From b7390f7e04f2e10cbadeb0c7e146c7485981905c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 27 Apr 2022 14:25:43 -0600 Subject: [PATCH 001/629] Makes set_u_at_v and set_v_at_u public --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index fb969953c4..367cf44d58 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -34,7 +34,7 @@ module MOM_set_visc #include public set_viscous_BBL, set_viscous_ML, set_visc_init, set_visc_end -public set_visc_register_restarts +public set_visc_register_restarts, set_u_at_v, set_v_at_u ! 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 From 9c103f1f9701796005e9a1fecee2d72e1a7daaa5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 27 Apr 2022 16:43:28 -0600 Subject: [PATCH 002/629] First draft for fpmix --- src/core/MOM_dynamics_split_RK2.F90 | 78 ++- .../vertical/MOM_vert_friction.F90 | 610 ++++++++++++++++++ 2 files changed, 687 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 06d828de96..8c3612f50b 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -68,6 +68,9 @@ module MOM_dynamics_split_RK2 use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member implicit none ; private @@ -131,6 +134,8 @@ module MOM_dynamics_split_RK2 real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure !! anomaly in each layer due to free surface height !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] @@ -159,10 +164,12 @@ module MOM_dynamics_split_RK2 !! Euler (1) [nondim]. 0 is often used. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. + logical :: fpmix !< If true, apply profiles of MTM flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. !>@{ Diagnostic IDs + integer :: id_uold = -1, id_vold = -1 integer :: id_uh = -1, id_vh = -1 integer :: id_umo = -1, id_vmo = -1 integer :: id_umo_2d = -1, id_vmo_2d = -1 @@ -320,6 +327,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! eta_pred is the predictor value of the free surface height or column mass, ! [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold + ! uold and vold are the velocities before vert_visc is applied. These arrays + ! are only used if fpmix is enabled [L T-1 ~> m s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! u_old_rad_OBC and v_old_rad_OBC are the starting velocities, which are @@ -348,8 +360,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. - + logical :: LU_pred ! Controls if it is predictor step or not logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating @@ -629,10 +642,41 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = up(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = vp(i,J,k) + enddo + enddo + enddo + endif + call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + if (CS%fpmix) then + LU_pred = .true. + hbl(:,:) = 0.0 + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + call vertFPmix(LU_pred, up, vp, uold, vold, hbl, h, forces, & + dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) @@ -847,9 +891,36 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k = 1, nz + do j = js , je + do I = Isq, Ieq + uold(I,j,k) = u(I,j,k) + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + vold(i,J,k) = v(i,J,k) + enddo + enddo + enddo + endif + call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) + + if (CS%fpmix) then + LU_pred = .false. + call vertFPmix(LU_pred, u, v, uold, vold, hbl, h, forces, dt, & + G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) @@ -914,6 +985,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s enddo ; enddo enddo + if (CS%fpmix) then + if (CS%id_uold > 0) call post_data(CS%id_uold , uold, CS%diag) + if (CS%id_vold > 0) call post_data(CS%id_vold , vold, CS%diag) + endif + ! The time-averaged free surface height has already been set by the last call to btstep. ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d384500c3d..d5a7aa9804 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -3,6 +3,7 @@ module MOM_vert_friction ! This file is part of MOM6. See LICENSE.md for the license. use MOM_domains, only : pass_var, To_All, Omit_corners +use MOM_domains, only : pass_vector, Scalar_Pair use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_u, post_product_sum_u use MOM_diag_mediator, only : post_product_v, post_product_sum_v @@ -31,6 +32,7 @@ module MOM_vert_friction public vertvisc, vertvisc_remnant, vertvisc_coef public vertvisc_limit_vel, vertvisc_init, vertvisc_end public updateCFLtruncationValue +public vertFPmix ! 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 @@ -126,6 +128,9 @@ module MOM_vert_friction integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 + integer :: id_FPmask_u = -1, id_FPmask_v = -1 , id_FPhbl_u = -1, id_FPhbl_v = -1 + integer :: id_tauFP_u = -1, id_tauFP_v = -1 , id_FPtau2x_u = -1, id_FPtau2x_v = -1 + integer :: id_FPtau2s_u = -1, id_FPtau2s_v = -1, id_FPtau2w_u = -1, id_FPtau2w_v = -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 @@ -142,6 +147,579 @@ module MOM_vert_friction contains +!> Add nonlocal momentum flux profile increments +!! TODO: add more description +subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) ! FPmix + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uold !< Old Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vold !< Old Meridional velocity [L T-1 ~> m s-1] + 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) :: hbl_h ! boundary layer depth + logical, intent(inout) :: LU_pred !w predictor step or NOT + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + + ! local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: mask3d_u !Test Plots @ 3-D centers + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: mask3d_v + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !2-D + real, dimension(SZI_(G),SZJB_(G)) :: hbl_v + integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u + integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v + real, dimension(SZI_(G),SZJ_(G)) :: ustar2_h !2-D surface + real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u + real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v + real, dimension(SZIB_(G),SZJ_(G)) :: taux_u + real, dimension(SZI_(G),SZJB_(G)) :: tauy_v + real, dimension(SZIB_(G),SZJ_(G)) :: tauy_u + real, dimension(SZI_(G),SZJB_(G)) :: taux_v + real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u + real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !3-D interfaces + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2x_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2x_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_s2x_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_s2x_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_s2w_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_s2w_v + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: du_rot !3-D centers + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: dv_rot + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: vi_u + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: ui_v + + real :: tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, MAXinc, MINthick + real :: du, dv, du_v, dv_u , dup, dvp , uZero, vZero + real :: fEQband, Cemp_SS , Cemp_LS , Cemp_CG, Cemp_DG , Wgt_SS + real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG + real :: pi, tmp, cos_tmp, sin_tmp, depth, taux, tauy, tauk, tauxI , tauyI, sign_f + real :: tauxh, tauyh, tauh, omega_s2xh, omega_s2wh, omega_tau2xh, omega_tau2wh + real :: taux0, tauy0, tau0, sigma, G_sig, Wind_x, Wind_y, omega_w2s, omega_tau2s,omega_s2x + real :: omega_tau2x, omega_tau2w, omega_SS, omega_LS, omega_tmp, omega_s2xI, omega_s2w + integer :: kblmin, kbld, kp, km, kp1, L19 ,jNseam + 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 + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke + + pi = 4. * atan2(1.,1.) + L19 = 1 !w Options A = 1, B = 2, C = 3 + Cemp_CG = 3.6 !w L91 cross-gradient + Cemp_DG = 1.0 !w L91 down-gradient + MAXinc = -1.0 !w if positive + MINthick= 0.01 !w GV%H_subroundoff !w 0.5 + kblmin = 1 + jNseam = 457 !w north seam = SZJ_(G) + +if(LU_pred ) then !w predictor step only, surface forcing + ustar2_h(:,:) = 0. + do j = js,je !w ?GMM -1,+1 with forces% + do i = is,ie + ustar2_h(i,j) = forces%ustar(i,j) * forces%ustar(i,j) + !w omega_w2x_h(i,j) = forces%omega_w2x(i,j) + enddo + enddo + call pass_var(ustar2_h ,G%Domain) ! update halos ?GMM + call pass_var( hbl_h ,G%Domain) + +! SURFACE ustar2 and x-stress to u points and ustar2 and y-stress to v points + ustar2_u(:,:) = 0. + ustar2_v(:,:) = 0. + hbl_u(:,:) = 0. + hbl_v(:,:) = 0. + taux_u(:,:) = 0. + tauy_v(:,:) = 0. + do j = js,je + do I = Isq,Ieq + tmp = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) + ustar2_u(I,j)=(G%mask2dT(i,j)*ustar2_h(i,j)+G%mask2dT(i+1,j)*ustar2_h(i+1,j))/tmp + hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j)* hbl_h(i+1,j)) /tmp + taux_u(I,j) = forces%taux(I,j) / GV%H_to_RZ + enddo + enddo + do J = Jsq,Jeq + do i = is,ie + tmp = MAX ( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1) ) ) + ustar2_u(I,j)=(G%mask2dT(i,j)*ustar2_h(i,j)+G%mask2dT(i+1,j)*ustar2_h(i+1,j))/tmp + hbl_v(i,J) = (G%mask2dT(i,j)* hbl_h(i,J) + G%mask2dT(i,j+1)* hbl_h(i,j+1)) /tmp + if( j > jNseam-1 ) then + ustar2_v(i,J) = ustar2_h(i,j ) !w ( j > 456 ) j >= 457 + hbl_v(i,J) = hbl_h(i,j) + endif + tauy_v(i,J) = forces%tauy(i,J) / GV%H_to_RZ + enddo + enddo + call pass_vector(taux_u , tauy_v, G%Domain, To_All+Scalar_Pair) + if (CS%debug) then + call uvchksum("ustar2 ",ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum(" hbl ", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=0, scalar_pair=.true.) + endif +!W endif !w predictor step + +!w surface tauy_u , taux_v and omega_w2x_[u,v] & Implicit interface stresses tauxDG_u and tauyDG_v + tauy_u(:,:) = 0.0 + taux_v(:,:) = 0.0 + kbl_u(:,:) = 0 + kbl_v(:,:) = 0 + omega_w2x_u(:,:) = 0.0 + omega_w2x_v(:,:) = 0.0 + tauxDG_u(:,:,:) = 0.0 + tauyDG_v(:,:,:) = 0.0 + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + tauy = 0.0 + tmp = MAX(1.0, (G%mask2dCv(i,j) + G%mask2dCv(i,j-1) + G%mask2dCv(i+1,j) + G%mask2dCv(i+1,j-1) ) ) + if ( G%mask2dCv(i ,j ) > 0.5 ) tauy = tauy + tauy_v(i ,j ) + if ( G%mask2dCv(i ,j-1) > 0.5 ) tauy = tauy + tauy_v(i ,j-1) + if ( G%mask2dCv(i+1,j ) > 0.5 ) tauy = tauy + tauy_v(i+1,j ) + if ( G%mask2dCv(i+1,j-1) > 0.5 ) tauy = tauy + tauy_v(i+1,j-1) + tauy = tauy / tmp + tauy_u(I,j) = (tauy/(abs(tauy)+GV%H_subroundoff)) * sqrt(MAX(GV%H_subroundoff,ustar2_u(I,j)*ustar2_u(I,j)-taux_u(I,j)*taux_u(I,j) )) + omega_w2x_u(I,j) = atan2( tauy_u(I,j) , taux_u(I,j) ) + tauxDG_u(I,j,1) = taux_u(I,j) !w ustar2_u(I,j) * cos(omega_w2x_u(I,j)) + depth = 0.0 + do k = 1, nz + depth = depth + CS%h_u(I,j,k) + if( (depth .ge. hbl_u(I,j)) .and. (kbl_u(I,j) .eq. 0 ) .and. (k > (kblmin-1)) ) then + kbl_u(I,j) = k + hbl_u(I,j) = depth + endif + enddo + endif + enddo + enddo + do J = Jsq,Jeq + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + taux = 0.0 + if ( j < 457 ) then + tmp = MAX(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1) ) ) + if ( G%mask2dCu(i ,j ) > 0.5 ) taux = taux + taux_u(i ,j ) + if ( G%mask2dCu(i ,j+1) > 0.5 ) taux = taux + taux_u(i ,j+1) + if ( G%mask2dCu(i-1,j ) > 0.5 ) taux = taux + taux_u(i-1,j ) + if ( G%mask2dCu(i-1,j+1) > 0.5 ) taux = taux + taux_u(i-1,j+1) + else + tmp = MAX(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i-1,j) ) ) + if ( G%mask2dCu(i ,j ) > 0.5 ) taux = taux + taux_u(i ,j ) + if ( G%mask2dCu(i-1,j ) > 0.5 ) taux = taux + taux_u(i-1,j ) + endif + taux = taux / tmp + taux_v(i,J) = (taux/(abs(taux)+GV%H_subroundoff)) * sqrt(MAX(GV%H_subroundoff,ustar2_v(i,J)*ustar2_v(i,J)-tauy_v(i,J)*tauy_v(i,J) )) + omega_w2x_v(i,J) = atan2( tauy_v(i,J) , taux_v(i,J) ) + tauyDG_v(i,J,1) = tauy_v(i,J) !w ustar2_v(i,J) * cos(omega_w2x_v(i,J)) + depth = 0.0 + do k = 1, nz + depth = depth + CS%h_v(i,J,k) + if( (depth .ge. hbl_v(i,J)) .and. (kbl_v(i,J) .eq. 0 ) .and. (k > (kblmin-1)) ) then + kbl_v(i,J) = k + hbl_v(i,J) = depth + endif + enddo + endif + enddo + enddo +endif !w predictor step + +! Thickness weighted diagnostic interpolations ! Copy Implicit [uv]i to [uv]old + call pass_vector(ui,vi, G%Domain, To_All+Scalar_Pair) + vi_u(:,:,:) = 0. + ui_v(:,:,:) = 0. + tauxDG_u(:,:,:) = 0.0 + tauyDG_v(:,:,:) = 0.0 + tauxDG_v(:,:,:) = 0. + tauyDG_u(:,:,:) = 0. + do k = 1, nz + kp = MIN( k+1 , nz) + do j = js-1 ,je+1 + do I = Isq-1, Ieq+1 + tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp) * (ui(I,j,k) - ui(I,j,kp)) + enddo + enddo + do J = Jsq-1, Jeq+1 + do i = is-1, ie+1 + tauyDG_v(i,J,k+1) = CS%a_v(i,J,kp) * (vi(i,J,k) - vi(i,J,kp)) + enddo + enddo + + ! v to u points + do j = js , je + do I = Isq, Ieq + vi_u(I,j,k) = set_v_at_u(vi, h, G, GV, I, j, k, G%mask2dCv, OBC) + tauyDG_u(I,j,k)= set_v_at_u(tauyDG_v, h, G, GV, I, j, k, G%mask2dCv, OBC) + enddo + enddo + ! u to v points + do J = Jsq, Jeq + do i = is, ie + ui_v(I,j,k) = set_u_at_v(ui, h, G, GV, i, J, k, G%mask2dCu, OBC) + tauxDG_v(i,J,k)= set_u_at_v(tauxDG_u, h, G, GV, i, J, k, G%mask2dCu, OBC) + enddo + enddo + enddo + if (CS%debug) then + call uvchksum(" vi_u ui_v ", vi_u , ui_v , G%HI, haloshift=0, scalar_pair=.true.) + endif + +! compute angles, tau2x_[u,v], tau2w_[u,v], tau2s_[u,v], s2x_[u,v], s2w_[u,v] and stress mag tau_[u,v] + omega_tau2x_u(:,:,:) = 0.0 + omega_tau2x_v(:,:,:) = 0.0 + omega_tau2w_u(:,:,:) = 0.0 + omega_tau2w_v(:,:,:) = 0.0 + omega_tau2s_u(:,:,:) = 0.0 + omega_tau2s_v(:,:,:) = 0.0 + omega_s2x_u(:,:,:) = 0.0 + omega_s2x_v(:,:,:) = 0.0 + omega_s2w_u(:,:,:) = 0. + omega_s2w_v(:,:,:) = 0. + tau_u(:,:,:) = 0.0 + tau_v(:,:,:) = 0.0 + +!w Default implicit (I) stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] Profiles + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + tauyDG_u(I,j,1) = tauy_u(I,j) ! SURFACE + tau_u(I,j,1) = ustar2_u(I,j) !w stress magnitude + Omega_tau2w_u(I,j,1) = 0.0 + Omega_tau2x_u(I,j,1) = omega_w2x_u(I,j) + Omega_tau2s_u(I,j,1) = 0.0 + omega_s2x_u(I,j,1) = omega_w2x_u(I,j) + omega_s2w_u(I,j,1) = 0.0 + + do k=1,nz + kp1 = MIN(k+1 , nz) + tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) + Omega_tau2x_u(I,j,k+1) = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) + + du = ui(i,J,k) - ui(i,J,kp1) + dv = vi_u(i,J,k) - vi_u(i,J,kp1) + omega_s2x_u(I,j,k+1) = atan2( dv , du) !w ~ Omega_tau2x + + omega_tmp = Omega_tau2x_u(I,j,k+1) - omega_w2x_u(I,j) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tmp + + omega_tmp = Omega_tau2x_u(I,j,k+1) - omega_s2x_u(I,j,k+1) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2s_u(I,j,k+1) = omega_tmp !w ~ 0 + + omega_tmp = omega_s2x_u(I,j,k+1) - omega_w2x_u(I,j) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + omega_s2w_u(I,j,k+1) = omega_tmp !w ~ Omega_tau2w + + enddo + endif + enddo + enddo + do J = Jsq, Jeq + do i = is, ie + if( (G%mask2dCv(i,J) > 0.5) ) then + tauxDG_v(i,J,1) = taux_v(i,J) ! SURFACE + tau_v(i,J,1) = ustar2_v(i,J) + Omega_tau2w_v(i,J,1) = 0.0 + Omega_tau2x_v(i,J,1) = omega_w2x_v(i,J) + Omega_tau2s_v(i,J,1) = 0.0 + omega_s2x_v(i,J,1) = omega_w2x_v(i,J) + omega_s2w_v(i,J,1) = 0.0 + + do k=1,nz-1 + kp1 = MIN(k+1 , nz) + tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) + Omega_tau2x_v(i,J,k+1) = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) + + du = ui_v(i,J,k) - ui_v(i,J,kp1) + dv = vi(i,J,k) - vi(i,J,kp1) + omega_s2x_v(i,J,k+1) = atan2( dv , du ) !~ Omega_tau2x + + omega_tmp = Omega_tau2x_v(i,J,k+1) - omega_w2x_v(i,J) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2w_v(i,J,k+1) = omega_tmp + + omega_tmp = Omega_tau2x_v(i,J,k+1) - omega_s2x_v(i,J,k+1) + if (omega_tmp .gt. pi ) omega_tmp = omega_tmp - 2.*pi + if (omega_tmp .le. (0.-pi) ) omega_tmp = omega_tmp + 2.*pi + Omega_tau2s_v(i,J,k+1) = omega_tmp !w ~ 0 + + omega_tmp = omega_s2x_v(i,J,k+1) - omega_w2x_v(i,J) + if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi + if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi + omega_s2w_v(i,J,k+1) = omega_tmp !w ~ Omega_tau2w + + enddo + endif + enddo + enddo +! ********************************************************************************************** +!w Parameterized stress orientation from the wind at interfaces (tau2x) and centers (tau2x) OVERWRITE to kbl-interface above hbl + du_rot(:,:,:) = 0.0 + dv_rot(:,:,:) = 0.0 + mask3d_u(:,:,:) = 0.0 + mask3d_v(:,:,:) = 0.0 + do j = js,je !w U-points + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + kbld = MIN( (kbl_u(I,j)) , (nz-2) ) + if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 + !w if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 + + tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff + omega_tau2wh = omega_tau2w_u(I,j,kbld+1) + + depth = 0. ! surface boundary conditions + tauNLup = 0.0 + do k=1, kbld + depth = depth + CS%h_u(I,j,k) + if ( (L19 > 0) ) then + sigma = MIN ( 1.0 , depth / hbl_u(i,j) ) + G_sig = MIN ( 0.287 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (1.74392*sigma - 2.58538) ) ) + + tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) !w linear stress mag + omega_s2x = Omega_tau2x_u(I,j,k+1) + cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + Wind_x = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) !w taux_u primary + Wind_y = ustar2_u(I,j) * sin(omega_w2x_u(I,j)) !w tauy_u interpolated + tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) !wind in x' + tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) !WCG in y' + omega_w2s = atan2( tauNL_CG , tauNL_DG ) !W wind to shear x' (limiter) + omega_s2w = 0.0-omega_w2s + tauNL_CG = Cemp_CG * G_sig * tauNL_CG +!OPTIONS + if(L19 .eq. 1) then !A L19=1 + tau_MAG = MAX( tau_MAG , tauNL_CG ) + tauNL_DG = sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - tau_u(I,j,k+1) + endif + + if(L19 .eq. 2) then !B L19=2 + tauNL_CG = MIN( tauNL_CG , tau_MAG ) + tauNL_DG = sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - tau_u(I,j,k+1) + endif + + if(L19 .eq. 3) then !C L19=3 + tauNL_DG = tau_MAG - tau_u(I,j,k+1) + tau_MAG = sqrt( tau_MAG*tau_MAG + tauNL_CG*tauNL_CG ) + endif + omega_tmp = atan2( tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG) ) !W Limiters + + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) !w back to x,y coordinates + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) + tauNLdn = tauNL_X ! SOLUTION + du_rot(I,j,k) = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) + tauNLup = tauNLdn + + mask3d_u(I,j,k) = tauNL_CG / (tau_MAG) !W (tauNLup - tauNLdn) + mask3d_v(i,j,k) = (tau_u(I,j,k+1)+tauNL_DG) / (tau_MAG) + ! DIAGNOSTICS + tau_u(I,j,k+1) = sqrt( (tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2 ) + omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y) , (tauxDG_u(I,j,k+1) + tauNL_X) ) + + omega_tau2w = omega_tau2x - omega_w2x_u(I,j) + if (omega_tau2w .gt. pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tau2w + Omega_tau2s_u(I,j,k+1) = omega_tmp !W omega_tau2x - Omega_tau2x_u(I,j,k+1) + Omega_tau2x_u(I,j,k+1) = 0.0 - omega_w2s !W omega_s2x !W 0.0 - omega_w2s !W omega_tau2x + + endif + enddo + endif + enddo + enddo +!w V-point dv increment %%%%%%%%%%%%%%%%%%%%%%%%%%%% + do J = Jsq,Jeq + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + kbld = MIN( (kbl_v(i,J)) , (nz-2) ) + if ( tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1) ) kbld = kbld + 1 + tauh = tau_v(i,J,kbld+1) + omega_tau2wh = omega_tau2w_u(I,j,kbld+1) + + depth = 0. !surface boundary conditions + tauNLup = 0.0 + do k=1, kbld + depth = depth + CS%h_v(i,J,k) + if ( (L19 > 0) ) then + sigma = MIN ( 1.0 , (depth ) / hbl_v(I,J) ) + G_sig = MIN ( 0.287 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (1.74392*sigma - 2.58538) ) ) + + tau_MAG = (ustar2_v(i,J) * (1.-sigma) ) + (tauh * sigma ) !w linear stress + omega_s2x = Omega_tau2x_v(i,J,k+1) + cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + Wind_x = ustar2_v(i,J) * cos(omega_w2x_v(i,J)) !w taux_v interpolated + Wind_y = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) !w tauy_v primary + tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) + tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) !w WCG + omega_w2s = atan2( tauNL_CG , tauNL_DG ) ! tau2x' limiter + omega_s2w = 0.0 - omega_w2s + tauNL_CG = Cemp_CG * G_sig * tauNL_CG +!OPTIONS + if(L19 .eq. 1) then !A L19=1 + tau_MAG = MAX( tau_MAG , tauNL_CG ) + tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) + endif + + if(L19 .eq. 2) then !B L19=2 + tauNL_CG = MIN( tauNL_CG , tau_MAG ) + tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) + endif + + if(L19 .eq. 3) then !C L19=3 + tauNL_DG = 0.0 - tau_v(i,J,k+1) + tau_MAG + tau_MAG = sqrt( tau_MAG*tau_MAG + tauNL_CG*tauNL_CG ) + endif + + omega_tmp = atan2( tauNL_CG , tau_v(i,J,k+1) + tauNL_DG ) !W LIMITERS as (tauNL_CG / tau_MAG) + + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) ! back to x,y coordinate + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) + tauNLdn = tauNL_Y + dv_rot(i,J,k) = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) ! SOLUTION + tauNLup = tauNLdn + ! DIAGNOSTICS + tau_v(i,J,k+1) = sqrt( (tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2 ) + omega_tau2x = atan2( (tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X) ) + omega_tau2w = omega_tau2x - omega_w2x_v(i,J) + if (omega_tau2w .gt. pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + + Omega_tau2w_v(i,J,k+1) = omega_tau2w + Omega_tau2s_v(i,J,k+1) = omega_tmp !W omega_tau2x - Omega_tau2x_v(i,J,k+1) + Omega_tau2x_v(i,J,k+1) = 0.0 - omega_w2s !W omega_s2x !W 0.0 - omega_w2s !W omega_tau2x + endif + enddo + endif + enddo + enddo + if (CS%debug) then + call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("FP-omega_s2x ",omega_s2x_u,omega_s2x_v,G%HI,haloshift=0,scalar_pair=.true.) + call uvchksum("FP-omega_s2w ",omega_s2w_u,omega_s2w_v,G%HI,haloshift=0,scalar_pair=.true.) + call uvchksum("FP-omega_t2w ",omega_tau2x_u,omega_tau2x_v,G%HI,haloshift=0,scalar_pair=.true.) + call uvchksum("FP-omega_t2x ",omega_tau2x_u ,omega_tau2x_v ,G%HI,haloshift=0,scalar_pair=.true.) + call uvchksum("FP-d[uv]_rot ",du_rot, dv_rot, G%HI, haloshift=0,scalar_pair=.true.) + call uvchksum("FP-d[uv]_out ",uold , vold , G%HI, haloshift=0,scalar_pair=.true.) + endif + +!w OUTPUT + do k=1,nz + do j = js,je + do I = Isq,Ieq + ui(I,j,k) = uold(I,j,k) + du_rot(I,j,k) + uold(I,j,k) = du_rot(I,j,k) + enddo + enddo + do J = Jsq,Jeq + do i = is,ie + vi(i,J,k) = vold(i,J,k) + dv_rot(i,J,k) + vold(i,J,k) = dv_rot(i,J,k) + enddo + enddo + enddo + +if( LU_pred .eq. .false. ) then !W CONDITION DIAGNOSTIC OUTPUT THEN POST + do j = js,je + do I = Isq,Ieq + if( (G%mask2dCu(I,j) > 0.5) ) then + kbld = kbl_u(I,j) + ustar2 = ustar2_u(I,j) + tau_u(I,j,1) = tau_u(I,j,1) / ustar2 + Omega_tau2w_u(I,j,1) = Omega_tau2w_u(I,j,1) / pi + Omega_tau2x_u(I,j,1) = Omega_tau2x_u(I,j,1) / pi + Omega_tau2s_u(I,j,1) = Omega_tau2s_u(I,j,1) / pi + do k=1,nz + !w mask3d_u(I,j,k) = + tau_u(I,j,k+1) = tau_u(I,j,k+1) / ustar2 + Omega_tau2w_u(I,j,k+1) = Omega_tau2w_u(I,j,k+1) /pi + Omega_tau2x_u(I,j,k+1) = Omega_tau2x_u(I,j,k+1) /pi + Omega_tau2s_u(I,j,k+1) = Omega_tau2s_u(I,j,k+1) /pi + if( k .eq. kbld+2) then + tau_u(I,j,k) = 0.0 - tau_u(I,j,k) + Omega_tau2w_u(I,j,k) = 1.05 + Omega_tau2x_u(I,j,k) = 1.05 + Omega_tau2s_u(I,j,k) = 1.05 + endif + enddo + Omega_tau2x_u(I,j,nz+1) = omega_w2x_u(I,j) / pi + mask3d_u(I,j,nz) = ustar2_u(I,j) + mask3d_u(I,j,nz-1) = sqrt(taux_u(I,j)*taux_u(I,j) + tauy_u(I,j)*tauy_u(I,j) ) + endif + enddo + enddo + do J = Jsq,Jeq !w v-points + do i = is,ie + if( (G%mask2dCv(i,J) > 0.5) ) then + kbld = kbl_v(i,J) + ustar2 = ustar2_v(i,J) + tau_v(i,J,1) = tau_v(i,J,1) / ustar2 + Omega_tau2w_v(i,J,1) = Omega_tau2w_v(i,J,1) / pi + Omega_tau2x_v(i,J,1) = Omega_tau2x_v(i,J,1) / pi + Omega_tau2s_v(i,J,1) = Omega_tau2s_v(i,J,1) / pi + do k=1,nz + !w mask3d_v(i,J,k) = tauxDG_v(i,J,k) !w vi(i,J,k) - v(i,J,k) !w dv_rot(i,J,k) + tau_v(i,J,k+1) = tau_v(i,J,k+1) / ustar2 + Omega_tau2w_v(i,J,k+1) = Omega_tau2w_v(i,J,k+1) /pi + Omega_tau2x_v(i,J,k+1) = Omega_tau2x_v(i,J,k+1) /pi + Omega_tau2s_v(i,J,k+1) = Omega_tau2s_v(i,J,k+1) /pi + if( k .eq. kbld+2) then + tau_v(i,J,k) = 0.0 - tau_v(i,J,k) + Omega_tau2w_v(i,J,k) = 1.05 + Omega_tau2x_v(i,J,k) = 1.05 + Omega_tau2s_v(i,J,k) = 1.05 + endif + enddo + Omega_tau2x_v(i,J,nz+1) = omega_w2x_v(i,J) / pi + mask3d_v(i,J,nz) = ustar2_v(i,J) + mask3d_v(i,J,nz-1) = sqrt(taux_v(i,J)*taux_v(i,J) + tauy_v(i,J)*tauy_v(i,J) ) + endif + enddo + enddo + + if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) + if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) + if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) + if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) + if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) + if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) + if (CS%id_FPtau2x_u > 0) call post_data(CS%id_FPtau2x_u, omega_tau2x_u, CS%diag) + if (CS%id_FPtau2x_v > 0) call post_data(CS%id_FPtau2x_v, omega_tau2x_v, CS%diag) + if (CS%id_FPmask_u > 0) call post_data(CS%id_FPmask_u, mask3d_u, CS%diag) + if (CS%id_FPmask_v > 0) call post_data(CS%id_FPmask_v, mask3d_v, CS%diag) + if (CS%id_FPhbl_u > 0) call post_data(CS%id_FPhbl_u, hbl_u, CS%diag) + if (CS%id_FPhbl_v > 0) call post_data(CS%id_FPhbl_v, hbl_v, CS%diag) + + if (cs%debug) then + call uvchksum("post viscFPmix [ui,vi]",ui,vi,G%HI,haloshift=0,scalar_pair=.true.) + endif +endif ! LU_pred = false + +end subroutine vertFPmix + !> Perform a fully implicit vertical diffusion !! of momentum. Stress top and bottom boundary conditions are used. !! @@ -1828,6 +2406,38 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & thickness_units, conversion=GV%H_to_MKS) + !w FPmix + CS%id_FPhbl_u = register_diag_field('ocean_model', 'FPhbl_u', diag%axesCu1, Time, & + 'Boundary-Layer Depth (u-points)','m') !w , conversion=GV%H_to_MKS) + CS%id_FPhbl_v = register_diag_field('ocean_model', 'FPhbl_v', diag%axesCv1, Time, & + 'Boundary-Layer Depth (v-points)','m') + + CS%id_FPmask_u = register_diag_field('ocean_model', 'FPmask_u', diag%axesCuL, Time, & + 'FP overwrite mask (u-points)','binary') + CS%id_FPmask_v = register_diag_field('ocean_model', 'FPmask_v', diag%axesCvL, Time, & + 'FP overwrite mask (v-points)','binary') + + CS%id_tauFP_u = register_diag_field('ocean_model', 'tauFP_u', diag%axesCui, Time, & + 'Stress Mag Profile (u-points)', 'm2 s-2') !w , conversion=GV%H_to_MKS) + CS%id_tauFP_v = register_diag_field('ocean_model', 'tauFP_v', diag%axesCvi, Time, & + 'Stress Mag Profile (v-points)', 'm2 s-2') !w , conversion=GV%H_to_MKS) + + CS%id_FPtau2s_u = register_diag_field('ocean_model', 'FPtau2s_u', diag%axesCui, Time, & + 'stress from shear direction (u-points)', 'pi ') + CS%id_FPtau2s_v = register_diag_field('ocean_model', 'FPtau2s_v', diag%axesCvi, Time, & + 'stress from shear direction (v-points)', 'pi ') + + CS%id_FPtau2w_u = register_diag_field('ocean_model', 'FPtau2w_u', diag%axesCui, Time, & + 'stress from wind direction (u-points)', 'pi ') + CS%id_FPtau2w_v = register_diag_field('ocean_model', 'FPtau2w_v', diag%axesCvi, Time, & + 'stress from wind direction (v-points)', 'pi ') + + CS%id_FPtau2x_u = register_diag_field('ocean_model', 'FPs2w_u', diag%axesCui, Time, & + 'shear from wind (u-points)', 'pi ') + CS%id_FPtau2x_v = register_diag_field('ocean_model', 'FPs2w_v', diag%axesCvi, Time, & + 'shear from wind (v-points)', 'pi ' + ! w - end + CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_du_dt_visc > 0) call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) From cb65bdcefd1a51acea19767b5e12502798aba7ec Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 May 2022 14:33:09 -0600 Subject: [PATCH 003/629] Change name of logical Replaces LU_pred to L_diag, since now this logical only controls if diagnostics should be posted. --- src/core/MOM_dynamics_split_RK2.F90 | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 8c3612f50b..f6cf456f98 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -362,7 +362,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. - logical :: LU_pred ! Controls if it is predictor step or not + logical :: L_diag ! Controls if diagostics are posted in the vertFPmix logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating @@ -666,12 +666,12 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) if (CS%fpmix) then - LU_pred = .true. + L_diag = .false. hbl(:,:) = 0.0 if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) if (ASSOCIATED(CS%energetic_PBL_CSp)) & call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) - call vertFPmix(LU_pred, up, vp, uold, vold, hbl, h, forces, & + call vertFPmix(L_diag, up, vp, uold, vold, hbl, h, forces, & dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) @@ -914,8 +914,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (CS%fpmix) then - LU_pred = .false. - call vertFPmix(LU_pred, u, v, uold, vold, hbl, h, forces, dt, & + L_diag = .true. + call vertFPmix(L_diag, u, v, uold, vold, hbl, h, forces, dt, & G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) From 143d117527746736707c49444ad554cf3f3901d6 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 17 May 2022 15:22:07 -0600 Subject: [PATCH 004/629] Updates to vertFPmix This commit adds the latest updates to the vertFPmix subroutine after Bill Large did some cleaning. We have highlight places in the code where work must be done. --- .../vertical/MOM_vert_friction.F90 | 648 ++++++------------ 1 file changed, 227 insertions(+), 421 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index d5a7aa9804..1d4f7bf646 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -128,8 +128,8 @@ module MOM_vert_friction integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 - integer :: id_FPmask_u = -1, id_FPmask_v = -1 , id_FPhbl_u = -1, id_FPhbl_v = -1 - integer :: id_tauFP_u = -1, id_tauFP_v = -1 , id_FPtau2x_u = -1, id_FPtau2x_v = -1 + integer :: id_FPdiag_u = -1, id_FPdiag_v = -1 , id_FPw2x = -1 !W id_FPhbl_u = -1, id_FPhbl_v = -1 + integer :: id_tauFP_u = -1, id_tauFP_v = -1 !W, id_FPtau2x_u = -1, id_FPtau2x_v = -1 integer :: id_FPtau2s_u = -1, id_FPtau2s_v = -1, id_FPtau2w_u = -1, id_FPtau2w_v = -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 @@ -147,9 +147,8 @@ module MOM_vert_friction contains -!> Add nonlocal momentum flux profile increments -!! TODO: add more description -subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) ! FPmix +!> Add nonlocal stress increments to u^n (uold) and v^n (vold) using ui and vi. +subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -164,123 +163,77 @@ subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, U 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) :: hbl_h ! boundary layer depth - logical, intent(inout) :: LU_pred !w predictor step or NOT - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment [T ~> s] - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + logical, intent(in) :: L_diag !< controls if diagnostics should be posted + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! local variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: mask3d_u !Test Plots @ 3-D centers - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: mask3d_v - real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !2-D + ! WGL; TODO: add description to local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: FPdiag_u !< this is for ... + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: FPdiag_v + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u real, dimension(SZI_(G),SZJB_(G)) :: hbl_v integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v - real, dimension(SZI_(G),SZJ_(G)) :: ustar2_h !2-D surface real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v real, dimension(SZIB_(G),SZJ_(G)) :: taux_u real, dimension(SZI_(G),SZJB_(G)) :: tauy_v - real, dimension(SZIB_(G),SZJ_(G)) :: tauy_u - real, dimension(SZI_(G),SZJB_(G)) :: taux_v - real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u - real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v + real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u + real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !3-D interfaces + ! GMM; TODO: make arrays allocatable if possible + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2x_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2x_v real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_s2x_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_s2x_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_s2w_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_s2w_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: du_rot !3-D centers - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: dv_rot - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: vi_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: ui_v - - real :: tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, MAXinc, MINthick - real :: du, dv, du_v, dv_u , dup, dvp , uZero, vZero - real :: fEQband, Cemp_SS , Cemp_LS , Cemp_CG, Cemp_DG , Wgt_SS + + real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp, omega_tmp + real :: du, dv, depth, sigma, Wind_x, Wind_y + real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG - real :: pi, tmp, cos_tmp, sin_tmp, depth, taux, tauy, tauk, tauxI , tauyI, sign_f - real :: tauxh, tauyh, tauh, omega_s2xh, omega_s2wh, omega_tau2xh, omega_tau2wh - real :: taux0, tauy0, tau0, sigma, G_sig, Wind_x, Wind_y, omega_w2s, omega_tau2s,omega_s2x - real :: omega_tau2x, omega_tau2w, omega_SS, omega_LS, omega_tmp, omega_s2xI, omega_s2w - integer :: kblmin, kbld, kp, km, kp1, L19 ,jNseam + real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w + integer :: kblmin, kbld, kp1 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 Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke pi = 4. * atan2(1.,1.) - L19 = 1 !w Options A = 1, B = 2, C = 3 - Cemp_CG = 3.6 !w L91 cross-gradient - Cemp_DG = 1.0 !w L91 down-gradient - MAXinc = -1.0 !w if positive - MINthick= 0.01 !w GV%H_subroundoff !w 0.5 + Cemp_CG = 3.6 kblmin = 1 - jNseam = 457 !w north seam = SZJ_(G) + FPdiag_u(:,:,:) = 0.0 + FPdiag_v(:,:,:) = 0.0 + taux_u(:,:) = 0. + tauy_v(:,:) = 0. -if(LU_pred ) then !w predictor step only, surface forcing - ustar2_h(:,:) = 0. - do j = js,je !w ?GMM -1,+1 with forces% - do i = is,ie - ustar2_h(i,j) = forces%ustar(i,j) * forces%ustar(i,j) - !w omega_w2x_h(i,j) = forces%omega_w2x(i,j) - enddo - enddo - call pass_var(ustar2_h ,G%Domain) ! update halos ?GMM - call pass_var( hbl_h ,G%Domain) - -! SURFACE ustar2 and x-stress to u points and ustar2 and y-stress to v points - ustar2_u(:,:) = 0. - ustar2_v(:,:) = 0. - hbl_u(:,:) = 0. - hbl_v(:,:) = 0. - taux_u(:,:) = 0. - tauy_v(:,:) = 0. do j = js,je do I = Isq,Ieq - tmp = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) - ustar2_u(I,j)=(G%mask2dT(i,j)*ustar2_h(i,j)+G%mask2dT(i+1,j)*ustar2_h(i+1,j))/tmp - hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j)* hbl_h(i+1,j)) /tmp - taux_u(I,j) = forces%taux(I,j) / GV%H_to_RZ + taux_u(I,j) = forces%taux(I,j) / GV%H_to_RZ !W rho0=1035. enddo enddo + do J = Jsq,Jeq do i = is,ie - tmp = MAX ( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1) ) ) - ustar2_u(I,j)=(G%mask2dT(i,j)*ustar2_h(i,j)+G%mask2dT(i+1,j)*ustar2_h(i+1,j))/tmp - hbl_v(i,J) = (G%mask2dT(i,j)* hbl_h(i,J) + G%mask2dT(i,j+1)* hbl_h(i,j+1)) /tmp - if( j > jNseam-1 ) then - ustar2_v(i,J) = ustar2_h(i,j ) !w ( j > 456 ) j >= 457 - hbl_v(i,J) = hbl_h(i,j) - endif - tauy_v(i,J) = forces%tauy(i,J) / GV%H_to_RZ + tauy_v(i,J) = forces%tauy(i,J) / GV%H_to_RZ enddo enddo - call pass_vector(taux_u , tauy_v, G%Domain, To_All+Scalar_Pair) - if (CS%debug) then - call uvchksum("ustar2 ",ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) - call uvchksum(" hbl ", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) - call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=0, scalar_pair=.true.) - endif -!W endif !w predictor step -!w surface tauy_u , taux_v and omega_w2x_[u,v] & Implicit interface stresses tauxDG_u and tauyDG_v - tauy_u(:,:) = 0.0 - taux_v(:,:) = 0.0 - kbl_u(:,:) = 0 - kbl_v(:,:) = 0 + call pass_var( hbl_h ,G%Domain, halo=1 ) + call pass_vector(taux_u , tauy_v, G%Domain, To_All ) + ustar2_u(:,:) = 0. + ustar2_v(:,:) = 0. + hbl_u(:,:) = 0. + hbl_v(:,:) = 0. + kbl_u(:,:) = 0 + kbl_v(:,:) = 0 omega_w2x_u(:,:) = 0.0 omega_w2x_v(:,:) = 0.0 tauxDG_u(:,:,:) = 0.0 @@ -288,16 +241,14 @@ subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, U do j = js,je do I = Isq,Ieq if( (G%mask2dCu(I,j) > 0.5) ) then - tauy = 0.0 - tmp = MAX(1.0, (G%mask2dCv(i,j) + G%mask2dCv(i,j-1) + G%mask2dCv(i+1,j) + G%mask2dCv(i+1,j-1) ) ) - if ( G%mask2dCv(i ,j ) > 0.5 ) tauy = tauy + tauy_v(i ,j ) - if ( G%mask2dCv(i ,j-1) > 0.5 ) tauy = tauy + tauy_v(i ,j-1) - if ( G%mask2dCv(i+1,j ) > 0.5 ) tauy = tauy + tauy_v(i+1,j ) - if ( G%mask2dCv(i+1,j-1) > 0.5 ) tauy = tauy + tauy_v(i+1,j-1) - tauy = tauy / tmp - tauy_u(I,j) = (tauy/(abs(tauy)+GV%H_subroundoff)) * sqrt(MAX(GV%H_subroundoff,ustar2_u(I,j)*ustar2_u(I,j)-taux_u(I,j)*taux_u(I,j) )) - omega_w2x_u(I,j) = atan2( tauy_u(I,j) , taux_u(I,j) ) - tauxDG_u(I,j,1) = taux_u(I,j) !w ustar2_u(I,j) * cos(omega_w2x_u(I,j)) + tmp = MAX (1.0 ,(G%mask2dT(i,j) + G%mask2dT(i+1,j) ) ) + hbl_u(I,j) = (G%mask2dT(i,j)* hbl_h(i,j) + G%mask2dT(i+1,j) * hbl_h(i+1,j)) /tmp + tmp = MAX(1.0, (G%mask2dCv(i,j) + G%mask2dCv(i,j-1) + G%mask2dCv(i+1,j) + G%mask2dCv(i+1,j-1) ) ) + tauy = ( G%mask2dCv(i ,j )*tauy_v(i ,j ) + G%mask2dCv(i ,j-1)*tauy_v(i ,j-1) & + + G%mask2dCv(i+1,j )*tauy_v(i+1,j ) + G%mask2dCv(i+1,j-1)*tauy_v(i+1,j-1) ) / tmp + ustar2_u(I,j) = sqrt( taux_u(I,j)*taux_u(I,j) + tauy*tauy ) + omega_w2x_u(I,j) = atan2( tauy , taux_u(I,j) ) + tauxDG_u(I,j,1) = taux_u(I,j) depth = 0.0 do k = 1, nz depth = depth + CS%h_u(I,j,k) @@ -312,22 +263,14 @@ subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, U do J = Jsq,Jeq do i = is,ie if( (G%mask2dCv(i,J) > 0.5) ) then - taux = 0.0 - if ( j < 457 ) then - tmp = MAX(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1) ) ) - if ( G%mask2dCu(i ,j ) > 0.5 ) taux = taux + taux_u(i ,j ) - if ( G%mask2dCu(i ,j+1) > 0.5 ) taux = taux + taux_u(i ,j+1) - if ( G%mask2dCu(i-1,j ) > 0.5 ) taux = taux + taux_u(i-1,j ) - if ( G%mask2dCu(i-1,j+1) > 0.5 ) taux = taux + taux_u(i-1,j+1) - else - tmp = MAX(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i-1,j) ) ) - if ( G%mask2dCu(i ,j ) > 0.5 ) taux = taux + taux_u(i ,j ) - if ( G%mask2dCu(i-1,j ) > 0.5 ) taux = taux + taux_u(i-1,j ) - endif - taux = taux / tmp - taux_v(i,J) = (taux/(abs(taux)+GV%H_subroundoff)) * sqrt(MAX(GV%H_subroundoff,ustar2_v(i,J)*ustar2_v(i,J)-tauy_v(i,J)*tauy_v(i,J) )) - omega_w2x_v(i,J) = atan2( tauy_v(i,J) , taux_v(i,J) ) - tauyDG_v(i,J,1) = tauy_v(i,J) !w ustar2_v(i,J) * cos(omega_w2x_v(i,J)) + tmp = MAX ( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1) ) ) + hbl_v(i,J) = (G%mask2dT(i,j)* hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) /tmp + tmp = MAX(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1) ) ) + taux = ( G%mask2dCu(i ,j )*taux_u(i ,j ) + G%mask2dCu(i ,j+1)*taux_u(i ,j+1) & + + G%mask2dCu(i-1,j )*taux_u(i-1,j ) + G%mask2dCu(i-1,j+1)*taux_u(i-1,j+1) ) / tmp + ustar2_v(i,J) = sqrt( tauy_v(i,J)*tauy_v(i,J) + taux*taux ) + omega_w2x_v(i,J) = atan2( tauy_v(i,J) , taux ) + tauyDG_v(i,J,1) = tauy_v(i,J) depth = 0.0 do k = 1, nz depth = depth + CS%h_v(i,J,k) @@ -339,98 +282,80 @@ subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, U endif enddo enddo -endif !w predictor step - -! Thickness weighted diagnostic interpolations ! Copy Implicit [uv]i to [uv]old - call pass_vector(ui,vi, G%Domain, To_All+Scalar_Pair) - vi_u(:,:,:) = 0. - ui_v(:,:,:) = 0. - tauxDG_u(:,:,:) = 0.0 - tauyDG_v(:,:,:) = 0.0 - tauxDG_v(:,:,:) = 0. - tauyDG_u(:,:,:) = 0. + + if (CS%debug) then + call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=1, scalar_pair=.true.) + call uvchksum("ustar2 ",ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum(" hbl ", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) + endif + + ! Compute downgradient stresses do k = 1, nz - kp = MIN( k+1 , nz) - do j = js-1 ,je+1 - do I = Isq-1, Ieq+1 - tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp) * (ui(I,j,k) - ui(I,j,kp)) + kp1 = MIN( k+1 , nz) + do j = js ,je + do I = Isq , Ieq + tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp1) * (ui(I,j,k) - ui(I,j,kp1)) enddo enddo - do J = Jsq-1, Jeq+1 - do i = is-1, ie+1 - tauyDG_v(i,J,k+1) = CS%a_v(i,J,kp) * (vi(i,J,k) - vi(i,J,kp)) + do J = Jsq , Jeq + do i = is , ie + tauyDG_v(i,J,k+1) = CS%a_v(i,J,kp1) * (vi(i,J,k) - vi(i,J,kp1)) enddo enddo + enddo + + call pass_vector(tauxDG_u, tauyDG_v , G%Domain, To_All) + call pass_vector(ui,vi, G%Domain, To_All) + tauxDG_v(:,:,:) = 0. + tauyDG_u(:,:,:) = 0. + ! Thickness weighted interpolations + do k = 1, nz ! v to u points do j = js , je do I = Isq, Ieq - vi_u(I,j,k) = set_v_at_u(vi, h, G, GV, I, j, k, G%mask2dCv, OBC) - tauyDG_u(I,j,k)= set_v_at_u(tauyDG_v, h, G, GV, I, j, k, G%mask2dCv, OBC) + tauyDG_u(I,j,k) = set_v_at_u(tauyDG_v, h, G, GV, I, j, k, G%mask2dCv, OBC) enddo enddo ! u to v points do J = Jsq, Jeq do i = is, ie - ui_v(I,j,k) = set_u_at_v(ui, h, G, GV, i, J, k, G%mask2dCu, OBC) - tauxDG_v(i,J,k)= set_u_at_v(tauxDG_u, h, G, GV, i, J, k, G%mask2dCu, OBC) + tauxDG_v(i,J,k) = set_u_at_v(tauxDG_u, h, G, GV, i, J, k, G%mask2dCu, OBC) enddo enddo enddo if (CS%debug) then - call uvchksum(" vi_u ui_v ", vi_u , ui_v , G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum(" tauyDG_u tauxDG_v",tauyDG_u,tauxDG_v, G%HI, haloshift=0, scalar_pair=.true.) endif -! compute angles, tau2x_[u,v], tau2w_[u,v], tau2s_[u,v], s2x_[u,v], s2w_[u,v] and stress mag tau_[u,v] - omega_tau2x_u(:,:,:) = 0.0 - omega_tau2x_v(:,:,:) = 0.0 + ! compute angles, tau2x_[u,v], tau2w_[u,v], tau2s_[u,v], s2w_[u,v] and stress mag tau_[u,v] omega_tau2w_u(:,:,:) = 0.0 omega_tau2w_v(:,:,:) = 0.0 omega_tau2s_u(:,:,:) = 0.0 omega_tau2s_v(:,:,:) = 0.0 - omega_s2x_u(:,:,:) = 0.0 - omega_s2x_v(:,:,:) = 0.0 - omega_s2w_u(:,:,:) = 0. - omega_s2w_v(:,:,:) = 0. tau_u(:,:,:) = 0.0 tau_v(:,:,:) = 0.0 -!w Default implicit (I) stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] Profiles + !w Default implicit (I) stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] Profiles do j = js,je do I = Isq,Ieq if( (G%mask2dCu(I,j) > 0.5) ) then - tauyDG_u(I,j,1) = tauy_u(I,j) ! SURFACE - tau_u(I,j,1) = ustar2_u(I,j) !w stress magnitude + ! SURFACE + tauyDG_u(I,j,1) = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) + tau_u(I,j,1) = ustar2_u(I,j) Omega_tau2w_u(I,j,1) = 0.0 - Omega_tau2x_u(I,j,1) = omega_w2x_u(I,j) Omega_tau2s_u(I,j,1) = 0.0 - omega_s2x_u(I,j,1) = omega_w2x_u(I,j) - omega_s2w_u(I,j,1) = 0.0 + ! WGL; TODO: can we use set_v_at_u to get tauyDG_u? do k=1,nz kp1 = MIN(k+1 , nz) tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) - Omega_tau2x_u(I,j,k+1) = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) - - du = ui(i,J,k) - ui(i,J,kp1) - dv = vi_u(i,J,k) - vi_u(i,J,kp1) - omega_s2x_u(I,j,k+1) = atan2( dv , du) !w ~ Omega_tau2x - - omega_tmp = Omega_tau2x_u(I,j,k+1) - omega_w2x_u(I,j) + Omega_tau2x = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) + omega_tmp = Omega_tau2x - omega_w2x_u(I,j) if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi Omega_tau2w_u(I,j,k+1) = omega_tmp - - omega_tmp = Omega_tau2x_u(I,j,k+1) - omega_s2x_u(I,j,k+1) - if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi - if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi - Omega_tau2s_u(I,j,k+1) = omega_tmp !w ~ 0 - - omega_tmp = omega_s2x_u(I,j,k+1) - omega_w2x_u(I,j) - if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi - if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi - omega_s2w_u(I,j,k+1) = omega_tmp !w ~ Omega_tau2w - + Omega_tau2s_u(I,j,k+1) = 0.0 enddo endif enddo @@ -438,49 +363,30 @@ subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, U do J = Jsq, Jeq do i = is, ie if( (G%mask2dCv(i,J) > 0.5) ) then - tauxDG_v(i,J,1) = taux_v(i,J) ! SURFACE + ! SURFACE + tauxDG_v(i,J,1) = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) tau_v(i,J,1) = ustar2_v(i,J) Omega_tau2w_v(i,J,1) = 0.0 - Omega_tau2x_v(i,J,1) = omega_w2x_v(i,J) Omega_tau2s_v(i,J,1) = 0.0 - omega_s2x_v(i,J,1) = omega_w2x_v(i,J) - omega_s2w_v(i,J,1) = 0.0 + ! WGL; TODO: can we use set_u_at_v to get tauxDG_v? do k=1,nz-1 kp1 = MIN(k+1 , nz) tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) - Omega_tau2x_v(i,J,k+1) = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) - - du = ui_v(i,J,k) - ui_v(i,J,kp1) - dv = vi(i,J,k) - vi(i,J,kp1) - omega_s2x_v(i,J,k+1) = atan2( dv , du ) !~ Omega_tau2x - - omega_tmp = Omega_tau2x_v(i,J,k+1) - omega_w2x_v(i,J) + omega_tau2x = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) + omega_tmp = omega_tau2x - omega_w2x_v(i,J) if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi Omega_tau2w_v(i,J,k+1) = omega_tmp - - omega_tmp = Omega_tau2x_v(i,J,k+1) - omega_s2x_v(i,J,k+1) - if (omega_tmp .gt. pi ) omega_tmp = omega_tmp - 2.*pi - if (omega_tmp .le. (0.-pi) ) omega_tmp = omega_tmp + 2.*pi - Omega_tau2s_v(i,J,k+1) = omega_tmp !w ~ 0 - - omega_tmp = omega_s2x_v(i,J,k+1) - omega_w2x_v(i,J) - if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi - if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi - omega_s2w_v(i,J,k+1) = omega_tmp !w ~ Omega_tau2w - + Omega_tau2s_v(i,J,k+1) = 0.0 enddo endif enddo enddo -! ********************************************************************************************** -!w Parameterized stress orientation from the wind at interfaces (tau2x) and centers (tau2x) OVERWRITE to kbl-interface above hbl - du_rot(:,:,:) = 0.0 - dv_rot(:,:,:) = 0.0 - mask3d_u(:,:,:) = 0.0 - mask3d_v(:,:,:) = 0.0 - do j = js,je !w U-points + + ! Parameterized stress orientation from the wind at interfaces (tau2x) + ! and centers (tau2x) OVERWRITE to kbl-interface above hbl + do j = js,je do I = Isq,Ieq if( (G%mask2dCu(I,j) > 0.5) ) then kbld = MIN( (kbl_u(I,j)) , (nz-2) ) @@ -488,238 +394,151 @@ subroutine vertFPmix(LU_pred, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, U !w if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff - omega_tau2wh = omega_tau2w_u(I,j,kbld+1) - - depth = 0. ! surface boundary conditions + ! surface boundary conditions + depth = 0. tauNLup = 0.0 do k=1, kbld depth = depth + CS%h_u(I,j,k) - if ( (L19 > 0) ) then - sigma = MIN ( 1.0 , depth / hbl_u(i,j) ) - G_sig = MIN ( 0.287 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (1.74392*sigma - 2.58538) ) ) - - tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) !w linear stress mag - omega_s2x = Omega_tau2x_u(I,j,k+1) - cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) - sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) - Wind_x = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) !w taux_u primary - Wind_y = ustar2_u(I,j) * sin(omega_w2x_u(I,j)) !w tauy_u interpolated - tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) !wind in x' - tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) !WCG in y' - omega_w2s = atan2( tauNL_CG , tauNL_DG ) !W wind to shear x' (limiter) - omega_s2w = 0.0-omega_w2s - tauNL_CG = Cemp_CG * G_sig * tauNL_CG -!OPTIONS - if(L19 .eq. 1) then !A L19=1 - tau_MAG = MAX( tau_MAG , tauNL_CG ) - tauNL_DG = sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - tau_u(I,j,k+1) - endif - - if(L19 .eq. 2) then !B L19=2 - tauNL_CG = MIN( tauNL_CG , tau_MAG ) - tauNL_DG = sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - tau_u(I,j,k+1) - endif - - if(L19 .eq. 3) then !C L19=3 - tauNL_DG = tau_MAG - tau_u(I,j,k+1) - tau_MAG = sqrt( tau_MAG*tau_MAG + tauNL_CG*tauNL_CG ) - endif - omega_tmp = atan2( tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG) ) !W Limiters - - tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) !w back to x,y coordinates - tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) - tauNLdn = tauNL_X ! SOLUTION - du_rot(I,j,k) = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) - tauNLup = tauNLdn - - mask3d_u(I,j,k) = tauNL_CG / (tau_MAG) !W (tauNLup - tauNLdn) - mask3d_v(i,j,k) = (tau_u(I,j,k+1)+tauNL_DG) / (tau_MAG) - ! DIAGNOSTICS - tau_u(I,j,k+1) = sqrt( (tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2 ) - omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y) , (tauxDG_u(I,j,k+1) + tauNL_X) ) - - omega_tau2w = omega_tau2x - omega_w2x_u(I,j) - if (omega_tau2w .gt. pi ) omega_tau2w = omega_tau2w - 2.*pi - if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi - Omega_tau2w_u(I,j,k+1) = omega_tau2w - Omega_tau2s_u(I,j,k+1) = omega_tmp !W omega_tau2x - Omega_tau2x_u(I,j,k+1) - Omega_tau2x_u(I,j,k+1) = 0.0 - omega_w2s !W omega_s2x !W 0.0 - omega_w2s !W omega_tau2x - - endif + sigma = MIN ( 1.0 , depth / hbl_u(i,j) ) + + ! linear stress mag + tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) + cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) + + ! rotate to wind coordinates + Wind_x = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) + Wind_y = ustar2_u(I,j) * sin(omega_w2x_u(I,j)) + tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) + tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) + omega_w2s = atan2( tauNL_CG , tauNL_DG ) + omega_s2w = 0.0-omega_w2s + tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG + tau_MAG = MAX( tau_MAG , tauNL_CG ) + tauNL_DG = sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - tau_u(I,j,k+1) + + ! back to x,y coordinates + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) + tauNLdn = tauNL_X + + ! nonlocal increment and update to uold + du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) + ui(I,j,k) = uold(I,j,k) + du + uold(I,j,k) = du + tauNLup = tauNLdn + + ! diagnostics + FPdiag_u(I,j,k+1) = tauNL_CG / (tau_MAG + GV%H_subroundoff) + Omega_tau2s_u(I,j,k+1) = atan2( tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG) ) + tau_u(I,j,k+1) = sqrt( (tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2 ) + omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y) , (tauxDG_u(I,j,k+1) + tauNL_X) ) + omega_tau2w = omega_tau2x - omega_w2x_u(I,j) + if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w <= (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_u(I,j,k+1) = omega_tau2w + enddo + do k= kbld+1, nz + ui(I,j,k) = uold(I,j,k) + uold(I,j,k) = 0.0 enddo endif enddo enddo -!w V-point dv increment %%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! v-point dv increment do J = Jsq,Jeq do i = is,ie if( (G%mask2dCv(i,J) > 0.5) ) then kbld = MIN( (kbl_v(i,J)) , (nz-2) ) if ( tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1) ) kbld = kbld + 1 tauh = tau_v(i,J,kbld+1) - omega_tau2wh = omega_tau2w_u(I,j,kbld+1) - depth = 0. !surface boundary conditions + !surface boundary conditions + depth = 0. tauNLup = 0.0 do k=1, kbld depth = depth + CS%h_v(i,J,k) - if ( (L19 > 0) ) then - sigma = MIN ( 1.0 , (depth ) / hbl_v(I,J) ) - G_sig = MIN ( 0.287 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (1.74392*sigma - 2.58538) ) ) - - tau_MAG = (ustar2_v(i,J) * (1.-sigma) ) + (tauh * sigma ) !w linear stress - omega_s2x = Omega_tau2x_v(i,J,k+1) - cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) - sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) - Wind_x = ustar2_v(i,J) * cos(omega_w2x_v(i,J)) !w taux_v interpolated - Wind_y = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) !w tauy_v primary - tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) - tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) !w WCG - omega_w2s = atan2( tauNL_CG , tauNL_DG ) ! tau2x' limiter - omega_s2w = 0.0 - omega_w2s - tauNL_CG = Cemp_CG * G_sig * tauNL_CG -!OPTIONS - if(L19 .eq. 1) then !A L19=1 - tau_MAG = MAX( tau_MAG , tauNL_CG ) - tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - endif - - if(L19 .eq. 2) then !B L19=2 - tauNL_CG = MIN( tauNL_CG , tau_MAG ) - tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - endif - - if(L19 .eq. 3) then !C L19=3 - tauNL_DG = 0.0 - tau_v(i,J,k+1) + tau_MAG - tau_MAG = sqrt( tau_MAG*tau_MAG + tauNL_CG*tauNL_CG ) - endif + sigma = MIN ( 1.0 , (depth ) / hbl_v(I,J) ) + + ! linear stress + tau_MAG = (ustar2_v(i,J) * (1.-sigma) ) + (tauh * sigma ) + cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) + + ! rotate into wind coordinate + Wind_x = ustar2_v(i,J) * cos(omega_w2x_v(i,J)) + Wind_y = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) + tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) + tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) + omega_w2s = atan2( tauNL_CG , tauNL_DG ) + omega_s2w = 0.0 - omega_w2s + tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG + tau_MAG = MAX( tau_MAG , tauNL_CG ) + tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) + + ! back to x,y coordinate + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) + tauNLdn = tauNL_Y + dv = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) + vi(i,J,k) = vold(i,J,k) + dv + vold(i,J,k) = dv + tauNLup = tauNLdn + + ! diagnostics + FPdiag_v(i,j,k+1) = tau_MAG / tau_v(i,J,k+1) + Omega_tau2s_v(i,J,k+1) = atan2( tauNL_CG , tau_v(i,J,k+1) + tauNL_DG ) + tau_v(i,J,k+1) = sqrt( (tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2 ) + omega_tau2x = atan2( (tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X) ) + omega_tau2w = omega_tau2x - omega_w2x_v(i,J) + if (omega_tau2w .gt. pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi + Omega_tau2w_v(i,J,k+1) = omega_tau2w + enddo - omega_tmp = atan2( tauNL_CG , tau_v(i,J,k+1) + tauNL_DG ) !W LIMITERS as (tauNL_CG / tau_MAG) - - tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) ! back to x,y coordinate - tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) - tauNLdn = tauNL_Y - dv_rot(i,J,k) = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) ! SOLUTION - tauNLup = tauNLdn - ! DIAGNOSTICS - tau_v(i,J,k+1) = sqrt( (tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2 ) - omega_tau2x = atan2( (tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X) ) - omega_tau2w = omega_tau2x - omega_w2x_v(i,J) - if (omega_tau2w .gt. pi ) omega_tau2w = omega_tau2w - 2.*pi - if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi - - Omega_tau2w_v(i,J,k+1) = omega_tau2w - Omega_tau2s_v(i,J,k+1) = omega_tmp !W omega_tau2x - Omega_tau2x_v(i,J,k+1) - Omega_tau2x_v(i,J,k+1) = 0.0 - omega_w2s !W omega_s2x !W 0.0 - omega_w2s !W omega_tau2x - endif + do k= kbld+1, nz + vi(i,J,k) = vold(i,J,k) + vold(i,J,k) = 0.0 enddo endif enddo enddo + if (CS%debug) then call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) - call uvchksum("FP-omega_s2x ",omega_s2x_u,omega_s2x_v,G%HI,haloshift=0,scalar_pair=.true.) - call uvchksum("FP-omega_s2w ",omega_s2w_u,omega_s2w_v,G%HI,haloshift=0,scalar_pair=.true.) - call uvchksum("FP-omega_t2w ",omega_tau2x_u,omega_tau2x_v,G%HI,haloshift=0,scalar_pair=.true.) - call uvchksum("FP-omega_t2x ",omega_tau2x_u ,omega_tau2x_v ,G%HI,haloshift=0,scalar_pair=.true.) - call uvchksum("FP-d[uv]_rot ",du_rot, dv_rot, G%HI, haloshift=0,scalar_pair=.true.) - call uvchksum("FP-d[uv]_out ",uold , vold , G%HI, haloshift=0,scalar_pair=.true.) endif -!w OUTPUT - do k=1,nz - do j = js,je - do I = Isq,Ieq - ui(I,j,k) = uold(I,j,k) + du_rot(I,j,k) - uold(I,j,k) = du_rot(I,j,k) - enddo - enddo - do J = Jsq,Jeq - do i = is,ie - vi(i,J,k) = vold(i,J,k) + dv_rot(i,J,k) - vold(i,J,k) = dv_rot(i,J,k) - enddo - enddo - enddo - -if( LU_pred .eq. .false. ) then !W CONDITION DIAGNOSTIC OUTPUT THEN POST - do j = js,je - do I = Isq,Ieq - if( (G%mask2dCu(I,j) > 0.5) ) then - kbld = kbl_u(I,j) - ustar2 = ustar2_u(I,j) - tau_u(I,j,1) = tau_u(I,j,1) / ustar2 - Omega_tau2w_u(I,j,1) = Omega_tau2w_u(I,j,1) / pi - Omega_tau2x_u(I,j,1) = Omega_tau2x_u(I,j,1) / pi - Omega_tau2s_u(I,j,1) = Omega_tau2s_u(I,j,1) / pi - do k=1,nz - !w mask3d_u(I,j,k) = - tau_u(I,j,k+1) = tau_u(I,j,k+1) / ustar2 - Omega_tau2w_u(I,j,k+1) = Omega_tau2w_u(I,j,k+1) /pi - Omega_tau2x_u(I,j,k+1) = Omega_tau2x_u(I,j,k+1) /pi - Omega_tau2s_u(I,j,k+1) = Omega_tau2s_u(I,j,k+1) /pi - if( k .eq. kbld+2) then - tau_u(I,j,k) = 0.0 - tau_u(I,j,k) - Omega_tau2w_u(I,j,k) = 1.05 - Omega_tau2x_u(I,j,k) = 1.05 - Omega_tau2s_u(I,j,k) = 1.05 - endif - enddo - Omega_tau2x_u(I,j,nz+1) = omega_w2x_u(I,j) / pi - mask3d_u(I,j,nz) = ustar2_u(I,j) - mask3d_u(I,j,nz-1) = sqrt(taux_u(I,j)*taux_u(I,j) + tauy_u(I,j)*tauy_u(I,j) ) - endif - enddo - enddo - do J = Jsq,Jeq !w v-points - do i = is,ie - if( (G%mask2dCv(i,J) > 0.5) ) then - kbld = kbl_v(i,J) - ustar2 = ustar2_v(i,J) - tau_v(i,J,1) = tau_v(i,J,1) / ustar2 - Omega_tau2w_v(i,J,1) = Omega_tau2w_v(i,J,1) / pi - Omega_tau2x_v(i,J,1) = Omega_tau2x_v(i,J,1) / pi - Omega_tau2s_v(i,J,1) = Omega_tau2s_v(i,J,1) / pi - do k=1,nz - !w mask3d_v(i,J,k) = tauxDG_v(i,J,k) !w vi(i,J,k) - v(i,J,k) !w dv_rot(i,J,k) - tau_v(i,J,k+1) = tau_v(i,J,k+1) / ustar2 - Omega_tau2w_v(i,J,k+1) = Omega_tau2w_v(i,J,k+1) /pi - Omega_tau2x_v(i,J,k+1) = Omega_tau2x_v(i,J,k+1) /pi - Omega_tau2s_v(i,J,k+1) = Omega_tau2s_v(i,J,k+1) /pi - if( k .eq. kbld+2) then - tau_v(i,J,k) = 0.0 - tau_v(i,J,k) - Omega_tau2w_v(i,J,k) = 1.05 - Omega_tau2x_v(i,J,k) = 1.05 - Omega_tau2s_v(i,J,k) = 1.05 - endif - enddo - Omega_tau2x_v(i,J,nz+1) = omega_w2x_v(i,J) / pi - mask3d_v(i,J,nz) = ustar2_v(i,J) - mask3d_v(i,J,nz-1) = sqrt(taux_v(i,J)*taux_v(i,J) + tauy_v(i,J)*tauy_v(i,J) ) - endif - enddo - enddo - - if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) - if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) - if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) - if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) - if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) - if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) - if (CS%id_FPtau2x_u > 0) call post_data(CS%id_FPtau2x_u, omega_tau2x_u, CS%diag) - if (CS%id_FPtau2x_v > 0) call post_data(CS%id_FPtau2x_v, omega_tau2x_v, CS%diag) - if (CS%id_FPmask_u > 0) call post_data(CS%id_FPmask_u, mask3d_u, CS%diag) - if (CS%id_FPmask_v > 0) call post_data(CS%id_FPmask_v, mask3d_v, CS%diag) - if (CS%id_FPhbl_u > 0) call post_data(CS%id_FPhbl_u, hbl_u, CS%diag) - if (CS%id_FPhbl_v > 0) call post_data(CS%id_FPhbl_v, hbl_v, CS%diag) - - if (cs%debug) then - call uvchksum("post viscFPmix [ui,vi]",ui,vi,G%HI,haloshift=0,scalar_pair=.true.) + ! GMM; TODO: can you make the arrays used below allocatable? + if(L_diag) then + if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) + if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) + if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) + if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) + if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) + if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) + if (CS%id_FPdiag_u > 0) call post_data(CS%id_FPdiag_u, FPdiag_u, CS%diag) + if (CS%id_FPdiag_v > 0) call post_data(CS%id_FPdiag_v, FPdiag_v, CS%diag) + if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) endif -endif ! LU_pred = false end subroutine vertFPmix +!> Returns the empirical shape-function given sigma. +real function G_sig(sigma) + real , intent(in) :: sigma !< non-dimensional normalized boundary layer depth [m] + + ! local variables + real :: p1, c2, c3 !< parameters used to fit and match empirycal shape-functions. + + ! parabola + p1 = 0.287 + ! cubic function + c2 = 1.74392 + c3 = 2.58538 + G_sig = MIN ( p1 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (c2*sigma - c3) ) ) +end function G_sig + !> Perform a fully implicit vertical diffusion !! of momentum. Stress top and bottom boundary conditions are used. !! @@ -2406,37 +2225,24 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & thickness_units, conversion=GV%H_to_MKS) - !w FPmix - CS%id_FPhbl_u = register_diag_field('ocean_model', 'FPhbl_u', diag%axesCu1, Time, & - 'Boundary-Layer Depth (u-points)','m') !w , conversion=GV%H_to_MKS) - CS%id_FPhbl_v = register_diag_field('ocean_model', 'FPhbl_v', diag%axesCv1, Time, & - 'Boundary-Layer Depth (v-points)','m') - - CS%id_FPmask_u = register_diag_field('ocean_model', 'FPmask_u', diag%axesCuL, Time, & - 'FP overwrite mask (u-points)','binary') - CS%id_FPmask_v = register_diag_field('ocean_model', 'FPmask_v', diag%axesCvL, Time, & - 'FP overwrite mask (v-points)','binary') - + CS%id_FPw2x = register_diag_field('ocean_model', 'FPw2x', diag%axesT1, Time, & + 'Wind direction from x-axis','radians') + CS%id_FPdiag_u = register_diag_field('ocean_model', 'FPdiag_u', diag%axesCui, Time, & + 'FP diagmostic (u-points)','binary') + CS%id_FPdiag_v = register_diag_field('ocean_model', 'FPdiag_v', diag%axesCvi, Time, & + 'FP diagnostic (v-points)','binary') CS%id_tauFP_u = register_diag_field('ocean_model', 'tauFP_u', diag%axesCui, Time, & - 'Stress Mag Profile (u-points)', 'm2 s-2') !w , conversion=GV%H_to_MKS) + 'Stress Mag Profile (u-points)', 'm2 s-2') CS%id_tauFP_v = register_diag_field('ocean_model', 'tauFP_v', diag%axesCvi, Time, & - 'Stress Mag Profile (v-points)', 'm2 s-2') !w , conversion=GV%H_to_MKS) - + 'Stress Mag Profile (v-points)', 'm2 s-2') CS%id_FPtau2s_u = register_diag_field('ocean_model', 'FPtau2s_u', diag%axesCui, Time, & - 'stress from shear direction (u-points)', 'pi ') + 'stress from shear direction (u-points)', 'radians ') CS%id_FPtau2s_v = register_diag_field('ocean_model', 'FPtau2s_v', diag%axesCvi, Time, & - 'stress from shear direction (v-points)', 'pi ') - + 'stress from shear direction (v-points)', 'radians') CS%id_FPtau2w_u = register_diag_field('ocean_model', 'FPtau2w_u', diag%axesCui, Time, & - 'stress from wind direction (u-points)', 'pi ') + 'stress from wind direction (u-points)', 'radians') CS%id_FPtau2w_v = register_diag_field('ocean_model', 'FPtau2w_v', diag%axesCvi, Time, & - 'stress from wind direction (v-points)', 'pi ') - - CS%id_FPtau2x_u = register_diag_field('ocean_model', 'FPs2w_u', diag%axesCui, Time, & - 'shear from wind (u-points)', 'pi ') - CS%id_FPtau2x_v = register_diag_field('ocean_model', 'FPs2w_v', diag%axesCvi, Time, & - 'shear from wind (v-points)', 'pi ' - ! w - end + 'stress from wind direction (v-points)', 'radians') CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) From 7624a83b810e21616b089a772398d7d287ca7feb Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 24 May 2022 14:51:31 -0600 Subject: [PATCH 005/629] Add missing use for vertFPmix --- src/core/MOM_dynamics_split_RK2.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index f6cf456f98..b74df389b3 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -64,7 +64,7 @@ module MOM_dynamics_split_RK2 use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS -use MOM_vert_friction, only : updateCFLtruncationValue +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF From 864506e850d5ec4f72457e01bf3dea6305c8eb8c Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 24 May 2022 14:56:17 -0600 Subject: [PATCH 006/629] Add omega_w2x to fluxes and forces omega_w2x is the counter-clockwise angle of the wind stress with respect to the horizontal abscissa (x-coordinate) at tracer points [rad]. This variable is needed in the vertPFmix subroutine. --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 3 +++ src/core/MOM_forcing_type.F90 | 24 ++++++++++++++++++- .../vertical/MOM_vert_friction.F90 | 1 + 3 files changed, 27 insertions(+), 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 69841bf84a..41572b969e 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -311,6 +311,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & cfc=CS%use_CFC, hevap=CS%enthalpy_cpl) + call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -721,6 +722,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) + call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) if (CS%rigid_sea_ice) then call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -880,6 +882,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) if (CS%read_gust_2d .and. (G%mask2dT(i,j) > 0)) gustiness = CS%gust(i,j) forces%ustar(i,j) = sqrt(gustiness*Irho0 + Irho0 * G%mask2dT(i,j) * & sqrt(taux_at_h(i,j)**2 + tauy_at_h(i,j)**2)) + forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) else ! C-grid wind stresses. diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index d4afabc2de..9d95e7159f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -67,6 +67,7 @@ module MOM_forcing_type ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & + omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. ustar_gustless => NULL() !< surface friction velocity scale without any !! any augmentation for gustiness [Z T-1 ~> m s-1]. @@ -221,7 +222,9 @@ module MOM_forcing_type taux => NULL(), & !< zonal wind stress [R L Z T-2 ~> Pa] tauy => NULL(), & !< meridional wind stress [R L Z T-2 ~> Pa] ustar => NULL(), & !< surface friction velocity scale [Z T-1 ~> m s-1]. - net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + net_mass_src => NULL(), & !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect + !! to the horizontal abscissa (x-coordinate) at tracer points [rad]. ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -357,6 +360,7 @@ module MOM_forcing_type integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 + integer :: id_omega_w2x = -1 integer :: id_psurf = -1 integer :: id_TKE_tidal = -1 @@ -1320,6 +1324,9 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & 'm s-1', conversion=US%Z_to_m*US%s_to_T) + handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & + 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') + if (present(use_berg_fluxes)) then if (use_berg_fluxes) then handles%id_ustar_berg = register_diag_field('ocean_model', 'ustar_berg', diag%axesT1, Time, & @@ -2164,6 +2171,11 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) enddo ; enddo endif + if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + do j=js,je ; do i=is,ie + fluxes%omega_w2x(i,j) = forces%omega_w2x(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 @@ -2295,6 +2307,11 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) enddo ; enddo endif + if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + do j=js,je ; do i=is,ie + forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) + enddo ; enddo + endif end subroutine copy_back_forcing_fields !> Offer mechanical forcing fields for diagnostics for those @@ -2948,6 +2965,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) + if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & + call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) + if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) @@ -3264,6 +3284,7 @@ end subroutine myAlloc subroutine deallocate_forcing_type(fluxes) type(forcing), intent(inout) :: fluxes !< Forcing fields structure + if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) if (associated(fluxes%ustar)) deallocate(fluxes%ustar) if (associated(fluxes%ustar_gustless)) deallocate(fluxes%ustar_gustless) if (associated(fluxes%buoy)) deallocate(fluxes%buoy) @@ -3325,6 +3346,7 @@ subroutine deallocate_mech_forcing(forces) if (associated(forces%taux)) deallocate(forces%taux) if (associated(forces%tauy)) deallocate(forces%tauy) if (associated(forces%ustar)) deallocate(forces%ustar) + if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) 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) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 1d4f7bf646..605fda5dce 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -25,6 +25,7 @@ module MOM_vert_friction use MOM_variables, only : ocean_internal_state use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS +use MOM_set_visc, only : set_v_at_u, set_u_at_v implicit none ; private #include From 9b4bd84b5e3c7ac1cf67a19670e7197c9ea4cdf5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 21 Jun 2022 15:17:51 -0600 Subject: [PATCH 007/629] Add mssing call to get_param for FPMIX This line of code was lost during the last merge. --- src/core/MOM_dynamics_split_RK2.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index b74df389b3..288d7d9092 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -164,7 +164,7 @@ module MOM_dynamics_split_RK2 !! Euler (1) [nondim]. 0 is often used. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. - logical :: fpmix !< If true, apply profiles of MTM flux magnitude and direction. + logical :: fpmix !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -327,6 +327,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! eta_pred is the predictor value of the free surface height or column mass, ! [H ~> m or kg m-2]. + ! GMM, TODO: make these allocatable? real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! uold and vold are the velocities before vert_visc is applied. These arrays @@ -1278,6 +1279,9 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param "If true, use the summed layered fluxes plus an "//& "adjustment due to the change in the barotropic velocity "//& "in the barotropic continuity equation.", default=.true.) + call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + "If true, apply profiles of momentum flux magnitude and "//& + " direction", default=.false.) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) From 8e833d4d93476d38002bff7836f937a69b482bdb Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 Jun 2022 14:49:26 -0600 Subject: [PATCH 008/629] Add missing units Address comment from reviewer by adding units to covTS and varS. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 0c223ffdeb..864669a217 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -179,7 +179,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer ! densities [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: covTS, varS !SGS TS covariance, S variance in Stanley param; currently 0 + real, dimension(SZI_(G)) :: covTS, & !SGS TS covariance in Stanley param; currently 0 [degC ppt] + varS !SGS S variance in Stanley param; currently 0 [ppt2] real :: aFac, bFac ! Nondimensional ratios [nondim] real :: ddRho ! A density difference [R ~> kg m-3] real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] From 6057714230bed75fd3093a6b73d60c478e42c9ac Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 9 Jun 2022 14:51:44 -0600 Subject: [PATCH 009/629] Follow MOM6 code style guide * Add ``implicit none ; private`` to this module; * Put module variables into the control structure for this module; * Add the description of the units for all real variables; * Add a consistent two-point indent throughout the module . TODO: Without further modifications, adding ``private`` to the control structure of this module will break the model. Currently, MOM.F90 needs access to ``use_stoch_eos``, ``stanley_coeff``, and some of the diagnostic ids. --- src/core/MOM_stoch_eos.F90 | 234 +++++++++++++++++++------------------ 1 file changed, 121 insertions(+), 113 deletions(-) diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index 0ee6d6b1be..bc5e15af4e 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -1,5 +1,6 @@ !> Provides the ocean stochastic equation of state module MOM_stoch_eos + ! This file is part of MOM6. See LICENSE.md for the license. use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type @@ -15,148 +16,156 @@ module MOM_stoch_eos use MOM_isopycnal_slopes,only : vert_fill_TS !use random_numbers_mod, only : getRandomNumbers,initializeRandomNumberStream,randomNumberStream -implicit none +implicit none; private #include public MOM_stoch_eos_init public MOM_stoch_eos_run public MOM_calc_varT -real,private ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: l2_inv - !< One over sum of the T cell side side lengths squared -real,private ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: rgauss !< nondimensional random Gaussian -real, parameter,private :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 -real, parameter,private :: amplitude=0.624499 !< Nondimensional std dev of Gaussian -integer ,private :: seed !< PRNG seed -type(PRNG) :: rn_CS !< PRNG control structure - !> Describes parameters of the stochastic component of the EOS !! correction, described in Stanley et al. JAMES 2020. type, public :: MOM_stoch_eos_CS - real,public ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: pattern - !< Random pattern for stochastic EOS + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: l2_inv + !< One over sum of the T cell side side lengths squared + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: rgauss + !< nondimensional random Gaussian + real :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 + real :: amplitude=0.624499 !< Nondimensional std dev of Gaussian + integer :: seed !< PRNG seed + type(PRNG) :: rn_CS !< PRNG control structure + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: pattern + !< Random pattern for stochastic EOS [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: phi - !< temporal correlation stochastic EOS (deugging) - logical :: use_stoch_eos !< If true, use the stochastic equation of state (Stanley et al. 2020) - real :: stanley_coeff !< Coefficient correlating the temperature gradient - !and SGS T variance; if <0, turn off scheme in all codes - real :: stanley_a ! m2 s-1] + !>@{ Diagnostic IDs integer :: id_stoch_eos = -1, id_stoch_phi = -1, id_tvar_sgs = -1 !>@} end type MOM_stoch_eos_CS - contains - subroutine MOM_stoch_eos_init(G,Time,param_file,stoch_eos_CS,restart_CS,diag) -! initialization subroutine called by MOM.F90, - type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< Time for stochastic process - type(MOM_stoch_eos_CS), intent(inout) :: stoch_eos_CS !< Stochastic control structure - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + +!> Initializes MOM_stoch_eos module. +subroutine MOM_stoch_eos_init(G,Time,param_file,CS,restart_CS,diag) + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< Time for stochastic process + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + + ! local variables integer :: i,j - type(vardesc) :: vd - seed=0 + type(vardesc) :: vd + CS%seed=0 ! contants !pi=2*acos(0.0) - call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", stoch_eos_CS%use_stoch_eos, & + call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", CS%use_stoch_eos, & "If true, stochastic perturbations are applied "//& "to the EOS in the PGF.", default=.false.) - call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", stoch_eos_CS%stanley_coeff, & + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & "Coefficient correlating the temperature gradient "//& "and SGS T variance.", default=-1.0) - call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", stoch_eos_CS%stanley_a, & + call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", CS%stanley_a, & "Coefficient a which scales chi in stochastic perturbation of the "//& "SGS T variance.", default=1.0) - call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", stoch_eos_CS%kappa_smooth, & + call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & units="m2 s-1", default=1.0e-6) !don't run anything if STANLEY_COEFF < 0 - if (stoch_eos_CS%stanley_coeff >= 0.0) then + if (CS%stanley_coeff >= 0.0) then - ALLOC_(stoch_eos_CS%pattern(G%isd:G%ied,G%jsd:G%jed)) ; stoch_eos_CS%pattern(:,:) = 0.0 + ALLOC_(CS%pattern(G%isd:G%ied,G%jsd:G%jed)) ; CS%pattern(:,:) = 0.0 vd = var_desc("stoch_eos_pattern","nondim","Random pattern for stoch EOS",'h','1') - call register_restart_field(stoch_eos_CS%pattern, vd, .false., restart_CS) - ALLOC_(stoch_eos_CS%phi(G%isd:G%ied,G%jsd:G%jed)) ; stoch_eos_CS%phi(:,:) = 0.0 - ALLOC_(l2_inv(G%isd:G%ied,G%jsd:G%jed)) - ALLOC_(rgauss(G%isd:G%ied,G%jsd:G%jed)) - call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", seed, & + call register_restart_field(CS%pattern, vd, .false., restart_CS) + ALLOC_(CS%phi(G%isd:G%ied,G%jsd:G%jed)) ; CS%phi(:,:) = 0.0 + ALLOC_(CS%l2_inv(G%isd:G%ied,G%jsd:G%jed)) + ALLOC_(CS%rgauss(G%isd:G%ied,G%jsd:G%jed)) + call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", CS%seed, & "Specfied seed for random number sequence ", default=0) - call random_2d_constructor(rn_CS, G%HI, Time, seed) - call random_2d_norm(rn_CS, G%HI, rgauss) + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) ! fill array with approximation of grid area needed for decorrelation ! time-scale calculation do j=G%jsc,G%jec - do i=G%isc,G%iec - l2_inv(i,j)=1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) - enddo + do i=G%isc,G%iec + CS%l2_inv(i,j)=1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) + enddo enddo if (is_new_run(restart_CS)) then - do j=G%jsc,G%jec - do i=G%isc,G%iec - stoch_eos_CS%pattern(i,j)=amplitude*rgauss(i,j) - enddo - enddo + do j=G%jsc,G%jec + do i=G%isc,G%iec + CS%pattern(i,j)=CS%amplitude*CS%rgauss(i,j) + enddo + enddo endif !register diagnostics - stoch_eos_CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs', diag%axesTL, Time, & + CS%id_tvar_sgs = register_diag_field('ocean_model', 'tvar_sgs', diag%axesTL, Time, & 'Parameterized SGS Temperature Variance ', 'None') - if (stoch_eos_CS%use_stoch_eos) then - stoch_eos_CS%id_stoch_eos = register_diag_field('ocean_model', 'stoch_eos', diag%axesT1, Time, & + if (CS%use_stoch_eos) then + CS%id_stoch_eos = register_diag_field('ocean_model', 'stoch_eos', diag%axesT1, Time, & 'random pattern for EOS', 'None') - stoch_eos_CS%id_stoch_phi = register_diag_field('ocean_model', 'stoch_phi', diag%axesT1, Time, & + CS%id_stoch_phi = register_diag_field('ocean_model', 'stoch_phi', diag%axesT1, Time, & 'phi for EOS', 'None') endif endif - end subroutine MOM_stoch_eos_init +end subroutine MOM_stoch_eos_init - subroutine MOM_stoch_eos_run(G,u,v,delt,Time,stoch_eos_CS,diag) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. +!> Generates a pattern in space and time for the ocean stochastic equation of state +subroutine MOM_stoch_eos_run(G,u,v,delt,Time,CS,diag) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. + intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. - real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. - type(time_type), intent(in) :: Time !< Time for stochastic process - type(MOM_stoch_eos_CS), intent(inout) :: stoch_eos_CS !< Stochastic control structure - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics -! locals - integer :: i,j + intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1]. + real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. + type(time_type), intent(in) :: Time !< Time for stochastic process + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + + ! local variables + integer :: i,j integer :: yr,mo,dy,hr,mn,sc - real :: phi,ubar,vbar + real :: phi,ubar,vbar + + call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) + call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) - call random_2d_constructor(rn_CS, G%HI, Time, seed) - call random_2d_norm(rn_CS, G%HI, rgauss) ! advance AR(1) do j=G%jsc,G%jec - do i=G%isc,G%iec - ubar=0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) - vbar=0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) - phi=exp(-delt*tfac*sqrt((ubar**2+vbar**2)*l2_inv(i,j))) - stoch_eos_CS%pattern(i,j)=phi*stoch_eos_CS%pattern(i,j) + amplitude*sqrt(1-phi**2)*rgauss(i,j) - stoch_eos_CS%phi(i,j)=phi - enddo + do i=G%isc,G%iec + ubar=0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) + vbar=0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) + phi=exp(-delt*CS%tfac*sqrt((ubar**2+vbar**2)*CS%l2_inv(i,j))) + CS%pattern(i,j)=phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j) + CS%phi(i,j)=phi + enddo enddo - end subroutine MOM_stoch_eos_run +end subroutine MOM_stoch_eos_run +!> Computes a parameterization of the SGS temperature variance +subroutine MOM_calc_varT(G,GV,h,tv,CS,dt) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + intent(in) :: h !< Layer thickness [H ~> m] + type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + real, intent(in) :: dt !< Time increment [T ~> s] - subroutine MOM_calc_varT(G,GV,h,tv,stoch_eos_CS,dt) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), intent(in) :: h !< Layer thickness [H ~> m] - type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - type(MOM_stoch_eos_CS), intent(inout) :: stoch_eos_CS !< Stochastic control structure. - real, intent(in) :: dt !< Time increment [T ~> s] -! locals + ! local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & T, & !> The temperature (or density) [degC], with the values in !! in massless layers filled vertically by diffusion. @@ -171,42 +180,41 @@ subroutine MOM_calc_varT(G,GV,h,tv,stoch_eos_CS,dt) ! still a poor approximation in the interior when coordinates are strongly tilted. if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) - call vert_fill_TS(h, tv%T, tv%S, stoch_eos_CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) do k=1,G%ke - do j=G%jsc,G%jec - do i=G%isc,G%iec - hl(1) = h(i,j,k) * G%mask2dT(i,j) - hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) - hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) - hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) - hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) - - ! SGS variance in i-direction [degC2] - dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & - + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & - ) * G%dxT(i,j) * 0.5 )**2 - ! SGS variance in j-direction [degC2] - dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & - + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & - ) * G%dyT(i,j) * 0.5 )**2 - tv%varT(i,j,k) = stoch_eos_CS%stanley_coeff * ( dTdi2 + dTdj2 ) - ! Turn off scheme near land - tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) - enddo - enddo + do j=G%jsc,G%jec + do i=G%isc,G%iec + hl(1) = h(i,j,k) * G%mask2dT(i,j) + hl(2) = h(i-1,j,k) * G%mask2dCu(I-1,j) + hl(3) = h(i+1,j,k) * G%mask2dCu(I,j) + hl(4) = h(i,j-1,k) * G%mask2dCv(i,J-1) + hl(5) = h(i,j+1,k) * G%mask2dCv(i,J) + + ! SGS variance in i-direction [degC2] + dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 + ! SGS variance in j-direction [degC2] + dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 + tv%varT(i,j,k) = CS%stanley_coeff * ( dTdi2 + dTdj2 ) + ! Turn off scheme near land + tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) + enddo + enddo enddo ! if stochastic, perturb - if (stoch_eos_CS%use_stoch_eos) then - do k=1,G%ke - do j=G%jsc,G%jec - do i=G%isc,G%iec - tv%varT(i,j,k) = exp (stoch_eos_CS%stanley_a * stoch_eos_CS%pattern(i,j)) * tv%varT(i,j,k) - enddo + if (CS%use_stoch_eos) then + do k=1,G%ke + do j=G%jsc,G%jec + do i=G%isc,G%iec + tv%varT(i,j,k) = exp (CS%stanley_a * CS%pattern(i,j)) * tv%varT(i,j,k) enddo - enddo + enddo + enddo endif - end subroutine MOM_calc_varT +end subroutine MOM_calc_varT end module MOM_stoch_eos - From bb02a51becfbfbb9d7d46332fb6f4c77015e0881 Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 11:41:20 -0600 Subject: [PATCH 010/629] A new tracer that keeps track of "mixed layer age" has been added to the ideal age module. This PR also adds the ability to use the actual BL depth that is diagnosed by the active BL scheme inside the ideal age module (for all ideal age tracers). --- src/tracer/MOM_tracer_flow_control.F90 | 5 +- src/tracer/ideal_age_example.F90 | 227 +++++++++++++++++++++---- 2 files changed, 199 insertions(+), 33 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index d1c105fcd5..3dac584571 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -468,7 +468,8 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & - minimum_forcing_depth=minimum_forcing_depth) + minimum_forcing_depth=minimum_forcing_depth, & + Hml=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp, & @@ -544,7 +545,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp) + G, GV, US, CS%ideal_age_tracer_CSp, Hml=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 2fdeaff02f..92aab231a2 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -6,7 +6,7 @@ module ideal_age_example use MOM_coms, only : EFP_type use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type @@ -31,8 +31,9 @@ module ideal_age_example public register_ideal_age_tracer, initialize_ideal_age_tracer public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state public ideal_age_stock, ideal_age_example_end +public count_ML_layers -integer, parameter :: NTR_MAX = 3 !< the maximum number of tracers in this module. +integer, parameter :: NTR_MAX = 4 !< the maximum number of tracers in this module. !> The control structure for the ideal_age_tracer package type, public :: ideal_age_tracer_CS ; private @@ -49,9 +50,12 @@ module ideal_age_example real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. - real, dimension(NTR_MAX) :: sfc_growth_rate !< The exponential growth rate for the surface value [year-1]. + real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1]. real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the !! surface value equals young_val, in years. + logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of + !! layers above the BL depth instead of the fixed nkml value. + integer :: ML_residence_num !! The tracer number assigned to the ML residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. @@ -64,6 +68,7 @@ module ideal_age_example type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< A pointer to the restart controls structure type(vardesc) :: tr_desc(NTR_MAX) !< Descriptions and metadata for the tracers + end type ideal_age_tracer_CS contains @@ -87,7 +92,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: var_name ! The variable's name. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_ideal_age_tracer - logical :: do_ideal_age, do_vintage, do_ideal_age_dated + logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_ML_residence integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -114,8 +119,14 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "the standard ideal age tracer - i.e. is set to 0 age in "//& "the mixed layer and ages at unit rate in the interior.", & default=.false.) - - + call get_param(param_file, mdl, "DO_ML_RESIDENCE", do_ML_residence, & + "If true, use a residence tracer that is set to 0 age "//& + "in the interior and ages at unit rate in the mixed layer.", & + default=.false.) + call get_param(param_file, mdl, "USE_REAL_BL_DEPTH", CS%use_real_BL_depth, & + "If true, the ideal age tracers will use the boundary layer "//& + "depth diagnosed from the BL or bulkmixedlayer scheme.", & + default=.false.) call get_param(param_file, mdl, "AGE_IC_FILE", CS%IC_file, & "The file in which the age-tracer initial values can be "//& "found, or an empty string for internal initialization.", & @@ -139,7 +150,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) if (do_ideal_age) then CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("age", "yr", "Ideal Age Tracer", cmor_field_name="agessc", caller=mdl) - CS%tracer_ages(m) = .true. ; CS%sfc_growth_rate(m) = 0.0 + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 endif @@ -147,7 +158,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("vintage", "yr", "Exponential Vintage Tracer", & caller=mdl) - CS%tracer_ages(m) = .false. ; CS%sfc_growth_rate(m) = 1.0/30.0 + CS%tracer_ages(m) = .false. ; CS%growth_rate(m) = 1.0/30.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 1e-20 ; CS%tracer_start_year(m) = 0.0 call get_param(param_file, mdl, "IDEAL_VINTAGE_START_YEAR", CS%tracer_start_year(m), & "The date at which the ideal vintage tracer starts.", & @@ -158,13 +169,21 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%ntr = CS%ntr + 1 ; m = CS%ntr CS%tr_desc(m) = var_desc("age_dated","yr","Ideal Age Tracer with a Start Date",& caller=mdl) - CS%tracer_ages(m) = .true. ; CS%sfc_growth_rate(m) = 0.0 + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 call get_param(param_file, mdl, "IDEAL_AGE_DATED_START_YEAR", CS%tracer_start_year(m), & "The date at which the dated ideal age tracer starts.", & units="years", default=0.0) endif + CS%ML_residence_num = 0 + if (do_ML_residence) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%ML_residence_num = CS%ntr + CS%tr_desc(m) = var_desc("ML_age", "yr", "ML Residence Time Tracer", caller=mdl) + CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 + CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 + endif + allocate(CS%tr(isd:ied,jsd:jed,nz,CS%ntr), source=0.0) do m=1,CS%ntr @@ -220,6 +239,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS logical :: OK integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB + logical :: use_real_BL_depth if (.not.associated(CS)) return if (CS%ntr < 1) return @@ -277,7 +297,7 @@ end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & - evap_CFL_limit, minimum_forcing_depth) + evap_CFL_limit, minimum_forcing_depth, Hml) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -302,6 +322,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hml !< Mixed layer depth [Z ~> m] + ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. ! This is a simple example of a set of advected passive tracers. @@ -309,13 +331,24 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: ML_layers ! Stores number of layers in mixed layer real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: sfc_val ! The surface value for the tracers. + real :: young_val ! The "young" value for the tracers. real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] real :: year ! The time in years. - integer :: i, j, k, is, ie, js, je, nz, m + real :: layer_frac + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (CS%use_real_BL_depth .and. .not. present(Hml)) then + call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, but no valid boundary layer scheme was found") + endif + + if (CS%use_real_BL_depth .and. present(Hml)) then + call count_ML_layers(G, GV, h_old, Hml, ML_layers) + endif + if (.not.associated(CS)) return if (CS%ntr < 1) return @@ -340,27 +373,123 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, year = US%s_to_T*time_type_to_real(CS%Time) * Isecs_per_year do m=1,CS%ntr - if (CS%sfc_growth_rate(m) == 0.0) then - sfc_val = CS%young_val(m) + + if (CS%growth_rate(m) == 0.0) then + young_val = CS%young_val(m) else - sfc_val = CS%young_val(m) * & - exp((year-CS%tracer_start_year(m)) * CS%sfc_growth_rate(m)) + young_val = CS%young_val(m) * & + exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif - do k=1,CS%nkml ; do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.0) then - CS%tr(i,j,k,m) = sfc_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif - enddo ; enddo ; enddo - enddo - do m=1,CS%ntr ; if (CS%tracer_ages(m) .and. & - (year>=CS%tracer_start_year(m))) then -!$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year - enddo ; enddo ; enddo - endif ; enddo + + if (m == CS%ML_residence_num) then + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(ML_layers(i,j)) + + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + + write(msg,*) TRIM("ML_layers= "),ML_layers(i,j), TRIM(", k= "),(k) + call MOM_error(NOTE,msg) + + if (G%mask2dT(i,j) > 0.0) then + layer_frac = ML_layers(i,j)-nk + layer_frac = 0.9 + CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + (1.-layer_frac) * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do j=js,je ; do i=is,ie + do k=1,CS%nkml + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + do k=CS%nkml+1,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + endif ! use real BL depth + + else ! if ML residence tracer + + if (CS%use_real_BL_depth) then + do j=js,je ; do i=is,ie + nk = floor(ML_layers(i,j)) + do k=1,nk + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + + k = MIN(nk+1,nz) + if (G%mask2dT(i,j) > 0.0) then + layer_frac = ML_layers(i,j)-nk + CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + layer_frac * young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + + do k=nk+2,nz + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo + enddo ; enddo + + else ! use real BL depth + do k=1,CS%nkml ; do j=js,je ; do i=is,ie + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif + enddo ; enddo ; enddo + + if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then + !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) + do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + enddo ; enddo ; enddo + endif + + + endif ! if use real BL depth + endif ! if ML residence tracer + + enddo ! loop over all tracers end subroutine ideal_age_tracer_column_physics @@ -448,6 +577,42 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end +subroutine count_ML_layers(G, GV, h, Hml, ML_layers) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: ML_layers !< Number of model layers in the mixed layer + + real :: current_depth + integer :: i, j, k, is, ie, js, je, nz, m, nk + character(len=255) :: msg + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + ML_layers(:,:) = 0. + do j=js,je ; do i=is,ie + +! write(msg,*) TRIM("Hml= "),Hml(i,j) +! call MOM_error(NOTE,msg) + current_depth = 0. + do k=1,nz + current_depth = current_depth + h(i,j,k)*GV%H_to_Z + if (Hml(i,j) <= current_depth) then + ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) +! write(msg,*) TRIM("ML_layers(i,j) found = "),ML_layers(i,j) +! call MOM_error(NOTE,msg) + exit + else + ML_layers(i,j) = ML_layers(i,j) + 1.0 +! write(msg,*) TRIM("ML_layers(i,j) adding = "),ML_layers(i,j) +! call MOM_error(NOTE,msg) + endif + enddo + enddo ; enddo + +end subroutine count_ML_layers + !> \namespace ideal_age_example !! !! Originally by Robert Hallberg, 2002 From f415a7f5cc844730fd483bd5f4ad36ab04ec2fce Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 12:22:54 -0600 Subject: [PATCH 011/629] Shortens a line and removes whitespace --- src/tracer/ideal_age_example.F90 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 92aab231a2..460b5cba41 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -342,7 +342,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (CS%use_real_BL_depth .and. .not. present(Hml)) then - call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, but no valid boundary layer scheme was found") + call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & + but no valid boundary layer scheme was found") endif if (CS%use_real_BL_depth .and. present(Hml)) then @@ -599,7 +600,7 @@ subroutine count_ML_layers(G, GV, h, Hml, ML_layers) do k=1,nz current_depth = current_depth + h(i,j,k)*GV%H_to_Z if (Hml(i,j) <= current_depth) then - ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) + ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) ! write(msg,*) TRIM("ML_layers(i,j) found = "),ML_layers(i,j) ! call MOM_error(NOTE,msg) exit From 2428684ac7537412794297e5329c98de2b648c6f Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 12:37:09 -0600 Subject: [PATCH 012/629] !! ----> !< --- src/tracer/ideal_age_example.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 460b5cba41..c1d12b1594 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -55,7 +55,7 @@ module ideal_age_example !! surface value equals young_val, in years. logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of !! layers above the BL depth instead of the fixed nkml value. - integer :: ML_residence_num !! The tracer number assigned to the ML residence tracer in this module + integer :: ML_residence_num !< The tracer number assigned to the ML residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. From 0d86acd523280a7f762ac9aaa48b0b1d761499ec Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 12:46:01 -0600 Subject: [PATCH 013/629] Shortened line length to make dOxygen happy --- src/tracer/ideal_age_example.F90 | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index c1d12b1594..cc0f8c4cdf 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -404,7 +404,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, if (G%mask2dT(i,j) > 0.0) then layer_frac = ML_layers(i,j)-nk layer_frac = 0.9 - CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + (1.-layer_frac) * young_val + CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + (1.-layer_frac) * young_val else CS%tr(i,j,k,m) = CS%land_val(m) endif @@ -456,7 +457,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, k = MIN(nk+1,nz) if (G%mask2dT(i,j) > 0.0) then layer_frac = ML_layers(i,j)-nk - CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year) + layer_frac * young_val + CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & + *Isecs_per_year) + layer_frac * young_val else CS%tr(i,j,k,m) = CS%land_val(m) endif From 5ac624241c40e4381efe724ade3e0dab5e442368 Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Fri, 29 Jul 2022 15:41:49 -0600 Subject: [PATCH 014/629] All references to "mixed layer" in the ideal age module now refer to "boundary layer" instead. --- src/tracer/ideal_age_example.F90 | 91 ++++++++++++++------------------ 1 file changed, 41 insertions(+), 50 deletions(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index cc0f8c4cdf..7351a7e459 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -31,7 +31,7 @@ module ideal_age_example public register_ideal_age_tracer, initialize_ideal_age_tracer public ideal_age_tracer_column_physics, ideal_age_tracer_surface_state public ideal_age_stock, ideal_age_example_end -public count_ML_layers +public count_BL_layers integer, parameter :: NTR_MAX = 4 !< the maximum number of tracers in this module. @@ -39,8 +39,8 @@ module ideal_age_example type, public :: ideal_age_tracer_CS ; private integer :: ntr !< The number of tracers that are actually used. logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. - integer :: nkml !< The number of layers in the mixed layer. The ideal - !1 age tracers are reset in the top nkml layers. + integer :: nkbl !< The number of layers in the boundary layer. The ideal + !1 age tracers are reset in the top nkbl layers. character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. @@ -54,8 +54,8 @@ module ideal_age_example real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the !! surface value equals young_val, in years. logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of - !! layers above the BL depth instead of the fixed nkml value. - integer :: ML_residence_num !< The tracer number assigned to the ML residence tracer in this module + !! layers above the BL depth instead of the fixed nkbl value. + integer :: BL_residence_num !< The tracer number assigned to the BL residence tracer in this module logical :: tracers_may_reinit !< If true, these tracers be set up via the initialization code if !! they are not found in the restart files. logical :: tracer_ages(NTR_MAX) !< Indicates whether each tracer ages. @@ -92,7 +92,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: var_name ! The variable's name. real, pointer :: tr_ptr(:,:,:) => NULL() logical :: register_ideal_age_tracer - logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_ML_residence + logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_BL_residence integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -107,21 +107,21 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DO_IDEAL_AGE", do_ideal_age, & "If true, use an ideal age tracer that is set to 0 age "//& - "in the mixed layer and ages at unit rate in the interior.", & + "in the boundary layer and ages at unit rate in the interior.", & default=.true.) call get_param(param_file, mdl, "DO_IDEAL_VINTAGE", do_vintage, & "If true, use an ideal vintage tracer that is set to an "//& - "exponentially increasing value in the mixed layer and "//& + "exponentially increasing value in the boundary layer and "//& "is conserved thereafter.", default=.false.) call get_param(param_file, mdl, "DO_IDEAL_AGE_DATED", do_ideal_age_dated, & "If true, use an ideal age tracer that is everywhere 0 "//& "before IDEAL_AGE_DATED_START_YEAR, but the behaves like "//& "the standard ideal age tracer - i.e. is set to 0 age in "//& - "the mixed layer and ages at unit rate in the interior.", & + "the boundary layer and ages at unit rate in the interior.", & default=.false.) - call get_param(param_file, mdl, "DO_ML_RESIDENCE", do_ML_residence, & + call get_param(param_file, mdl, "DO_BL_RESIDENCE", do_BL_residence, & "If true, use a residence tracer that is set to 0 age "//& - "in the interior and ages at unit rate in the mixed layer.", & + "in the interior and ages at unit rate in the boundary layer.", & default=.false.) call get_param(param_file, mdl, "USE_REAL_BL_DEPTH", CS%use_real_BL_depth, & "If true, the ideal age tracers will use the boundary layer "//& @@ -176,10 +176,10 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) units="years", default=0.0) endif - CS%ML_residence_num = 0 - if (do_ML_residence) then - CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%ML_residence_num = CS%ntr - CS%tr_desc(m) = var_desc("ML_age", "yr", "ML Residence Time Tracer", caller=mdl) + CS%BL_residence_num = 0 + if (do_BL_residence) then + CS%ntr = CS%ntr + 1 ; m = CS%ntr; CS%BL_residence_num = CS%ntr + CS%tr_desc(m) = var_desc("BL_age", "yr", "BL Residence Time Tracer", caller=mdl) CS%tracer_ages(m) = .true. ; CS%growth_rate(m) = 0.0 CS%IC_val(m) = 0.0 ; CS%young_val(m) = 0.0 ; CS%tracer_start_year(m) = 0.0 endif @@ -249,7 +249,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS CS%Time => day CS%diag => diag - CS%nkml = max(GV%nkml,1) + CS%nkbl = max(GV%nkbl,1) do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=name, & @@ -297,7 +297,7 @@ end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & - evap_CFL_limit, minimum_forcing_depth, Hml) + evap_CFL_limit, minimum_forcing_depth, Hbl) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -322,7 +322,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hbl !< Boundary layer depth [Z ~> m] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -331,7 +331,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: ML_layers ! Stores number of layers in mixed layer + real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified real :: young_val ! The "young" value for the tracers. real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] @@ -341,13 +341,13 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - if (CS%use_real_BL_depth .and. .not. present(Hml)) then + if (CS%use_real_BL_depth .and. .not. present(Hbl)) then call MOM_error(FATAL,"Attempting to use real boundary layer depth for ideal age tracers, & but no valid boundary layer scheme was found") endif - if (CS%use_real_BL_depth .and. present(Hml)) then - call count_ML_layers(G, GV, h_old, Hml, ML_layers) + if (CS%use_real_BL_depth .and. present(Hbl)) then + call count_BL_layers(G, GV, h_old, Hbl, BL_layers) endif if (.not.associated(CS)) return @@ -382,11 +382,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif - if (m == CS%ML_residence_num) then + if (m == CS%BL_residence_num) then if (CS%use_real_BL_depth) then do j=js,je ; do i=is,ie - nk = floor(ML_layers(i,j)) + nk = floor(BL_layers(i,j)) do k=1,nk if (G%mask2dT(i,j) > 0.0) then @@ -398,11 +398,8 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, k = MIN(nk+1,nz) - write(msg,*) TRIM("ML_layers= "),ML_layers(i,j), TRIM(", k= "),(k) - call MOM_error(NOTE,msg) - if (G%mask2dT(i,j) > 0.0) then - layer_frac = ML_layers(i,j)-nk + layer_frac = BL_layers(i,j)-nk layer_frac = 0.9 CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & *Isecs_per_year) + (1.-layer_frac) * young_val @@ -422,7 +419,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, else ! use real BL depth do j=js,je ; do i=is,ie - do k=1,CS%nkml + do k=1,CS%nkbl if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year else @@ -430,7 +427,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif enddo - do k=CS%nkml+1,nz + do k=CS%nkbl+1,nz if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = young_val else @@ -441,11 +438,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif ! use real BL depth - else ! if ML residence tracer + else ! if BL residence tracer if (CS%use_real_BL_depth) then do j=js,je ; do i=is,ie - nk = floor(ML_layers(i,j)) + nk = floor(BL_layers(i,j)) do k=1,nk if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = young_val @@ -456,7 +453,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, k = MIN(nk+1,nz) if (G%mask2dT(i,j) > 0.0) then - layer_frac = ML_layers(i,j)-nk + layer_frac = BL_layers(i,j)-nk CS%tr(i,j,k,m) = (1.-layer_frac) * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & *Isecs_per_year) + layer_frac * young_val else @@ -473,7 +470,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo ; enddo else ! use real BL depth - do k=1,CS%nkml ; do j=js,je ; do i=is,ie + do k=1,CS%nkbl ; do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then CS%tr(i,j,k,m) = young_val else @@ -483,14 +480,14 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkml+1,nz ; do j=js,je ; do i=is,ie + do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year enddo ; enddo ; enddo endif endif ! if use real BL depth - endif ! if ML residence tracer + endif ! if BL residence tracer enddo ! loop over all tracers @@ -580,41 +577,35 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end -subroutine count_ML_layers(G, GV, h, Hml, ML_layers) +subroutine count_BL_layers(G, GV, h, Hbl, BL_layers) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: ML_layers !< Number of model layers in the mixed layer + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer real :: current_depth integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ML_layers(:,:) = 0. + BL_layers(:,:) = 0. do j=js,je ; do i=is,ie -! write(msg,*) TRIM("Hml= "),Hml(i,j) -! call MOM_error(NOTE,msg) current_depth = 0. do k=1,nz current_depth = current_depth + h(i,j,k)*GV%H_to_Z - if (Hml(i,j) <= current_depth) then - ML_layers(i,j) = ML_layers(i,j) + (1.0 - (current_depth - Hml(i,j)) / (h(i,j,k)*GV%H_to_Z)) -! write(msg,*) TRIM("ML_layers(i,j) found = "),ML_layers(i,j) -! call MOM_error(NOTE,msg) + if (Hbl(i,j) <= current_depth) then + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / (h(i,j,k)*GV%H_to_Z)) exit else - ML_layers(i,j) = ML_layers(i,j) + 1.0 -! write(msg,*) TRIM("ML_layers(i,j) adding = "),ML_layers(i,j) -! call MOM_error(NOTE,msg) + BL_layers(i,j) = BL_layers(i,j) + 1.0 endif enddo enddo ; enddo -end subroutine count_ML_layers +end subroutine count_BL_layers !> \namespace ideal_age_example !! From e300296ac5c9fd9c3e6cf1aec791c70679dd75ba Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Mon, 1 Aug 2022 11:09:12 -0600 Subject: [PATCH 015/629] Changed GV%nkbl back to GV%nkml --- src/tracer/ideal_age_example.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 7351a7e459..ea9cbb3063 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -249,7 +249,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS CS%Time => day CS%diag => diag - CS%nkbl = max(GV%nkbl,1) + CS%nkbl = max(GV%nkml,1) do m=1,CS%ntr call query_vardesc(CS%tr_desc(m), name=name, & From dfb37154abff846b5edf5116ef0940d77df6f61d Mon Sep 17 00:00:00 2001 From: Scott Bachman Date: Mon, 1 Aug 2022 11:16:47 -0600 Subject: [PATCH 016/629] Changed parameter reference for ideal_age_physics to Hbl=Hml --- src/tracer/MOM_tracer_flow_control.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 3dac584571..7520db820d 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -469,7 +469,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth, & - Hml=Hml) + Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp, & @@ -545,7 +545,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp, Hml=Hml) + G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%dye_tracer_CSp) From cfd7c0bdec86c07231447c3ed1a4ac9f93b6b47a Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 22 Sep 2022 08:17:18 -0600 Subject: [PATCH 017/629] Rename parameter SMOOTH_RI to N_SMOOTH_RI In preparation for implementing the option to apply a vertical smooth filter in the Richardson number multiple times, the parameter SMOOTH_RI (logical) was renamed to N_SMOOTH_RI (interger). If N_SMOOTH_RI = 0 (default), smoothing is not performed. If N_SMOOTH_RI > 0, smoothing will be applied N_SMOOTH_RI times. --- src/parameterizations/vertical/MOM_CVMix_shear.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 7ec45dbe11..a84ec9ddd1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -31,7 +31,7 @@ module MOM_CVMix_shear type, public :: CVMix_shear_cs ! TODO: private logical :: use_LMD94 !< Flags to use the LMD94 scheme logical :: use_PP81 !< Flags to use Pacanowski and Philander (JPO 1981) - logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter + integer :: n_smooth_ri !< Number of times to smooth Ri using a 1-2-1 filter real :: Ri_zero !< LMD94 critical Richardson number real :: Nu_zero !< LMD94 maximum interior diffusivity real :: KPP_exp !< Exponent of unitless factor of diff. @@ -147,7 +147,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) - if (CS%smooth_ri) then + if (CS%n_smooth_ri) then ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -274,10 +274,10 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) "Exponent of unitless factor of diffusivities, "// & "for KPP internal shear mixing scheme." & ,units="nondim", default=3.0) - call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & - "If true, vertically smooth the Richardson "// & - "number by applying a 1-2-1 filter once.", & - default = .false.) + call get_param(param_file, mdl, "N_SMOOTH_RI", CS%n_smooth_ri, & + "If > 0, vertically smooth the Richardson "// & + "number by applying a 1-2-1 filter N_SMOOTH_RI times.", & + default = 0) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & KPP_nu_zero=CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & From 09278521c10ba261b52e68e834b9899628455be3 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 22 Sep 2022 08:39:27 -0600 Subject: [PATCH 018/629] Modify gradient Richarson number diagnostics Currently, there are two diagnostics related to the gradient Richarson number and these are described as follows: * ri_grad_shear : Gradient Richarson number used by MOM_CVMix_shear module; * ri_grad_shear_smooth : Smoothed gradient Richarson number used by MOM_CVMix_shear module. The description for ri_grad_shear is misleading. If smoothing is applied, ri_grad_shear *is not* the RI number used by MOM_CVMix_shear module. In this commit. I propose to avoid this potential confusion by renaming ri_grad_shear_smooth to ri_grad_shear_orig and, if N_SMOOTH_RI > 0, use ri_grad_shear to store the smoothed profiles. * ri_grad_shear_orig : Original gradient Richarson number, before smoothing was applied. This is part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0. No change in answers for GMOM. --- .../vertical/MOM_CVMix_shear.F90 | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index a84ec9ddd1..fca11423cb 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -39,14 +39,14 @@ module MOM_CVMix_shear real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number - real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number - !! after smoothing + real, allocatable, dimension(:,:,:) :: ri_grad_orig !< Gradient Richardson number + !! before smoothing character(10) :: Mix_Scheme !< Mixing scheme name (string) type(diag_ctrl), pointer :: diag => NULL() !< Pointer to the diagnostics control structure !>@{ Diagnostic handles integer :: id_N2 = -1, id_S2 = -1, id_ri_grad = -1, id_kv = -1, id_kd = -1 - integer :: id_ri_grad_smooth = -1 + integer :: id_ri_grad_orig = -1 !>@} end type CVMix_shear_cs @@ -145,9 +145,9 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) - if (CS%n_smooth_ri) then + if (CS%n_smooth_ri > 0) then ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -163,7 +163,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) dummy = 0.25 * Ri_grad(k) enddo - if (CS%id_ri_grad_smooth > 0) CS%ri_grad_smooth(i,j,:) = Ri_Grad(:) + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) endif do K=1,GV%ke+1 @@ -190,7 +190,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_N2 > 0) call post_data(CS%id_N2, CS%N2, CS%diag) if (CS%id_S2 > 0) call post_data(CS%id_S2, CS%S2, CS%diag) if (CS%id_ri_grad > 0) call post_data(CS%id_ri_grad, CS%ri_grad, CS%diag) - if (CS%id_ri_grad_smooth > 0) call post_data(CS%id_ri_grad_smooth ,CS%ri_grad_smooth, CS%diag) + if (CS%id_ri_grad_orig > 0) call post_data(CS%id_ri_grad_orig ,CS%ri_grad_orig, CS%diag) end subroutine calculate_CVMix_shear @@ -304,11 +304,12 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif - CS%id_ri_grad_smooth = register_diag_field('ocean_model', 'ri_grad_shear_smooth', & + CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & diag%axesTi, Time, & - 'Smoothed gradient Richarson number used by MOM_CVMix_shear module','nondim') - if (CS%id_ri_grad_smooth > 0) then !Initialize w/ large Richardson value - allocate( CS%ri_grad_smooth( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) + 'Original gradient Richarson number, before smoothing was applied. This is '//& + 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + if (CS%id_ri_grad_orig > 0 .or. CS%n_smooth_ri > 0) then !Initialize w/ large Richardson value + allocate( CS%ri_grad_orig( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & From b4440417c78eb585503cac8dc9f821bcef315e1e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 22 Sep 2022 14:16:21 -0600 Subject: [PATCH 019/629] Adds option to smooth gradient Ri multiple times This commit adds the option to smooth the gradient Richardson number multiple times using a 1-2-1 filter. The number of times that the filter is applied is controlled by parameter N_SMOOTH_RI. --- .../vertical/MOM_CVMix_shear.F90 | 41 ++++++++++++------- 1 file changed, 26 insertions(+), 15 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index fca11423cb..e3906e9df2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -72,7 +72,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous !! call to CVMix_shear_init. ! Local variables - integer :: i, j, k, kk, km1 + integer :: i, j, k, kk, km1, s real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] @@ -85,7 +85,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [C ~> degC] real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [S ~> ppt] real, dimension(2*(GV%ke)) :: rho_1d ! A column of densities at interface pressures [R ~> kg m-3] - real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad !< Gradient Richardson number [nondim] + real, dimension(GV%ke+1) :: Ri_Grad_prev !< Gradient Richardson number before s.th smoothing iteration [nondim] real, dimension(GV%ke+1) :: Kvisc !< Vertical viscosity at interfaces [m2 s-1] real, dimension(GV%ke+1) :: Kdiff !< Diapycnal diffusivity at interfaces [m2 s-1] real :: epsln !< Threshold to identify vanished layers [H ~> m or kg m-2] @@ -145,9 +146,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) - if (CS%n_smooth_ri > 0) then + + if (CS%id_ri_grad_orig > 0) CS%ri_grad_orig(i,j,:) = Ri_Grad(:) + ! 1) fill Ri_grad in vanished layers with adjacent value do k = 2, GV%ke if (h(i,j,k) <= epsln) Ri_grad(k) = Ri_grad(k-1) @@ -155,17 +157,24 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - ! 2) vertically smooth Ri with 1-2-1 filter - dummy = 0.25 * Ri_grad(2) - Ri_grad(GV%ke+1) = Ri_grad(GV%ke) - do k = 3, GV%ke - Ri_Grad(k) = dummy + 0.5 * Ri_Grad(k) + 0.25 * Ri_grad(k+1) - dummy = 0.25 * Ri_grad(k) + do s=1,CS%n_smooth_ri + + Ri_Grad_prev(:) = Ri_Grad(:) + + ! 2) vertically smooth Ri with 1-2-1 filter + dummy = 0.25 * Ri_grad_prev(2) + do k = 3, GV%ke + Ri_Grad(k) = dummy + 0.5 * Ri_Grad_prev(k) + 0.25 * Ri_grad_prev(k+1) + dummy = 0.25 * Ri_grad(k) + enddo enddo - if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + Ri_grad(GV%ke+1) = Ri_grad(GV%ke) + endif + if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) + do K=1,GV%ke+1 Kvisc(K) = US%Z2_T_to_m2_s * kv(i,j,K) Kdiff(K) = US%Z2_T_to_m2_s * kd(i,j,K) @@ -304,10 +313,12 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) allocate( CS%ri_grad( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif - CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & - diag%axesTi, Time, & - 'Original gradient Richarson number, before smoothing was applied. This is '//& - 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + if (CS%n_smooth_ri > 0) then + CS%id_ri_grad_orig = register_diag_field('ocean_model', 'ri_grad_shear_orig', & + diag%axesTi, Time, & + 'Original gradient Richarson number, before smoothing was applied. This is '//& + 'part of the MOM_CVMix_shear module and only available when N_SMOOTH_RI > 0','nondim') + endif if (CS%id_ri_grad_orig > 0 .or. CS%n_smooth_ri > 0) then !Initialize w/ large Richardson value allocate( CS%ri_grad_orig( SZI_(G), SZJ_(G), SZK_(GV)+1 ), source=1.e8 ) endif From 0cf34d352e59f8a202e93de6d9b2290bb06ef74e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 7 Oct 2022 11:35:25 -0600 Subject: [PATCH 020/629] Fix string order in regional_section The correct order is lon_min lon_max lat_min lat_max ... and not lat_min lat_max lon_min lon_max. --- src/framework/_Diagnostics.dox | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/_Diagnostics.dox b/src/framework/_Diagnostics.dox index 3db345ca1a..0be318f580 100644 --- a/src/framework/_Diagnostics.dox +++ b/src/framework/_Diagnostics.dox @@ -90,7 +90,7 @@ An arbitrary number of lines, one per diagnostic field: "average" or "mean" performs a time-average. "min" or "max" diagnose the minium or maxium over each time period. -- `regional_section` : "none" means global output. A string of six space separated numbers, "lat_min, lat_max, lon_min, lon_max, vert_min, vert_max", limits the diagnostic to a region. +- `regional_section` : "none" means global output. A string of six space separated numbers, "lon_min lon_max lat_min lat_max vert_min vert_max", limits the diagnostic to a region. - `packing` : Data representation in the file. 1 means "real*8", 2 means "real*4", 4 mean 16-bit integers, 8 means 1-byte. From 2ba1af11ef927a520e044c29f003f33f06ad11e1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 23 Oct 2022 09:38:51 -0400 Subject: [PATCH 021/629] +Created remapping_attic.F90 Created the new module remapping_attic to hold older versions of remapping code that are no longer used by MOM6. The subroutines is PosSumErrSignificant, remapByProjection, remapByDeltaZ and integrateReconOnInterval were moved to remapping_attic, where they can be tested by calling remapping_attic_unit_tests. The hard-coded old_algorithm logical module variable and the code it wraps were also eliminated. Also added a schematic description of the units of the real variables in the various routines in MOM_remapping and corrected some spelling errors. All answers are bitwise identical. --- src/ALE/MOM_remapping.F90 | 792 +++++++----------------------------- src/ALE/remapping_attic.F90 | 648 +++++++++++++++++++++++++++++ 2 files changed, 785 insertions(+), 655 deletions(-) create mode 100644 src/ALE/remapping_attic.F90 diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index faed4ac6be..061894711c 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -5,23 +5,22 @@ module MOM_remapping ! Original module written by Laurent White, 2008.06.09 use MOM_error_handler, only : MOM_error, FATAL +use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 +use remapping_attic, only : remapping_attic_unit_tests use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs -use MOM_io, only : stdout, stderr - implicit none ; private !> Container for remapping parameters -type, public :: remapping_CS - private +type, public :: remapping_CS ; private !> Determines which reconstruction to use integer :: remapping_scheme = -911 !> Degree of polynomial reconstruction @@ -76,20 +75,6 @@ module MOM_remapping "PQM_IH6IH5 (5th-order accurate)\n" character(len=3), public :: remappingDefaultScheme = "PLM" !< Default remapping method -! This CPP macro turns on/off bounding of integrations limits so that they are -! always within the cell. Roundoff can lead to the non-dimensional bounds being -! outside of the range 0 to 1. -#define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - -real, parameter :: hNeglect_dflt = 1.E-30 !< A thickness [H ~> m or kg m-2] that can be - !! added to thicknesses in a denominator without - !! changing the numerical result, except where - !! a division by zero would otherwise occur. - -logical, parameter :: old_algorithm = .false. !< Use the old "broken" algorithm. - !! This is a temporary measure to assist - !! debugging until we delete the old algorithm. - contains !> Set parameters within remapping object @@ -101,7 +86,7 @@ subroutine remapping_set_param(CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use if (present(remapping_scheme)) then @@ -152,11 +137,12 @@ subroutine extract_member_remapping_CS(CS, remapping_scheme, degree, boundary_ex if (present(force_bounds_in_subcell)) force_bounds_in_subcell = CS%force_bounds_in_subcell end subroutine extract_member_remapping_CS + !> Calculate edge coordinate x from cell width h subroutine buildGridFromH(nz, h, x) integer, intent(in) :: nz !< Number of cells - real, dimension(nz), intent(in) :: h !< Cell widths - real, dimension(nz+1), intent(inout) :: x !< Edge coordiantes starting at x(1)=0 + real, dimension(nz), intent(in) :: h !< Cell widths [H] + real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] ! Local variables integer :: k @@ -167,39 +153,6 @@ subroutine buildGridFromH(nz, h, x) end subroutine buildGridFromH -!> Compare two summation estimates of positive data and judge if due to more -!! than round-off. -!! When two sums are calculated from different vectors that should add up to -!! the same value, the results can differ by round off. The round off error -!! can be bounded to be proportional to the number of operations. -!! This function returns true if the difference between sum1 and sum2 is -!! larger than than the estimated round off bound. -!! \note This estimate/function is only valid for summation of positive data. -function isPosSumErrSignificant(n1, sum1, n2, sum2) - integer, intent(in) :: n1 !< Number of values in sum1 - integer, intent(in) :: n2 !< Number of values in sum2 - real, intent(in) :: sum1 !< Sum of n1 values - real, intent(in) :: sum2 !< Sum of n2 values - logical :: isPosSumErrSignificant !< True if difference in sums is large - ! Local variables - real :: sumErr, allowedErr, eps - - if (sum1<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum1<0 is not allowed!') - if (sum2<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum2<0 is not allowed!') - sumErr = abs(sum1-sum2) - eps = epsilon(sum1) - allowedErr = eps*0.5*(real(n1-1)*sum1+real(n2-1)*sum2) - if (sumErr>allowedErr) then - write(0,*) 'isPosSumErrSignificant: sum1,sum2=',sum1,sum2 - write(0,*) 'isPosSumErrSignificant: eps=',eps - write(0,*) 'isPosSumErrSignificant: err,n*eps=',sumErr,allowedErr - write(0,*) 'isPosSumErrSignificant: err/eps,n1,n2,n1+n2=',sumErr/eps,n1,n2,n1+n2 - isPosSumErrSignificant = .true. - else - isPosSumErrSignificant = .false. - endif -end function isPosSumErrSignificant - !> Remaps column of values u0 on grid h0 to grid h1 assuming the top edge is aligned. subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edge, PCM_cell) type(remapping_CS), intent(in) :: CS !< Remapping control structure @@ -220,9 +173,9 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg ! Local variables integer :: iMethod - real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial - real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial [A] real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] @@ -287,29 +240,33 @@ end subroutine remapping_core_h !> Remaps column of values u0 on grid h0 to implied grid h1 !! where the interfaces of h1 differ from those of h0 by dx. subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_edge ) - type(remapping_CS), intent(in) :: CS !< Remapping control structure - integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - integer, intent(in) :: n1 !< Number of cells on target grid - real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid - real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h0. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width - !! for the purpose of edge value - !! calculations in the same units as h0. + type(remapping_CS), intent(in) :: CS !< Remapping control structure + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + integer, intent(in) :: n1 !< Number of cells on target grid + real, dimension(n1+1), intent(in) :: dx !< Cell widths on target grid [H] + real, dimension(n1), intent(out) :: u1 !< Cell averages on target grid [A] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h0 [H]. + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width + !! for the purpose of edge value + !! calculations in the same units as h0 [H]. ! Local variables + real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] + real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial [A] + real :: h0tot, h1tot ! The total thicknesses of the source and target grids [H] + real :: h0err, h1err ! Magnitude of round-off errors in h0tot and h1tot [H] + real :: u0tot, u1tot ! Column integrated values on the source and target grids [H A] + real :: u0err, u1err ! Magnitude of round-off errors in u0tot and u1tot [H A] + real :: u0min, u0max, u1min, u1max ! Extrema of values on the source and target grids [A] + real :: uh_err ! Estimate of bound on error in sum of u*h [A H] + real, dimension(n1) :: h1 !< Cell widths on target grid [H] + real :: hNeglect, hNeglect_edge ! Negligibly small thicknesses [H] integer :: iMethod - real, dimension(n0,2) :: ppoly_r_E !Edge value of polynomial - real, dimension(n0,2) :: ppoly_r_S !Edge slope of polynomial - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs !Coefficients of polynomial integer :: k - real :: h0tot, h0err, h1tot, h1err - real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, uh_err - real, dimension(n1) :: h1 !< Cell widths on target grid - real :: hNeglect, hNeglect_edge hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect hNeglect_edge = 1.0e-10 ; if (present(h_neglect_edge)) hNeglect_edge = h_neglect_edge @@ -379,19 +336,19 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & h_neglect_edge, PCM_cell ) type(remapping_CS), intent(in) :: CS !< Remapping control structure integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] real, dimension(n0,CS%degree+1), & - intent(out) :: ppoly_r_coefs !< Coefficients of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial + intent(out) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] integer, intent(out) :: iMethod !< Integration method real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h0. + !! in the same units as h0 [H] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width !! for the purpose of edge value - !! calculations in the same units as h0. + !! calculations in the same units as h0 [H] logical, optional, intent(in) :: PCM_cell(n0) !< If present, use PCM remapping for !! cells from the source grid where this is true. @@ -500,17 +457,17 @@ end subroutine build_reconstructions_1d subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & ppoly_r_coefs, ppoly_r_E, ppoly_r_S) integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial + real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] ! Local variables integer :: i0, n - real :: u_l, u_c, u_r ! Cell averages - real :: u_min, u_max + real :: u_l, u_c, u_r ! Cell averages [A] + real :: u_min, u_max ! Cell extrema [A] logical :: problem_detected problem_detected = .false. @@ -573,18 +530,18 @@ end subroutine check_reconstructions_1d !! appropriate integrals into the h1*u1 values. h0 and h1 must have the same units. subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, method, & force_bounds_in_subcell, u1, uh_err, ah_sub, aisub_src, aiss, aise ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(n0) !< Source grid widths (size n0) - real, intent(in) :: u0(n0) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(n1) !< Target grid widths (size n1) - integer, intent(in) :: method !< Remapping scheme to use + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(n0) !< Source grid widths (size n0) [H] + real, intent(in) :: u0(n0) !< Source cell averages (size n0) [A] + real, intent(in) :: ppoly0_E(n0,2) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(n1) !< Target grid widths (size n1) [H] + integer, intent(in) :: method !< Remapping scheme to use logical, intent(in) :: force_bounds_in_subcell !< Force sub-cell values to be bounded - real, intent(out) :: u1(n1) !< Target cell averages (size n1) - real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h - real, optional, intent(out) :: ah_sub(n0+n1+1) !< h_sub + real, intent(out) :: u1(n1) !< Target cell averages (size n1) [A] + real, intent(out) :: uh_err !< Estimate of bound on error in sum of u*h [A H] + real, optional, intent(out) :: ah_sub(n0+n1+1) !< Overlapping sub-cell thicknesses, h_sub [H] integer, optional, intent(out) :: aisub_src(n0+n1+1) !< i_sub_src integer, optional, intent(out) :: aiss(n0) !< isrc_start integer, optional, intent(out) :: aise(n0) !< isrc_ens @@ -595,36 +552,38 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth integer :: i_start0 ! Used to record which sub-cells map to source cells integer :: i_start1 ! Used to record which sub-cells map to target cells integer :: i_max ! Used to record which sub-cell is the largest contribution of a source cell - real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell - real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell - real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell - real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell + real :: dh_max ! Used to record which sub-cell is the largest contribution of a source cell [H] + real, dimension(n0+n1+1) :: h_sub ! Width of each each sub-cell [H] + real, dimension(n0+n1+1) :: uh_sub ! Integral of u*h over each sub-cell [A H] + real, dimension(n0+n1+1) :: u_sub ! Average of u over each sub-cell [A] integer, dimension(n0+n1+1) :: isub_src ! Index of source cell for each sub-cell integer, dimension(n0) :: isrc_start ! Index of first sub-cell within each source cell integer, dimension(n0) :: isrc_end ! Index of last sub-cell within each source cell integer, dimension(n0) :: isrc_max ! Index of thickest sub-cell within each source cell - real, dimension(n0) :: h0_eff ! Effective thickness of source cells - real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell - real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell + real, dimension(n0) :: h0_eff ! Effective thickness of source cells [H] + real, dimension(n0) :: u0_min ! Minimum value of reconstructions in source cell [A] + real, dimension(n0) :: u0_max ! Minimum value of reconstructions in source cell [A] integer, dimension(n1) :: itgt_start ! Index of first sub-cell within each target cell integer, dimension(n1) :: itgt_end ! Index of last sub-cell within each target cell - real :: xa, xb ! Non-dimensional position within a source cell (0..1) - real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells - real :: dh ! The width of the sub-cell - real :: duh ! The total amount of accumulated stuff (u*h) - real :: dh0_eff ! Running sum of source cell thickness + real :: xa, xb ! Non-dimensional position within a source cell (0..1) [nondim] + real :: h0_supply, h1_supply ! The amount of width available for constructing sub-cells [H] + real :: dh ! The width of the sub-cell [H] + real :: duh ! The total amount of accumulated stuff (u*h) [A H] + real :: dh0_eff ! Running sum of source cell thickness [H] ! For error checking/debugging logical, parameter :: force_bounds_in_target = .true. ! To fix round-off issues logical, parameter :: adjust_thickest_subcell = .true. ! To fix round-off conservation issues logical, parameter :: debug_bounds = .false. ! For debugging overshoots etc. integer :: k, i0_last_thick_cell - real :: h0tot, h0err, h1tot, h1err, h2tot, h2err, u02_err - real :: u0tot, u0err, u0min, u0max, u1tot, u1err, u1min, u1max, u2tot, u2err, u2min, u2max, u_orig + real :: h0tot, h1tot, h2tot ! Summed thicknesses used for debugging [H] + real :: h0err, h1err, h2err ! Estimates of round-off errors used for debugging [H] + real :: u02_err, u0err, u1err, u2err ! Integrated reconstruction error estimates [H A] + real :: u0tot, u1tot, u2tot ! Integrated reconstruction values [H A] + real :: u_orig ! The original value of the reconstruction in a cell [A] + real :: u0min, u0max, u1min, u1max, u2min, u2max ! Minimum and maximum values of reconstructions [A] logical :: src_has_volume !< True if h0 has not been consumed logical :: tgt_has_volume !< True if h1 has not been consumed - if (old_algorithm) isrc_max(:)=1 - i0_last_thick_cell = 0 do i0 = 1, n0 u0_min(i0) = min(ppoly0_E(i0,1), ppoly0_E(i0,2)) @@ -692,28 +651,13 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth ! Record the source cell thickness found by summing the sub-cell thicknesses. h0_eff(i0) = dh0_eff ! Move the source index. - if (old_algorithm) then - if (i0 < i0_last_thick_cell) then - i0 = i0 + 1 - h0_supply = h0(i0) - dh0_eff = 0. - do while (h0_supply==0. .and. i0= h1_supply .and. tgt_has_volume) then ! h1_supply is smaller than h0_supply) so we consume h1_supply and increment the @@ -729,12 +673,8 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth i1 = i1 + 1 h1_supply = h1(i1) else - if (old_algorithm) then - h1_supply = 1.E30 - else - h1_supply = 0. - tgt_has_volume = .false. - endif + h1_supply = 0. + tgt_has_volume = .false. endif elseif (src_has_volume) then ! We ran out of target volume but still have source cells to consume @@ -984,18 +924,21 @@ end subroutine remap_via_sub_cells !! separation dh. real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, xa, xb) integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: u0(:) !< Cell means - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + real, intent(in) :: u0(:) !< Cell means [A] + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] integer, intent(in) :: method !< Remapping scheme to use integer, intent(in) :: i0 !< Source cell index - real, intent(in) :: xa !< Non-dimensional start position within source cell - real, intent(in) :: xb !< Non-dimensional end position within source cell + real, intent(in) :: xa !< Non-dimensional start position within source cell [nondim] + real, intent(in) :: xb !< Non-dimensional end position within source cell [nondim] ! Local variables - real :: u_ave, xa_2, xb_2, xa2pxb2, xapxb - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials - - real :: mx, a_L, a_R, u_c, Ya, Yb, my, xa2b2ab, Ya2b2ab, a_c + real :: u_ave ! The average value of the polynomial over the specified range [A] + real :: xapxb ! A sum of fracional positions [nondim] + real :: mx, Ya, Yb, my ! Various fractional positions [nondim] + real :: xa_2, xb_2 ! Squared fractional positions [nondim] + real :: xa2pxb2, xa2b2ab, Ya2b2ab ! Sums of squared fractional positions [nondim] + real :: a_L, a_R, u_c, a_c ! Values of the polynomial at various locations [A] + real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] if (xb > xa) then select case ( method ) @@ -1085,18 +1028,18 @@ end function average_value_ppoly !> Measure totals and bounds on source grid subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) integer, intent(in) :: n0 !< Number of cells on source grid - real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid - real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid - real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid - real, intent(out) :: h0tot !< Sum of cell widths - real, intent(out) :: h0err !< Magnitude of round-off error in h0tot - real, intent(out) :: u0tot !< Sum of cell widths times values - real, intent(out) :: u0err !< Magnitude of round-off error in u0tot - real, intent(out) :: u0min !< Minimum value in reconstructions of u0 - real, intent(out) :: u0max !< Maximum value in reconstructions of u0 + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,2), intent(in) :: edge_values !< Cell edge values on source grid [A] + real, intent(out) :: h0tot !< Sum of cell widths [H] + real, intent(out) :: h0err !< Magnitude of round-off error in h0tot [H] + real, intent(out) :: u0tot !< Sum of cell widths times values [H A] + real, intent(out) :: u0err !< Magnitude of round-off error in u0tot [H A] + real, intent(out) :: u0min !< Minimum value in reconstructions of u0 [A] + real, intent(out) :: u0max !< Maximum value in reconstructions of u0 [A] ! Local variables + real :: eps ! The smallest representable fraction of a number [nondim] integer :: k - real :: eps eps = epsilon(h0(1)) h0tot = h0(1) @@ -1119,17 +1062,17 @@ end subroutine measure_input_bounds !> Measure totals and bounds on destination grid subroutine measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) integer, intent(in) :: n1 !< Number of cells on destination grid - real, dimension(n1), intent(in) :: h1 !< Cell widths on destination grid - real, dimension(n1), intent(in) :: u1 !< Cell averages on destination grid - real, intent(out) :: h1tot !< Sum of cell widths - real, intent(out) :: h1err !< Magnitude of round-off error in h1tot - real, intent(out) :: u1tot !< Sum of cell widths times values - real, intent(out) :: u1err !< Magnitude of round-off error in u1tot - real, intent(out) :: u1min !< Minimum value in reconstructions of u1 - real, intent(out) :: u1max !< Maximum value in reconstructions of u1 + real, dimension(n1), intent(in) :: h1 !< Cell widths on destination grid [H] + real, dimension(n1), intent(in) :: u1 !< Cell averages on destination grid [A] + real, intent(out) :: h1tot !< Sum of cell widths [H] + real, intent(out) :: h1err !< Magnitude of round-off error in h1tot [H] + real, intent(out) :: u1tot !< Sum of cell widths times values [H A] + real, intent(out) :: u1err !< Magnitude of round-off error in u1tot [H A] + real, intent(out) :: u1min !< Minimum value in reconstructions of u1 [A] + real, intent(out) :: u1max !< Maximum value in reconstructions of u1 [A] ! Local variables + real :: eps ! The smallest representable fraction of a number [nondim] integer :: k - real :: eps eps = epsilon(h1(1)) h1tot = h1(1) @@ -1149,444 +1092,16 @@ subroutine measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, end subroutine measure_output_bounds -!> Remaps column of values u0 on grid h0 to grid h1 by integrating -!! over the projection of each h1 cell onto the h0 grid. -subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, h1, method, u1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) - real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(:) !< Target grid widths (size n1) - integer, intent(in) :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. - ! Local variables - integer :: iTarget - real :: xL, xR ! coordinates of target cell edges - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() - - ! Loop on cells in target grid (grid1). For each target cell, we need to find - ! in which source cells the target cell edges lie. The associated indexes are - ! noted j0 and j1. - xR = 0. ! Left boundary is at x=0 - jStart = 1 - xStart = 0. - do iTarget = 1,n1 - ! Determine the coordinates of the target cell edges - xL = xR - xR = xL + h1(iTarget) - - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) - - enddo ! end iTarget loop on target grid cells - -end subroutine remapByProjection - - -!> Remaps column of values u0 on grid h0 to implied grid h1 -!! where the interfaces of h1 differ from those of h0 by dx. -!! The new grid is defined relative to the original grid by change -!! dx1(:) = xNew(:) - xOld(:) -!! and the remapping calculated so that -!! hNew(k) qNew(k) = hOld(k) qOld(k) + F(k+1) - F(k) -!! where -!! F(k) = dx1(k) qAverage -!! and where qAverage is the average qOld in the region zOld(k) to zNew(k). -subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & - method, u1, h1, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) - real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial - integer, intent(in) :: n1 !< Number of cells in target grid - real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) - integer, intent(in) :: method !< Remapping scheme to use - real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) - real, dimension(:), & - optional, intent(out) :: h1 !< Target grid widths (size n1) - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. - ! Local variables - integer :: iTarget - real :: xL, xR ! coordinates of target cell edges - real :: xOld, hOld, uOld - real :: xNew, hNew, h_err - real :: uhNew, hFlux, uAve, fluxL, fluxR - integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() - - ! Loop on cells in target grid. For each cell, iTarget, the left flux is - ! the right flux of the cell to the left, iTarget-1. - ! The left flux is initialized by started at iTarget=0 to calculate the - ! right flux which can take into account the target left boundary being - ! in the interior of the source domain. - fluxR = 0. - h_err = 0. ! For measuring round-off error - jStart = 1 - xStart = 0. - do iTarget = 0,n1 - fluxL = fluxR ! This does nothing for iTarget=0 - - if (iTarget == 0) then - xOld = 0. ! Left boundary is at x=0 - hOld = -1.E30 ! Should not be used for iTarget = 0 - uOld = -1.E30 ! Should not be used for iTarget = 0 - elseif (iTarget <= n0) then - xOld = xOld + h0(iTarget) ! Position of right edge of cell - hOld = h0(iTarget) - uOld = u0(iTarget) - h_err = h_err + epsilon(hOld) * max(hOld, xOld) - else - hOld = 0. ! as if for layers>n0, they were vanished - uOld = 1.E30 ! and the initial value should not matter - endif - xNew = xOld + dx1(iTarget+1) - xL = min( xOld, xNew ) - xR = max( xOld, xNew ) - - ! hFlux is the positive width of the remapped volume - hFlux = abs(dx1(iTarget+1)) - call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hFlux, uAve, jStart, xStart ) - ! uAve is the average value of u, independent of sign of dx1 - fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 - - if (iTarget>0) then - hNew = hOld + ( dx1(iTarget+1) - dx1(iTarget) ) - hNew = max( 0., hNew ) - uhNew = ( uOld * hOld ) + ( fluxR - fluxL ) - if (hNew>0.) then - u1(iTarget) = uhNew / hNew - else - u1(iTarget) = uAve - endif - if (present(h1)) h1(iTarget) = hNew - endif - - enddo ! end iTarget loop on target grid cells - -end subroutine remapByDeltaZ - - -!> Integrate the reconstructed column profile over a single cell -subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & - xL, xR, hC, uAve, jStart, xStart, h_neglect ) - integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) - real, dimension(:), intent(in) :: u0 !< Source cell averages - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial - integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL !< Left edges of target cell - real, intent(in) :: xR !< Right edges of target cell - real, intent(in) :: hC !< Cell width hC = xR - xL - real, intent(out) :: uAve !< Average value on target cell - integer, intent(inout) :: jStart !< The index of the cell to start searching from - !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart - !< On first entry should be 0. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions - !! in the same units as h. - ! Local variables - integer :: j, k - integer :: jL, jR ! indexes of source cells containing target - ! cell edges - real :: q ! complete integration - real :: xi0, xi1 ! interval of integration (local -- normalized - ! -- coordinates) - real :: x0jLl, x0jLr ! Left/right position of cell jL - real :: x0jRl, x0jRr ! Left/right position of cell jR - real :: hAct ! The distance actually used in the integration - ! (notionally xR - xL) which differs due to roundoff. - real :: x0_2, x1_2, x02px12, x0px1 ! Used in evaluation of integrated polynomials - real :: hNeglect ! A negligible thicness in the same units as h. - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials - - hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect - - q = -1.E30 - x0jLl = -1.E30 - x0jRl = -1.E30 - - ! Find the left most cell in source grid spanned by the target cell - jL = -1 - x0jLr = xStart - do j = jStart, n0 - x0jLl = x0jLr - x0jLr = x0jLl + h0(j) - ! Left edge is found in cell j - if ( ( xL >= x0jLl ) .AND. ( xL <= x0jLr ) ) then - jL = j - exit ! once target grid cell is found, exit loop - endif - enddo - jStart = jL - xStart = x0jLl - -! ! HACK to handle round-off problems. Need only at j=n0. -! ! This moves the effective cell boundary outwards a smidgen. -! if (xL>x0jLr) x0jLr = xL - - ! If, at this point, jL is equal to -1, it means the vanished - ! cell lies outside the source grid. In other words, it means that - ! the source and target grids do not cover the same physical domain - ! and there is something very wrong ! - if ( jL == -1 ) call MOM_error(FATAL, & - 'MOM_remapping, integrateReconOnInterval: '//& - 'The location of the left-most cell could not be found') - - - ! ============================================================ - ! Check whether target cell is vanished. If it is, the cell - ! average is simply the interpolated value at the location - ! of the vanished cell. If it isn't, we need to integrate the - ! quantity within the cell and divide by the cell width to - ! determine the cell average. - ! ============================================================ - ! 1. Cell is vanished - !if ( abs(xR - xL) <= epsilon(xR)*max(abs(xR),abs(xL)) ) then - if ( abs(xR - xL) == 0.0 ) then - - ! We check whether the source cell (i.e. the cell in which the - ! vanished target cell lies) is vanished. If it is, the interpolated - ! value is set to be mean of the edge values (which should be the same). - ! If it isn't, we simply interpolate. - if ( h0(jL) == 0.0 ) then - uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) - else - ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA - xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) - - select case ( method ) - case ( INTEGRATION_PCM ) - uAve = ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ppoly0_coefs(jL,2) - case ( INTEGRATION_PPM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ( ppoly0_coefs(jL,2) & - + xi0 * ppoly0_coefs(jL,3) ) - case ( INTEGRATION_PQM ) - uAve = ppoly0_coefs(jL,1) & - + xi0 * ( ppoly0_coefs(jL,2) & - + xi0 * ( ppoly0_coefs(jL,3) & - + xi0 * ( ppoly0_coefs(jL,4) & - + xi0 * ppoly0_coefs(jL,5) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - endif ! end checking whether source cell is vanished - - ! 2. Cell is not vanished - else - - ! Find the right most cell in source grid spanned by the target cell - jR = -1 - x0jRr = xStart - do j = jStart,n0 - x0jRl = x0jRr - x0jRr = x0jRl + h0(j) - ! Right edge is found in cell j - if ( ( xR >= x0jRl ) .AND. ( xR <= x0jRr ) ) then - jR = j - exit ! once target grid cell is found, exit loop - endif - enddo ! end loop on source grid cells - - ! If xR>x0jRr then the previous loop reached j=n0 and the target - ! position, xR, was beyond the right edge of the source grid (h0). - ! This can happen due to roundoff, in which case we set jR=n0. - if (xR>x0jRr) jR = n0 - - ! To integrate, two cases must be considered: (1) the target cell is - ! entirely contained within a cell of the source grid and (2) the target - ! cell spans at least two cells of the source grid. - - if ( jL == jR ) then - ! The target cell is entirely contained within a cell of the source - ! grid. This situation is represented by the following schematic, where - ! the cell in which xL and xR are located has index jL=jR : - ! - ! ----|-----o--------o----------|------------- - ! xL xR - ! - ! Determine normalized coordinates -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) - xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) -#else - xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) - xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) -#endif - - hAct = h0(jL) * ( xi1 - xi0 ) - - ! Depending on which polynomial is used, integrate quantity - ! between xi0 and xi1. Integration is carried out in normalized - ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi - select case ( method ) - case ( INTEGRATION_PCM ) - q = ( xR - xL ) * ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = ( xR - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - else - ! The target cell spans at least two cells of the source grid. - ! This situation is represented by the following schematic, where - ! the cells in which xL and xR are located have indexes jL and jR, - ! respectively : - ! - ! ----|-----o---|--- ... --|---o----------|------------- - ! xL xR - ! - ! We first integrate from xL up to the right boundary of cell jL, then - ! add the integrated amounts of cells located between jL and jR and then - ! integrate from the left boundary of cell jR up to xR - - q = 0.0 - - ! Integrate from xL up to right boundary of cell jL -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) -#else - xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) -#endif - xi1 = 1.0 - - hAct = h0(jL) * ( xi1 - xi0 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) - case ( INTEGRATION_PLM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = q + ( x0jLr - xL ) * ( & - ppoly0_coefs(jL,1) & - + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL, 'The selected integration method is invalid' ) - end select - - ! Integrate contents within cells strictly comprised between jL and jR - if ( jR > (jL+1) ) then - do k = jL+1,jR-1 - q = q + h0(k) * u0(k) - hAct = hAct + h0(k) - enddo - endif - - ! Integrate from left boundary of cell jR up to xR - xi0 = 0.0 -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ - xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) -#else - xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) -#endif - - hAct = hAct + h0(jR) * ( xi1 - xi0 ) - - select case ( method ) - case ( INTEGRATION_PCM ) - q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) - case ( INTEGRATION_PLM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) - case ( INTEGRATION_PPM ) - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) - case ( INTEGRATION_PQM ) - x0_2 = xi0*xi0 - x1_2 = xi1*xi1 - x02px12 = x0_2 + x1_2 - x0px1 = xi1 + xi0 - q = q + ( xR - x0jRl ) * ( & - ppoly0_coefs(jR,1) & - + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & - + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & - + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & - + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) - case default - call MOM_error( FATAL,'The selected integration method is invalid' ) - end select - - endif ! end integration for non-vanished cells - - ! The cell average is the integrated value divided by the cell width -#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ -if (hAct==0.) then - uAve = ppoly0_coefs(jL,1) -else - uAve = q / hAct -endif -#else - uAve = q / hC -#endif - - endif ! endif clause to check if cell is vanished - -end subroutine integrateReconOnInterval - !> Calculates the change in interface positions based on h1 and h2 subroutine dzFromH1H2( n1, h1, n2, h2, dx ) integer, intent(in) :: n1 !< Number of cells on source grid - real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) + real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) [H] integer, intent(in) :: n2 !< Number of cells on target grid - real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) - real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) + real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) [H] + real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) [H] ! Local variables integer :: k - real :: x1, x2 + real :: x1, x2 ! Interface positions [H] x1 = 0. x2 = 0. @@ -1611,7 +1126,7 @@ subroutine initialize_remapping( CS, remapping_scheme, boundary_extrapolation, & logical, optional, intent(in) :: check_reconstruction !< Indicate to check reconstructions logical, optional, intent(in) :: check_remapping !< Indicate to check results of remapping logical, optional, intent(in) :: force_bounds_in_subcell !< Force subcells values to be bounded - logical, optional, intent(in) :: answers_2018 !< If true use older, less acccurate expressions. + logical, optional, intent(in) :: answers_2018 !< If true use older, less accurate expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Note that remapping_scheme is mandatory for initialize_remapping() @@ -1684,8 +1199,8 @@ logical function remapping_unit_tests(verbose) ! Local variables integer, parameter :: n0 = 4, n1 = 3, n2 = 6 real :: h0(n0), x0(n0+1), u0(n0) - real :: h1(n1), x1(n1+1), u1(n1), hn1(n1), dx1(n1+1) - real :: h2(n2), x2(n2+1), u2(n2), hn2(n2), dx2(n2+1) + real :: h1(n1), x1(n1+1), u1(n1), dx1(n1+1) + real :: h2(n2), x2(n2+1), u2(n2) data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 data h1 /3*1./ ! 3 uniform layers with total depth of 3 @@ -1694,6 +1209,10 @@ logical function remapping_unit_tests(verbose) real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs integer :: answer_date ! The vintage of the expressions to test integer :: i + real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be + ! added to thicknesses in a denominator without + ! changing the numerical result, except where + ! a division by zero would otherwise occur. real :: err, h_neglect, h_neglect_edge logical :: thisTest, v @@ -1749,49 +1268,9 @@ logical function remapping_unit_tests(verbose) call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) - u1(:) = 0. - call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, h1, INTEGRATION_PPM, u1, h_neglect ) - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByProjection()' - remapping_unit_tests = remapping_unit_tests .or. thisTest - - thisTest = .false. - u1(:) = 0. - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n1, x1-x0(1:n1+1), & - INTEGRATION_PPM, u1, hn1, h_neglect ) - if (verbose) write(stdout,*) 'h1 (by delta)' - if (verbose) call dumpGrid(n1,h1,x1,u1) - hn1=hn1-h1 - do i=1,n1 - err=u1(i)-8.*(0.5*real(1+n1)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByDeltaZ() 1' - remapping_unit_tests = remapping_unit_tests .or. thisTest thisTest = .false. call buildGridFromH(n2, h2, x2) - dx2(1:n0+1) = x2(1:n0+1) - x0 - dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) - call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & - n2, dx2, & - INTEGRATION_PPM, u2, hn2, h_neglect ) - if (verbose) write(stdout,*) 'h2' - if (verbose) call dumpGrid(n2,h2,x2,u2) - if (verbose) write(stdout,*) 'hn2' - if (verbose) call dumpGrid(n2,hn2,x2,u2) - - do i=1,n2 - err=u2(i)-8./2.*(0.5*real(1+n2)-real(i)) - if (abs(err)>2.*epsilon(err)) thisTest = .true. - enddo - if (thisTest) write(stdout,*) 'remapping_unit_tests: Failed remapByDeltaZ() 2' - remapping_unit_tests = remapping_unit_tests .or. thisTest if (verbose) write(stdout,*) 'Via sub-cells' thisTest = .false. @@ -1945,6 +1424,9 @@ logical function remapping_unit_tests(verbose) deallocate(ppoly0_E, ppoly0_S, ppoly0_coefs) + ! This line carries out tests on some older remapping schemes. + remapping_unit_tests = remapping_unit_tests .or. remapping_attic_unit_tests(verbose) + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' end function remapping_unit_tests @@ -1953,12 +1435,12 @@ end function remapping_unit_tests logical function test_answer(verbose, n, u, u_true, label, tol) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: n !< Number of cells in u - real, dimension(n), intent(in) :: u !< Values to test - real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) + real, dimension(n), intent(in) :: u !< Values to test [A] + real, dimension(n), intent(in) :: u_true !< Values to test against (correct answer) [A] character(len=*), intent(in) :: label !< Message - real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] ! Local variables - real :: tolerance ! The tolerance for differences between u and u_true + real :: tolerance ! The tolerance for differences between u and u_true [A] integer :: k tolerance = 0.0 ; if (present(tol)) tolerance = tol @@ -1983,9 +1465,9 @@ end function test_answer !> Convenience function for printing grid to screen subroutine dumpGrid(n,h,x,u) integer, intent(in) :: n !< Number of cells - real, dimension(:), intent(in) :: h !< Cell thickness - real, dimension(:), intent(in) :: x !< Interface delta - real, dimension(:), intent(in) :: u !< Cell average values + real, dimension(:), intent(in) :: h !< Cell thickness [H] + real, dimension(:), intent(in) :: x !< Interface delta [H] + real, dimension(:), intent(in) :: u !< Cell average values [A] integer :: i write(stdout,'("i=",20i10)') (i,i=1,n+1) write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) diff --git a/src/ALE/remapping_attic.F90 b/src/ALE/remapping_attic.F90 new file mode 100644 index 0000000000..534428aaed --- /dev/null +++ b/src/ALE/remapping_attic.F90 @@ -0,0 +1,648 @@ +!> Retains older versions of column-wise vertical remapping functions that are +!! no longer used in MOM6, but may be useful later for documenting the development +!! of the schemes that are used in MOM6. +module remapping_attic + +! This file is part of MOM6. See LICENSE.md for the license. +! Original module written by Laurent White, 2008.06.09 + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io, only : stdout +use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use regrid_edge_values, only : edge_values_explicit_h4 + +implicit none ; private + +! The following routines are visible to the outside world +public remapping_attic_unit_tests, remapByProjection, remapByDeltaZ +public isPosSumErrSignificant + +! The following are private parameter constants +integer, parameter :: INTEGRATION_PCM = 0 !< Piecewise Constant Method +integer, parameter :: INTEGRATION_PLM = 1 !< Piecewise Linear Method +integer, parameter :: INTEGRATION_PPM = 3 !< Piecewise Parabolic Method +integer, parameter :: INTEGRATION_PQM = 5 !< Piecewise Quartic Method + +! This CPP macro turns on/off bounding of integrations limits so that they are +! always within the cell. Roundoff can lead to the non-dimensional bounds being +! outside of the range 0 to 1. +#define __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + +real, parameter :: hNeglect_dflt = 1.E-30 !< A thickness [H ~> m or kg m-2] that can be + !! added to thicknesses in a denominator without + !! changing the numerical result, except where + !! a division by zero would otherwise occur. + +contains + +!> Compare two summation estimates of positive data and judge if due to more +!! than round-off. +!! When two sums are calculated from different vectors that should add up to +!! the same value, the results can differ by round off. The round off error +!! can be bounded to be proportional to the number of operations. +!! This function returns true if the difference between sum1 and sum2 is +!! larger than than the estimated round off bound. +!! \note This estimate/function is only valid for summation of positive data. +function isPosSumErrSignificant(n1, sum1, n2, sum2) + integer, intent(in) :: n1 !< Number of values in sum1 + integer, intent(in) :: n2 !< Number of values in sum2 + real, intent(in) :: sum1 !< Sum of n1 values [A] + real, intent(in) :: sum2 !< Sum of n2 values [A] + logical :: isPosSumErrSignificant !< True if difference in sums is large + ! Local variables + real :: sumErr, allowedErr, eps + + if (sum1<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum1<0 is not allowed!') + if (sum2<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum2<0 is not allowed!') + sumErr = abs(sum1-sum2) + eps = epsilon(sum1) + allowedErr = eps*0.5*(real(n1-1)*sum1+real(n2-1)*sum2) + if (sumErr>allowedErr) then + write(0,*) 'isPosSumErrSignificant: sum1,sum2=',sum1,sum2 + write(0,*) 'isPosSumErrSignificant: eps=',eps + write(0,*) 'isPosSumErrSignificant: err,n*eps=',sumErr,allowedErr + write(0,*) 'isPosSumErrSignificant: err/eps,n1,n2,n1+n2=',sumErr/eps,n1,n2,n1+n2 + isPosSumErrSignificant = .true. + else + isPosSumErrSignificant = .false. + endif +end function isPosSumErrSignificant + +!> Remaps column of values u0 on grid h0 to grid h1 by integrating +!! over the projection of each h1 cell onto the h0 grid. +subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h1, method, u1, h_neglect ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, intent(in) :: h0(:) !< Source grid widths (size n0) + real, intent(in) :: u0(:) !< Source cell averages (size n0) + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + integer, intent(in) :: n1 !< Number of cells in target grid + real, intent(in) :: h1(:) !< Target grid widths (size n1) + integer, intent(in) :: method !< Remapping scheme to use + real, intent(out) :: u1(:) !< Target cell averages (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. + ! Local variables + integer :: iTarget + real :: xL, xR ! coordinates of target cell edges + integer :: jStart ! Used by integrateReconOnInterval() + real :: xStart ! Used by integrateReconOnInterval() + + ! Loop on cells in target grid (grid1). For each target cell, we need to find + ! in which source cells the target cell edges lie. The associated indexes are + ! noted j0 and j1. + xR = 0. ! Left boundary is at x=0 + jStart = 1 + xStart = 0. + do iTarget = 1,n1 + ! Determine the coordinates of the target cell edges + xL = xR + xR = xL + h1(iTarget) + + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & + xL, xR, h1(iTarget), u1(iTarget), jStart, xStart, h_neglect ) + + enddo ! end iTarget loop on target grid cells + +end subroutine remapByProjection + +!> Remaps column of values u0 on grid h0 to implied grid h1 +!! where the interfaces of h1 differ from those of h0 by dx. +!! The new grid is defined relative to the original grid by change +!! dx1(:) = xNew(:) - xOld(:) +!! and the remapping calculated so that +!! hNew(k) qNew(k) = hOld(k) qOld(k) + F(k+1) - F(k) +!! where +!! F(k) = dx1(k) qAverage +!! and where qAverage is the average qOld in the region zOld(k) to zNew(k). +subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & + method, u1, h1, h_neglect ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: n1 !< Number of cells in target grid + real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) + integer, intent(in) :: method !< Remapping scheme to use + real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) + real, dimension(:), & + optional, intent(out) :: h1 !< Target grid widths (size n1) + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h. + ! Local variables + integer :: iTarget + real :: xL, xR ! coordinates of target cell edges + real :: xOld, hOld, uOld + real :: xNew, hNew, h_err + real :: uhNew, hFlux, uAve, fluxL, fluxR + integer :: jStart ! Used by integrateReconOnInterval() + real :: xStart ! Used by integrateReconOnInterval() + + ! Loop on cells in target grid. For each cell, iTarget, the left flux is + ! the right flux of the cell to the left, iTarget-1. + ! The left flux is initialized by started at iTarget=0 to calculate the + ! right flux which can take into account the target left boundary being + ! in the interior of the source domain. + fluxR = 0. + h_err = 0. ! For measuring round-off error + jStart = 1 + xStart = 0. + do iTarget = 0,n1 + fluxL = fluxR ! This does nothing for iTarget=0 + + if (iTarget == 0) then + xOld = 0. ! Left boundary is at x=0 + hOld = -1.E30 ! Should not be used for iTarget = 0 + uOld = -1.E30 ! Should not be used for iTarget = 0 + elseif (iTarget <= n0) then + xOld = xOld + h0(iTarget) ! Position of right edge of cell + hOld = h0(iTarget) + uOld = u0(iTarget) + h_err = h_err + epsilon(hOld) * max(hOld, xOld) + else + hOld = 0. ! as if for layers>n0, they were vanished + uOld = 1.E30 ! and the initial value should not matter + endif + xNew = xOld + dx1(iTarget+1) + xL = min( xOld, xNew ) + xR = max( xOld, xNew ) + + ! hFlux is the positive width of the remapped volume + hFlux = abs(dx1(iTarget+1)) + call integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & + xL, xR, hFlux, uAve, jStart, xStart ) + ! uAve is the average value of u, independent of sign of dx1 + fluxR = dx1(iTarget+1)*uAve ! Includes sign of dx1 + + if (iTarget>0) then + hNew = hOld + ( dx1(iTarget+1) - dx1(iTarget) ) + hNew = max( 0., hNew ) + uhNew = ( uOld * hOld ) + ( fluxR - fluxL ) + if (hNew>0.) then + u1(iTarget) = uhNew / hNew + else + u1(iTarget) = uAve + endif + if (present(h1)) h1(iTarget) = hNew + endif + + enddo ! end iTarget loop on target grid cells + +end subroutine remapByDeltaZ + +!> Integrate the reconstructed column profile over a single cell +subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & + xL, xR, hC, uAve, jStart, xStart, h_neglect ) + integer, intent(in) :: n0 !< Number of cells in source grid + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) + real, dimension(:), intent(in) :: u0 !< Source cell averages + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + integer, intent(in) :: method !< Remapping scheme to use + real, intent(in) :: xL !< Left edges of target cell + real, intent(in) :: xR !< Right edges of target cell + real, intent(in) :: hC !< Cell width hC = xR - xL + real, intent(out) :: uAve !< Average value on target cell + integer, intent(inout) :: jStart !< The index of the cell to start searching from + !< On exit, contains index of last cell used + real, intent(inout) :: xStart !< The left edge position of cell jStart + !< On first entry should be 0. + real, optional, intent(in) :: h_neglect !< A negligibly small width for the + !! purpose of cell reconstructions + !! in the same units as h + ! Local variables + integer :: j, k + integer :: jL, jR ! indexes of source cells containing target + ! cell edges + real :: q ! complete integration + real :: xi0, xi1 ! interval of integration (local -- normalized + ! -- coordinates) + real :: x0jLl, x0jLr ! Left/right position of cell jL + real :: x0jRl, x0jRr ! Left/right position of cell jR + real :: hAct ! The distance actually used in the integration + ! (notionally xR - xL) which differs due to roundoff. + real :: x0_2, x1_2, x02px12, x0px1 ! Used in evaluation of integrated polynomials + real :: hNeglect ! A negligible thickness in the same units as h + real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + q = -1.E30 + x0jLl = -1.E30 + x0jRl = -1.E30 + + ! Find the left most cell in source grid spanned by the target cell + jL = -1 + x0jLr = xStart + do j = jStart, n0 + x0jLl = x0jLr + x0jLr = x0jLl + h0(j) + ! Left edge is found in cell j + if ( ( xL >= x0jLl ) .AND. ( xL <= x0jLr ) ) then + jL = j + exit ! once target grid cell is found, exit loop + endif + enddo + jStart = jL + xStart = x0jLl + +! ! HACK to handle round-off problems. Need only at j=n0. +! ! This moves the effective cell boundary outwards a smidgen. +! if (xL>x0jLr) x0jLr = xL + + ! If, at this point, jL is equal to -1, it means the vanished + ! cell lies outside the source grid. In other words, it means that + ! the source and target grids do not cover the same physical domain + ! and there is something very wrong ! + if ( jL == -1 ) call MOM_error(FATAL, & + 'MOM_remapping, integrateReconOnInterval: '//& + 'The location of the left-most cell could not be found') + + + ! ============================================================ + ! Check whether target cell is vanished. If it is, the cell + ! average is simply the interpolated value at the location + ! of the vanished cell. If it isn't, we need to integrate the + ! quantity within the cell and divide by the cell width to + ! determine the cell average. + ! ============================================================ + ! 1. Cell is vanished + !if ( abs(xR - xL) <= epsilon(xR)*max(abs(xR),abs(xL)) ) then + if ( abs(xR - xL) == 0.0 ) then + + ! We check whether the source cell (i.e. the cell in which the + ! vanished target cell lies) is vanished. If it is, the interpolated + ! value is set to be mean of the edge values (which should be the same). + ! If it isn't, we simply interpolate. + if ( h0(jL) == 0.0 ) then + uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) + else + !### WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA + xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) + + select case ( method ) + case ( INTEGRATION_PCM ) + uAve = ppoly0_coefs(jL,1) + case ( INTEGRATION_PLM ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ppoly0_coefs(jL,2) + case ( INTEGRATION_PPM ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ppoly0_coefs(jL,3) ) + case ( INTEGRATION_PQM ) + uAve = ppoly0_coefs(jL,1) & + + xi0 * ( ppoly0_coefs(jL,2) & + + xi0 * ( ppoly0_coefs(jL,3) & + + xi0 * ( ppoly0_coefs(jL,4) & + + xi0 * ppoly0_coefs(jL,5) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + + endif ! end checking whether source cell is vanished + + ! 2. Cell is not vanished + else + + ! Find the right most cell in source grid spanned by the target cell + jR = -1 + x0jRr = xStart + do j = jStart,n0 + x0jRl = x0jRr + x0jRr = x0jRl + h0(j) + ! Right edge is found in cell j + if ( ( xR >= x0jRl ) .AND. ( xR <= x0jRr ) ) then + jR = j + exit ! once target grid cell is found, exit loop + endif + enddo ! end loop on source grid cells + + ! If xR>x0jRr then the previous loop reached j=n0 and the target + ! position, xR, was beyond the right edge of the source grid (h0). + ! This can happen due to roundoff, in which case we set jR=n0. + if (xR>x0jRr) jR = n0 + + ! To integrate, two cases must be considered: (1) the target cell is + ! entirely contained within a cell of the source grid and (2) the target + ! cell spans at least two cells of the source grid. + + if ( jL == jR ) then + ! The target cell is entirely contained within a cell of the source + ! grid. This situation is represented by the following schematic, where + ! the cell in which xL and xR are located has index jL=jR : + ! + ! ----|-----o--------o----------|------------- + ! xL xR + ! + ! Determine normalized coordinates +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) + xi1 = max( 0., min( 1., ( xR - x0jLl ) / ( h0(jL) + hNeglect ) ) ) +#else + xi0 = xL / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) + xi1 = xR / h0(jL) - x0jLl / ( h0(jL) + hNeglect ) +#endif + + hAct = h0(jL) * ( xi1 - xi0 ) + + ! Depending on which polynomial is used, integrate quantity + ! between xi0 and xi1. Integration is carried out in normalized + ! coordinates, hence: \int_xL^xR p(x) dx = h \int_xi0^xi1 p(xi) dxi + select case ( method ) + case ( INTEGRATION_PCM ) + q = ( xR - xL ) * ppoly0_coefs(jL,1) + case ( INTEGRATION_PLM ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) + case ( INTEGRATION_PPM ) + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + case ( INTEGRATION_PQM ) + x0_2 = xi0*xi0 + x1_2 = xi1*xi1 + x02px12 = x0_2 + x1_2 + x0px1 = xi1 + xi0 + q = ( xR - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + + else + ! The target cell spans at least two cells of the source grid. + ! This situation is represented by the following schematic, where + ! the cells in which xL and xR are located have indexes jL and jR, + ! respectively : + ! + ! ----|-----o---|--- ... --|---o----------|------------- + ! xL xR + ! + ! We first integrate from xL up to the right boundary of cell jL, then + ! add the integrated amounts of cells located between jL and jR and then + ! integrate from the left boundary of cell jR up to xR + + q = 0.0 + + ! Integrate from xL up to right boundary of cell jL +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + xi0 = max( 0., min( 1., ( xL - x0jLl ) / ( h0(jL) + hNeglect ) ) ) +#else + xi0 = (xL - x0jLl) / ( h0(jL) + hNeglect ) +#endif + xi1 = 1.0 + + hAct = h0(jL) * ( xi1 - xi0 ) + + select case ( method ) + case ( INTEGRATION_PCM ) + q = q + ( x0jLr - xL ) * ppoly0_coefs(jL,1) + case ( INTEGRATION_PLM ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) ) + case ( INTEGRATION_PPM ) + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jL,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + case ( INTEGRATION_PQM ) + x0_2 = xi0*xi0 + x1_2 = xi1*xi1 + x02px12 = x0_2 + x1_2 + x0px1 = xi1 + xi0 + q = q + ( x0jLr - xL ) * ( & + ppoly0_coefs(jL,1) & + + ( ppoly0_coefs(jL,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jL,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jL,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jL,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + case default + call MOM_error( FATAL, 'The selected integration method is invalid' ) + end select + + ! Integrate contents within cells strictly comprised between jL and jR + if ( jR > (jL+1) ) then + do k = jL+1,jR-1 + q = q + h0(k) * u0(k) + hAct = hAct + h0(k) + enddo + endif + + ! Integrate from left boundary of cell jR up to xR + xi0 = 0.0 +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ + xi1 = max( 0., min( 1., ( xR - x0jRl ) / ( h0(jR) + hNeglect ) ) ) +#else + xi1 = (xR - x0jRl) / ( h0(jR) + hNeglect ) +#endif + + hAct = hAct + h0(jR) * ( xi1 - xi0 ) + + select case ( method ) + case ( INTEGRATION_PCM ) + q = q + ( xR - x0jRl ) * ppoly0_coefs(jR,1) + case ( INTEGRATION_PLM ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) ) + case ( INTEGRATION_PPM ) + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ppoly0_coefs(jR,3) * r_3 * ( ( xi1*xi1 + xi0*xi0 ) + xi0*xi1 ) ) ) + case ( INTEGRATION_PQM ) + x0_2 = xi0*xi0 + x1_2 = xi1*xi1 + x02px12 = x0_2 + x1_2 + x0px1 = xi1 + xi0 + q = q + ( xR - x0jRl ) * ( & + ppoly0_coefs(jR,1) & + + ( ppoly0_coefs(jR,2) * 0.5 * ( xi1 + xi0 ) & + + ( ppoly0_coefs(jR,3) * r_3 * ( x02px12 + xi0*xi1 ) & + + ppoly0_coefs(jR,4) * 0.25* ( x02px12 * x0px1 ) & + + ppoly0_coefs(jR,5) * 0.2 * ( ( xi1*x1_2 + xi0*x0_2 ) * x0px1 + x0_2*x1_2 ) ) ) ) + case default + call MOM_error( FATAL,'The selected integration method is invalid' ) + end select + + endif ! end integration for non-vanished cells + + ! The cell average is the integrated value divided by the cell width +#ifdef __USE_ROUNDOFF_SAFE_ADJUSTMENTS__ +if (hAct==0.) then + uAve = ppoly0_coefs(jL,1) +else + uAve = q / hAct +endif +#else + uAve = q / hC +#endif + + endif ! endif clause to check if cell is vanished + +end subroutine integrateReconOnInterval + +!> Calculates the change in interface positions based on h1 and h2 +subroutine dzFromH1H2( n1, h1, n2, h2, dx ) + integer, intent(in) :: n1 !< Number of cells on source grid + real, dimension(:), intent(in) :: h1 !< Cell widths of source grid (size n1) [H] + integer, intent(in) :: n2 !< Number of cells on target grid + real, dimension(:), intent(in) :: h2 !< Cell widths of target grid (size n2) [H] + real, dimension(:), intent(out) :: dx !< Change in interface position (size n2+1) [H] + ! Local variables + integer :: k + real :: x1, x2 ! Interface positions [H] + + x1 = 0. + x2 = 0. + dx(1) = 0. + do K = 1, max(n1,n2) + if (k <= n1) x1 = x1 + h1(k) ! Interface k+1, right of source cell k + if (k <= n2) then + x2 = x2 + h2(k) ! Interface k+1, right of target cell k + dx(K+1) = x2 - x1 ! Change of interface k+1, target - source + endif + enddo + +end subroutine dzFromH1H2 + +!> Calculate edge coordinate x from cell width h +subroutine buildGridFromH(nz, h, x) + integer, intent(in) :: nz !< Number of cells + real, dimension(nz), intent(in) :: h !< Cell widths [H] + real, dimension(nz+1), intent(inout) :: x !< Edge coordinates starting at x(1)=0 [H] + ! Local variables + integer :: k + + x(1) = 0.0 + do k = 1,nz + x(k+1) = x(k) + h(k) + enddo + +end subroutine buildGridFromH + +!> Runs unit tests on archaic remapping functions. +!! Should only be called from a single/root thread +!! Returns True if a test fails, otherwise False +logical function remapping_attic_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + ! Local variables + integer, parameter :: n0 = 4, n1 = 3, n2 = 6 + real :: h0(n0), x0(n0+1), u0(n0) + real :: h1(n1), x1(n1+1), u1(n1), hn1(n1), dx1(n1+1) + real :: h2(n2), x2(n2+1), u2(n2), hn2(n2), dx2(n2+1) + data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom + data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 + data h1 /3*1./ ! 3 uniform layers with total depth of 3 + data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 + real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs + integer :: answer_date ! The vintage of the expressions to test + integer :: i, degree + real :: err, h_neglect, h_neglect_edge + logical :: thisTest, v + + v = verbose + answer_date = 20190101 ! 20181231 + h_neglect = hNeglect_dflt + h_neglect_edge = hNeglect_dflt ; if (answer_date < 20190101) h_neglect_edge = 1.0e-10 + + write(stdout,*) '==== remapping_attic: remapping_attic_unit_tests =================' + remapping_attic_unit_tests = .false. ! Normally return false + + call buildGridFromH(n0, h0, x0) + call buildGridFromH(n1, h1, x1) + + thisTest = .false. + degree = 2 + if (verbose) write(stdout,*) 'h0 (test data)' + if (verbose) call dumpGrid(n0,h0,x0,u0) + + call dzFromH1H2( n0, h0, n1, h1, dx1 ) + + thisTest = .false. + allocate(ppoly0_E(n0,2)) + allocate(ppoly0_S(n0,2)) + allocate(ppoly0_coefs(n0,degree+1)) + + ppoly0_E(:,:) = 0.0 + ppoly0_S(:,:) = 0.0 + ppoly0_coefs(:,:) = 0.0 + + call edge_values_explicit_h4( n0, h0, u0, ppoly0_E, h_neglect=1e-10, answer_date=answer_date ) + call PPM_reconstruction( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=answer_date ) + call PPM_boundary_extrapolation( n0, h0, u0, ppoly0_E, ppoly0_coefs, h_neglect ) + u1(:) = 0. + call remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, h1, INTEGRATION_PPM, u1, h_neglect ) + do i=1,n1 + err = u1(i)-8.*(0.5*real(1+n1)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByProjection()' + remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest + + thisTest = .false. + u1(:) = 0. + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n1, x1-x0(1:n1+1), & + INTEGRATION_PPM, u1, hn1, h_neglect ) + if (verbose) write(stdout,*) 'h1 (by delta)' + if (verbose) call dumpGrid(n1,h1,x1,u1) + hn1 = hn1-h1 + do i=1,n1 + err = u1(i)-8.*(0.5*real(1+n1)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByDeltaZ() 1' + remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest + + thisTest = .false. + call buildGridFromH(n2, h2, x2) + dx2(1:n0+1) = x2(1:n0+1) - x0 + dx2(n0+2:n2+1) = x2(n0+2:n2+1) - x0(n0+1) + call remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, & + n2, dx2, & + INTEGRATION_PPM, u2, hn2, h_neglect ) + if (verbose) write(stdout,*) 'h2' + if (verbose) call dumpGrid(n2,h2,x2,u2) + if (verbose) write(stdout,*) 'hn2' + if (verbose) call dumpGrid(n2,hn2,x2,u2) + + do i=1,n2 + err = u2(i)-8./2.*(0.5*real(1+n2)-real(i)) + if (abs(err)>2.*epsilon(err)) thisTest = .true. + enddo + if (thisTest) write(stdout,*) 'remapping_attic_unit_tests: Failed remapByDeltaZ() 2' + remapping_attic_unit_tests = remapping_attic_unit_tests .or. thisTest + + if (.not. remapping_attic_unit_tests) write(stdout,*) 'Pass' + +end function remapping_attic_unit_tests + +!> Convenience function for printing grid to screen +subroutine dumpGrid(n,h,x,u) + integer, intent(in) :: n !< Number of cells + real, dimension(:), intent(in) :: h !< Cell thickness [H] + real, dimension(:), intent(in) :: x !< Interface delta [H] + real, dimension(:), intent(in) :: u !< Cell average values [A] + integer :: i + write(stdout,'("i=",20i10)') (i,i=1,n+1) + write(stdout,'("x=",20es10.2)') (x(i),i=1,n+1) + write(stdout,'("i=",5x,20i10)') (i,i=1,n) + write(stdout,'("h=",5x,20es10.2)') (h(i),i=1,n) + write(stdout,'("u=",5x,20es10.2)') (u(i),i=1,n) +end subroutine dumpGrid + +end module remapping_attic From f93728875bf92a91b1212e5be366e02fd15f3417 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 23 Oct 2022 11:43:17 -0400 Subject: [PATCH 022/629] +Move interpolate_column to MOM_remapping.F90 Moved interpolate_column and reintegrate_column (without changing anything) from MOM_diag_vkernels.F90 to MOM_remapping.F90 and incorporated the tests that had been in diag_vkernels_unit_tests into remapping_unit_tests. The entire MOM_diag_vkernels.F90 file was then removed. All answers are bitwise identical, although the module for two public routines was changed and a third was eliminated. --- src/ALE/MOM_ALE.F90 | 2 +- src/ALE/MOM_remapping.F90 | 334 +++++++++++++++- src/core/MOM_unit_tests.F90 | 3 - src/framework/MOM_diag_remap.F90 | 5 +- src/framework/MOM_diag_vkernels.F90 | 357 ------------------ src/tracer/MOM_lateral_boundary_diffusion.F90 | 3 +- src/tracer/MOM_offline_aux.F90 | 2 +- 7 files changed, 337 insertions(+), 369 deletions(-) delete mode 100644 src/framework/MOM_diag_vkernels.F90 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 8116ba3e17..5fd84c73c9 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -13,7 +13,6 @@ module MOM_ALE use MOM_debugging, only : check_column_integrals use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl use MOM_diag_mediator, only : time_type, diag_update_remap_grids, query_averaging_enabled -use MOM_diag_vkernels, only : interpolate_column, reintegrate_column use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_showQuery @@ -40,6 +39,7 @@ module MOM_ALE use MOM_remapping, only : initialize_remapping, end_remapping use MOM_remapping, only : remapping_core_h, remapping_core_w use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_remapping, only : interpolate_column, reintegrate_column use MOM_remapping, only : remapping_CS, dzFromH1H2 use MOM_string_functions, only : uppercase, extractWord, extract_integer use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 061894711c..20d3930d69 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -42,7 +42,7 @@ module MOM_remapping public remapping_core_h, remapping_core_w public initialize_remapping, end_remapping, remapping_set_param, extract_member_remapping_CS public remapping_unit_tests, build_reconstructions_1d, average_value_ppoly -public dzFromH1H2 +public interpolate_column, reintegrate_column, dzFromH1H2 ! The following are private parameter constants integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme @@ -919,6 +919,157 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth end subroutine remap_via_sub_cells +!> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest +subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells + real, intent(in) :: missing_value !< Value to assign in vanished cells + real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces + ! Local variables + real :: x_dest ! Relative position of target interface + real :: dh ! Source cell thickness + real :: u1, u2 ! Values to interpolate between + real :: weight_a, weight_b ! Weights for interpolation + integer :: k_src, k_dest ! Index of cell in src and dest columns + logical :: still_vanished ! Used for figuring out what to mask as missing + + ! Initial values for the loop + still_vanished = .true. + + ! The following forces the "do while" loop to do one cycle that will set u1, u2, dh. + k_src = 0 + dh = 0. + x_dest = 0. + + do k_dest=1, ndest+1 + do while (dh<=x_dest .and. k_src0.) then + weight_a = max(0., ( dh - x_dest ) / dh) ! Weight of u1 + weight_b = min(1., x_dest / dh) ! Weight of u2 + u_dest(k_dest) = weight_a * u1 + weight_b * u2 ! Linear interpolation between u1 and u2 + else + u_dest(k_dest) = 0.5 * ( u1 + u2 ) ! For a vanished layer we need to do something reasonable... + endif + + ! Mask vanished layers at the surface which would be under an ice-shelf. + ! TODO: Need to figure out what to do for an isopycnal coordinate diagnostic that could + ! also have vanished layers at the surface. + if (k_dest<=ndest) then + x_dest = x_dest + h_dest(k_dest) ! Position of interface k_dest+1 + if (still_vanished .and. h_dest(k_dest)==0.) then + ! When the layer k_dest is vanished and all layers above are also vanished, the k_dest + ! interface value should be missing. + u_dest(k_dest) = missing_value + else + still_vanished = .false. + endif + endif + + enddo + + ! Mask vanished layers on topography + still_vanished = .true. + do k_dest=ndest, 1, -1 + if (still_vanished .and. h_dest(k_dest)==0.) then + ! When the layer k_dest is vanished and all layers below are also vanished, the k_dest+1 + ! interface value should be missing. + u_dest(k_dest+1) = missing_value + else + exit + endif + enddo + +end subroutine interpolate_column + +!> Conservatively calculate integrated data, uh_dest, on grid h_dest, from layer-integrated data, uh_src, on grid h_src +subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells + real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells + real, intent(in) :: missing_value !< Value to assign in vanished cells + real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces + + ! Local variables + real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses + real :: uh_src_rem, duh ! Incremental amounts of stuff + integer :: k_src, k_dest ! Index of cell in src and dest columns + logical :: src_ran_out, src_exists + + uh_dest(:) = missing_value + + k_src = 0 + k_dest = 0 + h_dest_rem = 0. + h_src_rem = 0. + src_ran_out = .false. + src_exists = .false. + + do while(.true.) + if (h_src_rem==0. .and. k_src0.) duh = uh_src_rem + h_src_rem = 0. + uh_src_rem = 0. + h_dest_rem = max(0., h_dest_rem - dh) + elseif (h_src_rem>h_dest_rem) then + ! Only part of the source cell can be used up + dh = h_dest_rem + duh = (dh / h_src_rem) * uh_src_rem + h_src_rem = max(0., h_src_rem - dh) + uh_src_rem = uh_src_rem - duh + h_dest_rem = 0. + else ! h_src_rem==h_dest_rem + ! The source cell exactly fits the destination cell + duh = uh_src_rem + h_src_rem = 0. + uh_src_rem = 0. + h_dest_rem = 0. + endif + uh_dest(k_dest) = uh_dest(k_dest) + duh + if (k_dest==ndest .and. (k_src==nsrc .or. h_dest_rem==0.)) exit + enddo + + if (.not. src_exists) uh_dest(1:ndest) = missing_value + +end subroutine reintegrate_column + !> Returns the average value of a reconstruction within a single source cell, i0, !! between the non-dimensional positions xa and xb (xa<=xb) with dimensional !! separation dh. @@ -1209,12 +1360,13 @@ logical function remapping_unit_tests(verbose) real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs integer :: answer_date ! The vintage of the expressions to test integer :: i + real, parameter :: mv=-9.999999999E9 ! Value to use for vanished layers in interpolation tests. real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be ! added to thicknesses in a denominator without ! changing the numerical result, except where ! a division by zero would otherwise occur. real :: err, h_neglect, h_neglect_edge - logical :: thisTest, v + logical :: thisTest, v, fail v = verbose answer_date = 20190101 ! 20181231 @@ -1429,6 +1581,108 @@ logical function remapping_unit_tests(verbose) if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + write(stdout,*) '=== MOM_remapping: interpolation and reintegration unit tests ===' + if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' + + fail = test_interp(v,mv,'Identity: 3 layer', & + 3, (/1.,2.,3./), (/1.,2.,3.,4./), & + 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'A: 3 layer to 2', & + 3, (/1.,1.,1./), (/1.,2.,3.,4./), & + 2, (/1.5,1.5/), (/1.,2.5,4./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'B: 2 layer to 3', & + 2, (/1.5,1.5/), (/1.,4.,7./), & + 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'C: 3 layer (vanished middle) to 2', & + 3, (/1.,0.,2./), (/1.,2.,2.,3./), & + 2, (/1.,2./), (/1.,2.,3./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'D: 3 layer (deep) to 3', & + 3, (/1.,2.,3./), (/1.,2.,4.,7./), & + 2, (/2.,2./), (/1.,3.,5./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'E: 3 layer to 3 (deep)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'F: 3 layer to 4 with vanished top/botton', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,5.,0./), (/mv,1.,3.,8.,mv/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,4.,0./), (/mv,1.,3.,7.,mv/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_interp(v,mv,'Fd: 3 layer to 4 with vanished top/botton (deep)', & + 3, (/1.,2.,4./), (/1.,2.,4.,8./), & + 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + if (verbose) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' + + fail = test_reintegrate(v,mv,'Identity: 3 layer', & + 3, (/1.,2.,3./), (/-5.,2.,1./), & + 3, (/1.,2.,3./), (/-5.,2.,1./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'A: 3 layer to 2', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,3./), (/-4.,2./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'A: 3 layer to 2 (deep)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,4./), (/-4.,2./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'A: 3 layer to 2 (shallow)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 2, (/3.,2./), (/-4.,1.5/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'B: 3 layer to 4 with vanished top/bottom', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'C: 3 layer to 4 with vanished top//middle/bottom', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'D: 3 layer to 3 (vanished)', & + 3, (/2.,2.,2./), (/-5.,2.,1./), & + 3, (/0.,0.,0./), (/0.,0.,0./) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3', & + 3, (/0.,0.,0./), (/-5.,2.,1./), & + 3, (/2.,2.,2./), (/mv, mv, mv/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & + 3, (/0.,0.,0./), (/-5.,2.,1./), & + 3, (/0.,0.,0./), (/mv, mv, mv/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & + 3, (/0.,0.,0./), (/0.,0.,0./), & + 3, (/0.,0.,0./), (/mv, mv, mv/) ) + remapping_unit_tests = remapping_unit_tests .or. fail + + if (.not. remapping_unit_tests) write(stdout,*) 'Pass' + end function remapping_unit_tests !> Returns true if any cell of u and u_true are not identical. Returns false otherwise. @@ -1462,6 +1716,82 @@ logical function test_answer(verbose, n, u, u_true, label, tol) end function test_answer +!> Returns true if a test of interpolate_column() produces the wrong answer +logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: missing_value !< Value to indicate missing data + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces [A] + ! Local variables + real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] + integer :: k + real :: error + + ! Interpolate from src to dest + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) + + test_interp = .false. + do k=1,ndest+1 + if (u_dest(k)/=u_true(k)) test_interp = .true. + enddo + if (verbose .or. test_interp) then + write(stdout,'(2a)') ' Test: ',msg + write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' + do k=1,ndest+1 + error = u_dest(k)-u_true(k) + if (error==0.) then + write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) + else + write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' + endif + enddo + endif +end function test_interp + +!> Returns true if a test of reintegrate_column() produces the wrong answer +logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: missing_value !< Value to indicate missing data [A H] + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff [A H] + ! Local variables + real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] + integer :: k + real :: error + + ! Interpolate from src to dest + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) + + test_reintegrate = .false. + do k=1,ndest + if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. + enddo + if (verbose .or. test_reintegrate) then + write(stdout,'(2a)') ' Test: ',msg + write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' + do k=1,ndest + error = uh_dest(k)-uh_true(k) + if (error==0.) then + write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) + else + write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' + endif + enddo + endif +end function test_reintegrate + !> Convenience function for printing grid to screen subroutine dumpGrid(n,h,x,u) integer, intent(in) :: n !< Number of cells diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 08f8dea634..10782e8890 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -8,7 +8,6 @@ module MOM_unit_tests use MOM_string_functions, only : string_functions_unit_tests use MOM_remapping, only : remapping_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests -use MOM_diag_vkernels, only : diag_vkernels_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 @@ -35,8 +34,6 @@ subroutine unit_tests(verbosity) "MOM_unit_tests: remapping_unit_tests FAILED") if (neutral_diffusion_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: neutralDiffusionUnitTests FAILED") - if (diag_vkernels_unit_tests(verbose)) call MOM_error(FATAL, & - "MOM_unit_tests: diag_vkernels_unit_tests FAILED") if (random_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: random_unit_tests FAILED") if (near_boundary_unit_tests(verbose)) call MOM_error(FATAL, & diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 1bdf13b41f..eae498f5cb 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -62,15 +62,14 @@ module MOM_diag_remap use MOM_error_handler, only : MOM_error, FATAL, assert, WARNING use MOM_debugging, only : check_column_integrals use MOM_diag_manager_infra,only : MOM_diag_axis_init -use MOM_diag_vkernels, only : interpolate_column, reintegrate_column use MOM_file_parser, only : get_param, log_param, param_file_type use MOM_string_functions, only : lowercase, extractWord use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : EOS_type -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : remapping_core_h +use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h +use MOM_remapping, only : interpolate_column, reintegrate_column use MOM_regridding, only : regridding_CS, initialize_regridding use MOM_regridding, only : end_regridding use MOM_regridding, only : set_regrid_params, get_regrid_size diff --git a/src/framework/MOM_diag_vkernels.F90 b/src/framework/MOM_diag_vkernels.F90 deleted file mode 100644 index 886f6dcd4d..0000000000 --- a/src/framework/MOM_diag_vkernels.F90 +++ /dev/null @@ -1,357 +0,0 @@ -!> Provides kernels for single-column interpolation, re-integration (re-mapping of integrated quantities) -!! and intensive-variable remapping in the vertical -module MOM_diag_vkernels - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_io, only : stdout, stderr - -implicit none ; private - -public diag_vkernels_unit_tests -public interpolate_column -public reintegrate_column - -contains - -!> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest -subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, intent(in) :: missing_value !< Value to assign in vanished cells - real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces - ! Local variables - real :: x_dest ! Relative position of target interface - real :: dh ! Source cell thickness - real :: u1, u2 ! Values to interpolate between - real :: weight_a, weight_b ! Weights for interpolation - integer :: k_src, k_dest ! Index of cell in src and dest columns - logical :: still_vanished ! Used for figuring out what to mask as missing - - ! Initial values for the loop - still_vanished = .true. - - ! The following forces the "do while" loop to do one cycle that will set u1, u2, dh. - k_src = 0 - dh = 0. - x_dest = 0. - - do k_dest=1, ndest+1 - do while (dh<=x_dest .and. k_src0.) then - weight_a = max(0., ( dh - x_dest ) / dh) ! Weight of u1 - weight_b = min(1., x_dest / dh) ! Weight of u2 - u_dest(k_dest) = weight_a * u1 + weight_b * u2 ! Linear interpolation between u1 and u2 - else - u_dest(k_dest) = 0.5 * ( u1 + u2 ) ! For a vanished layer we need to do something reasonable... - endif - - ! Mask vanished layers at the surface which would be under an ice-shelf. - ! TODO: Need to figure out what to do for an isopycnal coordinate diagnostic that could - ! also have vanished layers at the surface. - if (k_dest<=ndest) then - x_dest = x_dest + h_dest(k_dest) ! Position of interface k_dest+1 - if (still_vanished .and. h_dest(k_dest)==0.) then - ! When the layer k_dest is vanished and all layers above are also vanished, the k_dest - ! interface value should be missing. - u_dest(k_dest) = missing_value - else - still_vanished = .false. - endif - endif - - enddo - - ! Mask vanished layers on topography - still_vanished = .true. - do k_dest=ndest, 1, -1 - if (still_vanished .and. h_dest(k_dest)==0.) then - ! When the layer k_dest is vanished and all layers below are also vanished, the k_dest+1 - ! interface value should be missing. - u_dest(k_dest+1) = missing_value - else - exit - endif - enddo - -end subroutine interpolate_column - -!> Conservatively calculate integrated data, uh_dest, on grid h_dest, from layer-integrated data, uh_src, on grid h_src -subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, intent(in) :: missing_value !< Value to assign in vanished cells - real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces - - ! Local variables - real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses - real :: uh_src_rem, duh ! Incremental amounts of stuff - integer :: k_src, k_dest ! Index of cell in src and dest columns - logical :: src_ran_out, src_exists - - uh_dest(:) = missing_value - - k_src = 0 - k_dest = 0 - h_dest_rem = 0. - h_src_rem = 0. - src_ran_out = .false. - src_exists = .false. - - do while(.true.) - if (h_src_rem==0. .and. k_src0.) duh = uh_src_rem - h_src_rem = 0. - uh_src_rem = 0. - h_dest_rem = max(0., h_dest_rem - dh) - elseif (h_src_rem>h_dest_rem) then - ! Only part of the source cell can be used up - dh = h_dest_rem - duh = (dh / h_src_rem) * uh_src_rem - h_src_rem = max(0., h_src_rem - dh) - uh_src_rem = uh_src_rem - duh - h_dest_rem = 0. - else ! h_src_rem==h_dest_rem - ! The source cell exactly fits the destination cell - duh = uh_src_rem - h_src_rem = 0. - uh_src_rem = 0. - h_dest_rem = 0. - endif - uh_dest(k_dest) = uh_dest(k_dest) + duh - if (k_dest==ndest .and. (k_src==nsrc .or. h_dest_rem==0.)) exit - enddo - - if (.not. src_exists) uh_dest(1:ndest) = missing_value - -end subroutine reintegrate_column - -!> Returns true if any unit tests for module MOM_diag_vkernels fail -logical function diag_vkernels_unit_tests(verbose) - logical, intent(in) :: verbose !< If true, write results to stdout - ! Local variables - real, parameter :: mv=-9.999999999E9 ! Value to use for vanished layers - logical :: fail, v - - v = verbose - - write(stdout,*) '==== MOM_diag_kernels: diag_vkernels_unit_tests ==========' - if (v) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' - - fail = test_interp(v,mv,'Identity: 3 layer', & - 3, (/1.,2.,3./), (/1.,2.,3.,4./), & - 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) - diag_vkernels_unit_tests = fail - - fail = test_interp(v,mv,'A: 3 layer to 2', & - 3, (/1.,1.,1./), (/1.,2.,3.,4./), & - 2, (/1.5,1.5/), (/1.,2.5,4./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'B: 2 layer to 3', & - 2, (/1.5,1.5/), (/1.,4.,7./), & - 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'C: 3 layer (vanished middle) to 2', & - 3, (/1.,0.,2./), (/1.,2.,2.,3./), & - 2, (/1.,2./), (/1.,2.,3./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'D: 3 layer (deep) to 3', & - 3, (/1.,2.,3./), (/1.,2.,4.,7./), & - 2, (/2.,2./), (/1.,3.,5./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'E: 3 layer to 3 (deep)', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'F: 3 layer to 4 with vanished top/botton', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,5.,0./), (/mv,1.,3.,8.,mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'Fs: 3 layer to 4 with vanished top/botton (shallow)', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,4.,0./), (/mv,1.,3.,7.,mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_interp(v,mv,'Fd: 3 layer to 4 with vanished top/botton (deep)', & - 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - if (v) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' - - fail = test_reintegrate(v,mv,'Identity: 3 layer', & - 3, (/1.,2.,3./), (/-5.,2.,1./), & - 3, (/1.,2.,3./), (/-5.,2.,1./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'A: 3 layer to 2', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 2, (/3.,3./), (/-4.,2./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'A: 3 layer to 2 (deep)', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 2, (/3.,4./), (/-4.,2./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'A: 3 layer to 2 (shallow)', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 2, (/3.,2./), (/-4.,1.5/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'B: 3 layer to 4 with vanished top/bottom', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'C: 3 layer to 4 with vanished top//middle/bottom', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer to 3 (vanished)', & - 3, (/2.,2.,2./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/0.,0.,0./) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3', & - 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/2.,2.,2./), (/mv, mv, mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & - 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/mv, mv, mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & - 3, (/0.,0.,0./), (/0.,0.,0./), & - 3, (/0.,0.,0./), (/mv, mv, mv/) ) - diag_vkernels_unit_tests = diag_vkernels_unit_tests .or. fail - - if (.not. fail) write(stdout,*) 'Pass' - -end function diag_vkernels_unit_tests - -!> Returns true if a test of interpolate_column() produces the wrong answer -logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) - logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: missing_value !< Value to indicate missing data - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, dimension(ndest+1), intent(in) :: u_true !< Correct value at destination cell interfaces - ! Local variables - real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces - integer :: k - real :: error - - ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) - - test_interp = .false. - do k=1,ndest+1 - if (u_dest(k)/=u_true(k)) test_interp = .true. - enddo - if (verbose .or. test_interp) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','u_result','u_true','error' - do k=1,ndest+1 - error = u_dest(k)-u_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,u_dest(k),u_true(k),u_dest(k)-u_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,u_dest(k),u_true(k),u_dest(k)-u_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_interp - -!> Returns true if a test of reintegrate_column() produces the wrong answer -logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) - logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: missing_value !< Value to indicate missing data - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc), intent(in) :: uh_src !< Values of source cell stuff - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, dimension(ndest), intent(in) :: uh_true !< Correct value of destination cell stuff - ! Local variables - real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells - integer :: k - real :: error - - ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) - - test_reintegrate = .false. - do k=1,ndest - if (uh_dest(k)/=uh_true(k)) test_reintegrate = .true. - enddo - if (verbose .or. test_reintegrate) then - write(stdout,'(2a)') ' Test: ',msg - write(stdout,'(a3,3(a24))') 'k','uh_result','uh_true','error' - do k=1,ndest - error = uh_dest(k)-uh_true(k) - if (error==0.) then - write(stdout,'(i3,3(1pe24.16))') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k) - else - write(stdout,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - write(stderr,'(i3,3(1pe24.16),1x,a)') k,uh_dest(k),uh_true(k),uh_dest(k)-uh_true(k),'<--- WRONG!' - endif - enddo - endif -end function test_reintegrate - -end module MOM_diag_vkernels diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index e7e47370e1..1bd5500023 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -11,11 +11,10 @@ module MOM_lateral_boundary_diffusion use MOM_domains, only : pass_var use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : remapping_CS, initialize_remapping, reintegrate_column use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme use MOM_spatial_means, only : global_mass_integral diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 0a56925516..ab37b87f17 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -7,13 +7,13 @@ module MOM_offline_aux use MOM_debugging, only : check_column_integrals use MOM_domains, only : pass_var, pass_vector, To_All use MOM_diag_mediator, only : post_data -use MOM_diag_vkernels, only : reintegrate_column use MOM_error_handler, only : callTree_enter, callTree_leave, MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_opacity, only : optics_type +use MOM_remapping, only : reintegrate_column use MOM_time_manager, only : time_type, operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : vertvisc_type From 1faf2a8a4a44a7347286885bca24a5db9a724ebc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 23 Oct 2022 13:21:51 -0400 Subject: [PATCH 023/629] +Remove missing_value arg to interpolate_column Remove missing_value arguments to interpolate_column and reintegrate_column, instead using 0 for the values in vanished cells. This change helps to address github.com/mom-ocean/MOM6/issues/769. Also added comments schematically describing some of the argument units. Because 0 was already being used for the missing value (except in unit tests), all solutions are bitwise identical. --- src/ALE/MOM_ALE.F90 | 6 +- src/ALE/MOM_remapping.F90 | 142 +++++++++--------- src/framework/MOM_diag_remap.F90 | 12 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 2 +- src/tracer/MOM_offline_aux.F90 | 1 - 5 files changed, 79 insertions(+), 84 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 5fd84c73c9..ec71e15bbd 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -536,7 +536,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) if (G%mask2dCu(i,j)>0.) then h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) h_dest(:) = 0.5 * (h_new(i,j,:) + h_new(i+1,j,:)) - call reintegrate_column(nk, h_src, uhtr(I,j,:), nk, h_dest, 0., temp_vec) + call reintegrate_column(nk, h_src, uhtr(I,j,:), nk, h_dest, temp_vec) uhtr(I,j,:) = temp_vec endif enddo ; enddo @@ -544,7 +544,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) if (G%mask2dCv(i,j)>0.) then h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) h_dest(:) = 0.5 * (h_new(i,j,:) + h_new(i,j+1,:)) - call reintegrate_column(nk, h_src, vhtr(I,j,:), nk, h_dest, 0., temp_vec) + call reintegrate_column(nk, h_src, vhtr(I,j,:), nk, h_dest, temp_vec) vhtr(I,j,:) = temp_vec endif enddo ; enddo @@ -554,7 +554,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) if (check_column_integrals(nk, h_src, nk, h_dest)) then call MOM_error(FATAL, "ALE_offline_inputs: Kd interpolation columns do not match") endif - call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), 0., Kd(i,j,:)) + call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), Kd(i,j,:)) endif enddo ; enddo diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 20d3930d69..ad8fe48fbf 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -920,19 +920,19 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth end subroutine remap_via_sub_cells !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest -subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, intent(in) :: missing_value !< Value to assign in vanished cells - real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces +subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces [A] + ! Local variables - real :: x_dest ! Relative position of target interface - real :: dh ! Source cell thickness - real :: u1, u2 ! Values to interpolate between - real :: weight_a, weight_b ! Weights for interpolation + real :: x_dest ! Relative position of target interface [H] + real :: dh ! Source cell thickness [H] + real :: u1, u2 ! Values to interpolate between [A] + real :: weight_a, weight_b ! Weights for interpolation [nondim] integer :: k_src, k_dest ! Index of cell in src and dest columns logical :: still_vanished ! Used for figuring out what to mask as missing @@ -972,7 +972,7 @@ subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, if (still_vanished .and. h_dest(k_dest)==0.) then ! When the layer k_dest is vanished and all layers above are also vanished, the k_dest ! interface value should be missing. - u_dest(k_dest) = missing_value + u_dest(k_dest) = 0.0 else still_vanished = .false. endif @@ -986,7 +986,7 @@ subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, if (still_vanished .and. h_dest(k_dest)==0.) then ! When the layer k_dest is vanished and all layers below are also vanished, the k_dest+1 ! interface value should be missing. - u_dest(k_dest+1) = missing_value + u_dest(k_dest+1) = 0.0 else exit endif @@ -995,29 +995,27 @@ subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, end subroutine interpolate_column !> Conservatively calculate integrated data, uh_dest, on grid h_dest, from layer-integrated data, uh_src, on grid h_src -subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) - integer, intent(in) :: nsrc !< Number of source cells - real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells - real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces - integer, intent(in) :: ndest !< Number of destination cells - real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells - real, intent(in) :: missing_value !< Value to assign in vanished cells - real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces +subroutine reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) + integer, intent(in) :: nsrc !< Number of source cells + real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] + real, dimension(nsrc), intent(in) :: uh_src !< Values at source cell interfaces [A H] + integer, intent(in) :: ndest !< Number of destination cells + real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] + real, dimension(ndest), intent(inout) :: uh_dest !< Interpolated value at destination cell interfaces [A H] ! Local variables - real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses - real :: uh_src_rem, duh ! Incremental amounts of stuff + real :: h_src_rem, h_dest_rem, dh ! Incremental thicknesses [H] + real :: uh_src_rem, duh ! Incremental amounts of stuff [A H] integer :: k_src, k_dest ! Index of cell in src and dest columns - logical :: src_ran_out, src_exists + logical :: src_ran_out - uh_dest(:) = missing_value + uh_dest(:) = 0.0 k_src = 0 k_dest = 0 h_dest_rem = 0. h_src_rem = 0. src_ran_out = .false. - src_exists = .false. do while(.true.) if (h_src_rem==0. .and. k_src Returns the average value of a reconstruction within a single source cell, i0, @@ -1349,23 +1344,26 @@ logical function remapping_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1), u0(n0) - real :: h1(n1), x1(n1+1), u1(n1), dx1(n1+1) - real :: h2(n2), x2(n2+1), u2(n2) - data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom - data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 - data h1 /3*1./ ! 3 uniform layers with total depth of 3 - data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 + real :: h0(n0), x0(n0+1), u0(n0) ! Thicknesses [H], interface heights [H] and values [A] for profile 0 + real :: h1(n1), x1(n1+1), u1(n1) ! Thicknesses [H], interface heights [H] and values [A] for profile 1 + real :: dx1(n1+1) ! Interface height changes for profile 1 [H] + real :: h2(n2), x2(n2+1), u2(n2) ! Thicknesses [H], interface heights [H] and values [A] for profile 2 + data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom [A] + data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 [H] + data h1 /3*1./ ! 3 uniform layers with total depth of 3 [H] + data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 [H] type(remapping_CS) :: CS !< Remapping control structure - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs + real, allocatable, dimension(:,:) :: ppoly0_E ! Edge values of polynomials [A] + real, allocatable, dimension(:,:) :: ppoly0_S ! Edge slopes of polynomials [A H-1] + real, allocatable, dimension(:,:) :: ppoly0_coefs ! Coefficients of polynomials [A] integer :: answer_date ! The vintage of the expressions to test integer :: i - real, parameter :: mv=-9.999999999E9 ! Value to use for vanished layers in interpolation tests. real, parameter :: hNeglect_dflt = 1.0e-30 ! A thickness [H ~> m or kg m-2] that can be ! added to thicknesses in a denominator without ! changing the numerical result, except where ! a division by zero would otherwise occur. - real :: err, h_neglect, h_neglect_edge + real :: err ! Errors in the remapped thicknesses [H] or values [A] + real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H] logical :: thisTest, v, fail v = verbose @@ -1584,101 +1582,101 @@ logical function remapping_unit_tests(verbose) write(stdout,*) '=== MOM_remapping: interpolation and reintegration unit tests ===' if (verbose) write(stdout,*) '- - - - - - - - - - interpolation tests - - - - - - - - -' - fail = test_interp(v,mv,'Identity: 3 layer', & + fail = test_interp(verbose, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/1.,2.,3.,4./), & 3, (/1.,2.,3./), (/1.,2.,3.,4./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'A: 3 layer to 2', & + fail = test_interp(verbose, 'A: 3 layer to 2', & 3, (/1.,1.,1./), (/1.,2.,3.,4./), & 2, (/1.5,1.5/), (/1.,2.5,4./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'B: 2 layer to 3', & + fail = test_interp(verbose, 'B: 2 layer to 3', & 2, (/1.5,1.5/), (/1.,4.,7./), & 3, (/1.,1.,1./), (/1.,3.,5.,7./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'C: 3 layer (vanished middle) to 2', & + fail = test_interp(verbose, 'C: 3 layer (vanished middle) to 2', & 3, (/1.,0.,2./), (/1.,2.,2.,3./), & 2, (/1.,2./), (/1.,2.,3./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'D: 3 layer (deep) to 3', & + fail = test_interp(verbose, 'D: 3 layer (deep) to 3', & 3, (/1.,2.,3./), (/1.,2.,4.,7./), & 2, (/2.,2./), (/1.,3.,5./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'E: 3 layer to 3 (deep)', & + fail = test_interp(verbose, 'E: 3 layer to 3 (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & 3, (/2.,3.,4./), (/1.,3.,6.,8./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'F: 3 layer to 4 with vanished top/botton', & + fail = test_interp(verbose, 'F: 3 layer to 4 with vanished top/botton', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,5.,0./), (/mv,1.,3.,8.,mv/) ) + 4, (/0.,2.,5.,0./), (/0.,1.,3.,8.,0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'Fs: 3 layer to 4 with vanished top/botton (shallow)', & + fail = test_interp(verbose, 'Fs: 3 layer to 4 with vanished top/botton (shallow)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,4.,0./), (/mv,1.,3.,7.,mv/) ) + 4, (/0.,2.,4.,0./), (/0.,1.,3.,7.,0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_interp(v,mv,'Fd: 3 layer to 4 with vanished top/botton (deep)', & + fail = test_interp(verbose, 'Fd: 3 layer to 4 with vanished top/botton (deep)', & 3, (/1.,2.,4./), (/1.,2.,4.,8./), & - 4, (/0.,2.,6.,0./), (/mv,1.,3.,8.,mv/) ) + 4, (/0.,2.,6.,0./), (/0.,1.,3.,8.,0./) ) remapping_unit_tests = remapping_unit_tests .or. fail if (verbose) write(stdout,*) '- - - - - - - - - - reintegration tests - - - - - - - - -' - fail = test_reintegrate(v,mv,'Identity: 3 layer', & + fail = test_reintegrate(verbose, 'Identity: 3 layer', & 3, (/1.,2.,3./), (/-5.,2.,1./), & 3, (/1.,2.,3./), (/-5.,2.,1./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'A: 3 layer to 2', & + fail = test_reintegrate(verbose, 'A: 3 layer to 2', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,3./), (/-4.,2./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'A: 3 layer to 2 (deep)', & + fail = test_reintegrate(verbose, 'A: 3 layer to 2 (deep)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,4./), (/-4.,2./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'A: 3 layer to 2 (shallow)', & + fail = test_reintegrate(verbose, 'A: 3 layer to 2 (shallow)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 2, (/3.,2./), (/-4.,1.5/) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'B: 3 layer to 4 with vanished top/bottom', & + fail = test_reintegrate(verbose, 'B: 3 layer to 4 with vanished top/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 4, (/0.,3.,3.,0./), (/0.,-4.,2.,0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'C: 3 layer to 4 with vanished top//middle/bottom', & + fail = test_reintegrate(verbose, 'C: 3 layer to 4 with vanished top//middle/bottom', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 5, (/0.,3.,0.,3.,0./), (/0.,-4.,0.,2.,0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'D: 3 layer to 3 (vanished)', & + fail = test_reintegrate(verbose, 'D: 3 layer to 3 (vanished)', & 3, (/2.,2.,2./), (/-5.,2.,1./), & 3, (/0.,0.,0./), (/0.,0.,0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3', & + fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3', & 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/2.,2.,2./), (/mv, mv, mv/) ) + 3, (/2.,2.,2./), (/0., 0., 0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & + fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/-5.,2.,1./), & - 3, (/0.,0.,0./), (/mv, mv, mv/) ) + 3, (/0.,0.,0./), (/0., 0., 0./) ) remapping_unit_tests = remapping_unit_tests .or. fail - fail = test_reintegrate(v,mv,'D: 3 layer (vanished) to 3 (vanished)', & + fail = test_reintegrate(verbose, 'D: 3 layer (vanished) to 3 (vanished)', & 3, (/0.,0.,0./), (/0.,0.,0./), & - 3, (/0.,0.,0./), (/mv, mv, mv/) ) + 3, (/0.,0.,0./), (/0., 0., 0./) ) remapping_unit_tests = remapping_unit_tests .or. fail if (.not. remapping_unit_tests) write(stdout,*) 'Pass' @@ -1717,11 +1715,10 @@ logical function test_answer(verbose, n, u, u_true, label, tol) end function test_answer !> Returns true if a test of interpolate_column() produces the wrong answer -logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) +logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_true) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: missing_value !< Value to indicate missing data - character(len=*), intent(in) :: msg !< Message to label test - integer, intent(in) :: nsrc !< Number of source cells + character(len=*), intent(in) :: msg !< Message to label test + integer, intent(in) :: nsrc !< Number of source cells real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] integer, intent(in) :: ndest !< Number of destination cells @@ -1733,7 +1730,7 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd real :: error ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, missing_value, u_dest) + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest) test_interp = .false. do k=1,ndest+1 @@ -1755,9 +1752,8 @@ logical function test_interp(verbose, missing_value, msg, nsrc, h_src, u_src, nd end function test_interp !> Returns true if a test of reintegrate_column() produces the wrong answer -logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) +logical function test_reintegrate(verbose, msg, nsrc, h_src, uh_src, ndest, h_dest, uh_true) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: missing_value !< Value to indicate missing data [A H] character(len=*), intent(in) :: msg !< Message to label test integer, intent(in) :: nsrc !< Number of source cells real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] @@ -1771,7 +1767,7 @@ logical function test_reintegrate(verbose, missing_value, msg, nsrc, h_src, uh_s real :: error ! Interpolate from src to dest - call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, missing_value, uh_dest) + call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) test_reintegrate = .false. do k=1,ndest diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index eae498f5cb..05bd8aeed0 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -527,7 +527,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) h_dest(:) = 0.5 * (h_target(i_lo,j,:) + h_target(i_hi,j,:)) call reintegrate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, 0., reintegrated_field(I1,j,:)) + nz_dest, h_dest, reintegrated_field(I1,j,:)) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then @@ -542,7 +542,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) h_dest(:) = 0.5 * (h_target(i,j_lo,:) + h_target(i,j_hi,:)) call reintegrate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, 0., reintegrated_field(i,J1,:)) + nz_dest, h_dest, reintegrated_field(i,J1,:)) enddo enddo elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -555,7 +555,7 @@ subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered h_src(:) = h(i,j,:) h_dest(:) = h_target(i,j,:) call reintegrate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, 0., reintegrated_field(i,j,:)) + nz_dest, h_dest, reintegrated_field(i,j,:)) enddo enddo else @@ -608,7 +608,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) call interpolate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, 0., interpolated_field(I1,j,:)) + nz_dest, h_dest, interpolated_field(I1,j,:)) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then @@ -623,7 +623,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) call interpolate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, 0., interpolated_field(i,J1,:)) + nz_dest, h_dest, interpolated_field(i,J1,:)) enddo enddo elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -636,7 +636,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta h_src(:) = h(i,j,:) h_dest(:) = remap_cs%h(i,j,:) call interpolate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, 0., interpolated_field(i,j,:)) + nz_dest, h_dest, interpolated_field(i,j,:)) enddo enddo else diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 index 1bd5500023..f26395c119 100644 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ b/src/tracer/MOM_lateral_boundary_diffusion.F90 @@ -697,7 +697,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ enddo ! remap flux to h_vel (native grid) - call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), F_layer(:)) ! used to avoid fluxes below hbl if (CS%linear) then diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index ab37b87f17..d42355f245 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -13,7 +13,6 @@ module MOM_offline_aux use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, MOM_read_vector, CENTER use MOM_opacity, only : optics_type -use MOM_remapping, only : reintegrate_column use MOM_time_manager, only : time_type, operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : vertvisc_type From b52593282f0df4c97fd5fb6d73ca2dc24630230b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 23 Oct 2022 15:31:52 -0400 Subject: [PATCH 024/629] Add check_remapped_values Added the new subroutine check_remapped_values with the duplicative error checking code in remapping_core_h and remapping_core_w, both to reduce code volume and promote code coverage, and to make the substance of these two routines easier to follow. All answers are bitwise identical. --- src/ALE/MOM_remapping.F90 | 166 +++++++++++++++++--------------------- 1 file changed, 76 insertions(+), 90 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index ad8fe48fbf..fa79c50c3c 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -172,17 +172,12 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg !! cells in the source grid where this is true. ! Local variables - integer :: iMethod real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial [A] - real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] - real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] - real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] - real :: u1tot, u1err ! Integrated values on the target grid and round-off error in this sum [H A] - real :: u0min, u0max, u1min, u1max ! Extrema of values on the two grids [A] - real :: uh_err ! Difference in the total amounts on the two grids [H A] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] + real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] real :: hNeglect, hNeglect_edge ! Negligibly small cell widths in the same units as h0 [H] + integer :: iMethod ! An integer indicating the integration method used integer :: k hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect @@ -197,43 +192,8 @@ subroutine remapping_core_h(CS, n0, h0, u0, n1, h1, u1, h_neglect, h_neglect_edg call remap_via_sub_cells( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, h1, iMethod, & CS%force_bounds_in_subcell, u1, uh_err ) - if (CS%check_remapping) then - ! Check errors and bounds - call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - if (iMethod<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then - write(0,*) 'iMethod = ',iMethod - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min - if (u1minn0) then - write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) - enddo - call MOM_error( FATAL, 'MOM_remapping, remapping_core_h: '//& - 'Remapping result is inconsistent!' ) - endif - endif ! method<5 - endif + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_h") end subroutine remapping_core_h @@ -256,16 +216,11 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed ! Local variables real, dimension(n0,2) :: ppoly_r_E ! Edge value of polynomial [A] real, dimension(n0,2) :: ppoly_r_S ! Edge slope of polynomial [A H-1] - real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial [A] - real :: h0tot, h1tot ! The total thicknesses of the source and target grids [H] - real :: h0err, h1err ! Magnitude of round-off errors in h0tot and h1tot [H] - real :: u0tot, u1tot ! Column integrated values on the source and target grids [H A] - real :: u0err, u1err ! Magnitude of round-off errors in u0tot and u1tot [H A] - real :: u0min, u0max, u1min, u1max ! Extrema of values on the source and target grids [A] - real :: uh_err ! Estimate of bound on error in sum of u*h [A H] + real, dimension(n0,CS%degree+1) :: ppoly_r_coefs ! Coefficients of polynomial reconstructions [A] real, dimension(n1) :: h1 !< Cell widths on target grid [H] + real :: uh_err ! A bound on the error in the sum of u*h, as estimated by the remapping code [A H] real :: hNeglect, hNeglect_edge ! Negligibly small thicknesses [H] - integer :: iMethod + integer :: iMethod ! An integer indicating the integration method used integer :: k hNeglect = 1.0e-30 ; if (present(h_neglect)) hNeglect = h_neglect @@ -290,43 +245,8 @@ subroutine remapping_core_w( CS, n0, h0, u0, n1, dx, u1, h_neglect, h_neglect_ed ! call remapByDeltaZ( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, n1, dx, iMethod, u1, hNeglect ) ! call remapByProjection( n0, h0, u0, CS%ppoly_r, n1, h1, iMethod, u1, hNeglect ) - if (CS%check_remapping) then - ! Check errors and bounds - call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) - call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) - if (iMethod<5) then ! We except PQM until we've debugged it - if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then - write(0,*) 'iMethod = ',iMethod - write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err - if (abs(h1tot-h0tot)>h0err+h1err) & - write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' - write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err - if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & - write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' - write(0,*) 'U: u0min=',u0min,'u1min=',u1min - if (u1minn0) then - write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) - else - write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) - endif - enddo - write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' - do k = 1, n0 - write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) - enddo - call MOM_error( FATAL, 'MOM_remapping, remapping_core_w: '//& - 'Remapping result is inconsistent!' ) - endif - endif ! method<5 - endif + if (CS%check_remapping) call check_remapped_values(n0, h0, u0, ppoly_r_E, CS%degree, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, "remapping_core_w") end subroutine remapping_core_w @@ -1171,6 +1091,72 @@ real function average_value_ppoly( n0, u0, ppoly0_E, ppoly0_coefs, method, i0, x end function average_value_ppoly +!> This subroutine checks for sufficient consistence in the extrema and total amounts on the old +!! and new grids. +subroutine check_remapped_values(n0, h0, u0, ppoly_r_E, deg, ppoly_r_coefs, & + n1, h1, u1, iMethod, uh_err, caller) + integer, intent(in) :: n0 !< Number of cells on source grid + real, dimension(n0), intent(in) :: h0 !< Cell widths on source grid [H] + real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge values of polynomial fits [A] + integer, intent(in) :: deg !< Degree of the piecewise polynomial reconstrution + real, dimension(n0,deg+1), intent(in) :: ppoly_r_coefs !< Coefficients of the piecewise + !! polynomial reconstructions [A] + integer, intent(in) :: n1 !< Number of cells on target grid + real, dimension(n1), intent(in) :: h1 !< Cell widths on target grid [H] + real, dimension(n1), intent(in) :: u1 !< Cell averages on target grid [A] + integer, intent(in) :: iMethod !< An integer indicating the integration method used + real, intent(in) :: uh_err !< A bound on the error in the sum of u*h as + !! estimated by the remapping code [H A] + character(len=*), intent(in) :: caller !< The name of the calling routine. + + ! Local variables + real :: h0tot, h0err ! Sum of source cell widths and round-off error in this sum [H] + real :: h1tot, h1err ! Sum of target cell widths and round-off error in this sum [H] + real :: u0tot, u0err ! Integrated values on the source grid and round-off error in this sum [H A] + real :: u1tot, u1err ! Integrated values on the target grid and round-off error in this sum [H A] + real :: u0min, u0max, u1min, u1max ! Extrema of values on the two grids [A] + integer :: k + + ! Check errors and bounds + call measure_input_bounds( n0, h0, u0, ppoly_r_E, h0tot, h0err, u0tot, u0err, u0min, u0max ) + call measure_output_bounds( n1, h1, u1, h1tot, h1err, u1tot, u1err, u1min, u1max ) + + if (iMethod<5) return ! We except PQM until we've debugged it + + if ( (abs(u1tot-u0tot)>(u0err+u1err)+uh_err .and. abs(h1tot-h0tot)u0max) ) then + write(0,*) 'iMethod = ',iMethod + write(0,*) 'H: h0tot=',h0tot,'h1tot=',h1tot,'dh=',h1tot-h0tot,'h0err=',h0err,'h1err=',h1err + if (abs(h1tot-h0tot)>h0err+h1err) & + write(0,*) 'H non-conservation difference=',h1tot-h0tot,'allowed err=',h0err+h1err,' <-----!' + write(0,*) 'UH: u0tot=',u0tot,'u1tot=',u1tot,'duh=',u1tot-u0tot,'u0err=',u0err,'u1err=',u1err,'uh_err=',uh_err + if (abs(u1tot-u0tot)>(u0err+u1err)+uh_err) & + write(0,*) 'U non-conservation difference=',u1tot-u0tot,'allowed err=',u0err+u1err+uh_err,' <-----!' + write(0,*) 'U: u0min=',u0min,'u1min=',u1min + if (u1minn0) then + write(0,'(i3,96x,1p2e24.16)') k,h1(k),u1(k) + else + write(0,'(i3,1p4e24.16)') k,h0(k),ppoly_r_E(k,1),u0(k),ppoly_r_E(k,2) + endif + enddo + write(0,'(a3,2a24)') 'k','u0','Polynomial coefficients' + do k = 1, n0 + write(0,'(i3,1p6e24.16)') k,u0(k),ppoly_r_coefs(k,:) + enddo + call MOM_error( FATAL, 'MOM_remapping, '//trim(caller)//': '//& + 'Remapping result is inconsistent!' ) + endif + +end subroutine check_remapped_values + !> Measure totals and bounds on source grid subroutine measure_input_bounds( n0, h0, u0, edge_values, h0tot, h0err, u0tot, u0err, u0min, u0max ) integer, intent(in) :: n0 !< Number of cells on source grid From bc01d95022782562c3cf5857e5771dd332e40d58 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 31 Aug 2022 16:59:04 -0400 Subject: [PATCH 025/629] gitlab-ci: Adds (command-line) tool to simplify .gitlab-ci.yml - Adds `.gitlab/pipeline-ci-tool.sh` to enact most of the stages of the gitlab CI pipeline - enables interactive/command-line reproduction of the pipeline - `.gitlab/pipeline-ci-tool.sh` is documented in .gitlab/README.md with instructions on how to use at the command line and what each function is doing - All commands formerly in .gitlab-ci.yml are now one-line invocations of `.gitlab/pipeline-ci-tool.sh` so .gitlab-ci.yml is now considerably smaller and easier to read with statements like `.gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu` or `.gitlab/pipeline-ci-tool.sh check-params gnu` - Previously, all results were compared again the stored regression answers. This meant that any error (e.g. layout) would show up as a fail of all types. We use the regression answers to check the repro-symmetric mode and then compare everything else to repro-symmetric or other results as appropriate. This allows us to distinguish between types of errors. The GH actions are doing it this way, and we originally did this in the first forms of the pipeline, but in the last re-factor I lazily switched to using the regression answers for everything. --- .gitlab-ci.yml | 243 +++++---------- .gitlab/README.md | 148 ++++++++++ .gitlab/mom6-ci-run-gnu-script.sh | 2 +- .gitlab/mom6-ci-run-intel-script.sh | 2 +- .gitlab/mom6-ci-run-pgi-script.sh | 2 +- .gitlab/pipeline-ci-tool.sh | 444 ++++++++++++++++++++++++++++ 6 files changed, 672 insertions(+), 169 deletions(-) create mode 100644 .gitlab/README.md create mode 100755 .gitlab/pipeline-ci-tool.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 496a578c91..6a622f55cc 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -6,124 +6,71 @@ stages: - cleanup # JOB_DIR points to a persistent working space used for most stages in this pipeline but -# it is unique to this pipeline. +# that is unique to this pipeline. # We use the "fetch" strategy to speed up the startup of stages variables: JOB_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" GIT_STRATEGY: fetch -# Start all stages in $JOB_DIR/.../MOM6-examples -# Exception: for "setup" stages MOM6-examples has not yet been cloned so the stage starts in $JOB_DIR +# Always eport value of $JOB_DIR before_script: - - echo -e "\e[0Ksection_start:`date +%s`:dir_stuff[collapsed=true]\r\e[0KChanging directories to $JOB_DIR" - echo Job directory set to $JOB_DIR - - mkdir -p $JOB_DIR - - cd $JOB_DIR - - test -d Gaea-stats-MOM6-examples/MOM6-examples && cd Gaea-stats-MOM6-examples/MOM6-examples - - pwd - - echo -e "\e[0Ksection_end:`date +%s`:dir_stuff\r\e[0K" # Test that merge with dev/gfdl works. -merge: +p:merge: stage: setup tags: - ncrc4 script: - - cd $CI_PROJECT_DIR - git pull --no-edit https://github.com/NOAA-GFDL/MOM6.git dev/gfdl # Setup the persistent JOB_DIR for all subsequent stages # -# This basically setups up a complete tree much as a user would work -# EXCEPT that src/MOM6 is cloned from a file system -clone: +# This basically setups up a complete tree much as a user would in their workflow +p:clone: stage: setup tags: - ncrc4 - before_script: - - echo -e "\e[0Ksection_start:`date +%s`:dir_stuff[collapsed=true]\r\e[0KChanging directories to $JOB_DIR" - - cd $CI_PROJECT_DIR - - git submodule init ; git submodule update - - echo Job directory set to $JOB_DIR - - mkdir -p $JOB_DIR - - cd $JOB_DIR - - test -d Gaea-stats-MOM6-examples && rm -rf Gaea-stats-MOM6-examples # In case we are re-running this stage - - pwd - - echo -e "\e[0Ksection_end:`date +%s`:dir_stuff\r\e[0K" - script: - - echo -e "\e[0Ksection_start:`date +%s`:clone[collapsed=true]\r\e[0KCloning repository tree" - - git clone https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git - - cd Gaea-stats-MOM6-examples - - git submodule update --init - - cd MOM6-examples - - git checkout dev/gfdl - - git submodule init - - git submodule set-url src/MOM6 $CI_PROJECT_DIR/.git # Easiest way to get MOM6 source to be tested - - git submodule update --recursive --jobs 8 - - (cd src/MOM6 ; git checkout $CI_COMMIT_SHA ; git submodule update --recursive --init) # Get commit to be tested - - make -f tools/MRS/Makefile.clone clone_gfdl -j # Extras and link to datasets - - bash tools/MRS/generate_manifest.sh . tools/MRS/excluded-expts.txt > manifest.mk - - mkdir -p results - - echo -e "\e[0Ksection_end:`date +%s`:clone\r\e[0K" + script: + - .gitlab/pipeline-ci-tool.sh create-job-dir +#.gitlab/pipeline-ci-tool.sh clean-job-dir # Make work spaces for running simultaneously in parallel jobs # # Each work space is a clone of MOM6-examples with symbolic links for the build and data directories # so they can share executables which can run simultaneously without interfering with each other -work-space:pgi: +s:work-space:pgi: stage: setup tags: - ncrc4 - needs: ["clone"] + needs: ["p:clone"] script: - - echo 911 - - echo -e "\e[0Ksection_start:`date +%s`:clone[collapsed=true]\r\e[0KCreating separate work space" - - git clone -s .git tmp-pgi-MOM6-examples - - cd tmp-pgi-MOM6-examples - - ln -s ../{build,results,.datasets} . - - cp ../manifest.mk . - - echo -e "\e[0Ksection_end:`date +%s`:clone\r\e[0K" + - .gitlab/pipeline-ci-tool.sh copy-test-space pgi -work-space:intel: +s:work-space:intel: stage: setup tags: - ncrc4 - needs: ["clone"] + needs: ["p:clone"] script: - - echo 911 - - echo -e "\e[0Ksection_start:`date +%s`:clone[collapsed=true]\r\e[0KCreating separate work space" - - git clone -s .git tmp-intel-MOM6-examples - - cd tmp-intel-MOM6-examples - - ln -s ../{build,results,.datasets} . - - cp ../manifest.mk . - - echo -e "\e[0Ksection_end:`date +%s`:clone\r\e[0K" + - .gitlab/pipeline-ci-tool.sh copy-test-space intel -work-space:gnu: +s:work-space:gnu: stage: setup tags: - ncrc4 - needs: ["clone"] + needs: ["p:clone"] script: - - echo -e "\e[0Ksection_start:`date +%s`:clone[collapsed=true]\r\e[0KCreating separate work space" - - git clone -s .git tmp-gnu-MOM6-examples - - cd tmp-gnu-MOM6-examples - - ln -s ../{build,results,.datasets} . - - cp ../manifest.mk . - - echo -e "\e[0Ksection_end:`date +%s`:clone\r\e[0K" + - .gitlab/pipeline-ci-tool.sh copy-test-space gnu -work-space:gnu-restarts: +s:work-space:gnu-restarts: stage: setup tags: - ncrc4 - needs: ["clone"] + needs: ["p:clone"] script: - - echo -e "\e[0Ksection_start:`date +%s`:clone[collapsed=true]\r\e[0KCreating separate work space" - - git clone -s .git tmp-gnu-restarts-MOM6-examples - - cd tmp-gnu-restarts-MOM6-examples - - ln -s ../{build,results,.datasets} . - - cp ../manifest.mk . - - echo -e "\e[0Ksection_end:`date +%s`:clone\r\e[0K" + - .gitlab/pipeline-ci-tool.sh copy-test-space gnu-rst # Compile executables # @@ -132,140 +79,97 @@ work-space:gnu-restarts: compile:pgi:repro: stage: builds - needs: ["clone"] + needs: ["p:clone"] tags: - ncrc4 script: - - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling target repro_pgi" - - time make -f tools/MRS/Makefile.build repro_pgi -s -j - - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_pgi compile:intel:repro: stage: builds - needs: ["clone"] + needs: ["p:clone"] tags: - ncrc4 script: - - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling target repro_intel" - - time make -f tools/MRS/Makefile.build repro_intel -s -j - - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_intel compile:gnu:repro: stage: builds - needs: ["clone"] + needs: ["p:clone"] tags: - ncrc4 script: - - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling target repro_gnu" - - time make -f tools/MRS/Makefile.build repro_gnu -s -j - - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - - echo -e "\e[0Ksection_start:`date +%s`:compile2[collapsed=true]\r\e[0KCompiling target static_gnu" - - time make -f tools/MRS/Makefile.build static_gnu -s -j - - echo -e "\e[0Ksection_end:`date +%s`:compile2\r\e[0K" + - .gitlab/pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu compile:gnu:debug: stage: builds - needs: ["clone"] + needs: ["p:clone"] tags: - ncrc4 script: - - echo -e "\e[0Ksection_start:`date +%s`:compile2[collapsed=true]\r\e[0KCompiling target debug_gnu" - - time make -f tools/MRS/Makefile.build debug_gnu -s -j - - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - .gitlab/pipeline-ci-tool.sh mrs-compile debug_gnu compile:gnu:ocean-only-nolibs: stage: builds - needs: ["clone"] + needs: ["p:clone"] tags: - ncrc4 script: - - echo 911 - - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling target gnu ocean-only no-libs" - - mkdir -p build-ocean-only-nolibs - - cd build-ocean-only-nolibs - - make -f ../tools/MRS/Makefile.build ./gnu/env BUILD=. -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-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF" path_names - - (source gnu/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) - - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - .gitlab/pipeline-ci-tool.sh nolibs-ocean-only-compile gnu compile:gnu:ice-ocean-nolibs: stage: builds - needs: ["clone"] + needs: ["p:clone"] tags: - ncrc4 script: - - echo 911 - - echo -e "\e[0Ksection_start:`date +%s`:compile[collapsed=true]\r\e[0KCompiling target gnu ice-ocean-SIS2 no-libs" - - mkdir -p build-ice-ocean-SIS2-nolibs - - cd build-ice-ocean-SIS2-nolibs - - make -f ../tools/MRS/Makefile.build ./gnu/env BUILD=. -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-gnu.mk -p MOM6 -c"-Duse_libMPI -Duse_netCDF -D_USE_LEGACY_LAND_ -Duse_AM3_physics" path_names - - (source gnu/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) - - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" + - .gitlab/pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu # Runs -# -# The main "run" stage uses the script .gitlab/mom6-ci-run-script.sh run:pgi: stage: run - needs: ["work-space:pgi","compile:pgi:repro"] + needs: ["s:work-space:pgi","compile:pgi:repro"] tags: - ncrc4 script: - - cd tmp-pgi-MOM6-examples - - cp ../src/MOM6/.gitlab/mom6-ci-run-pgi-script.sh . - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20:00 --account=gfdl_o --qos=debug --job-name=mom6_pgi_tests --output=log.$CI_JOB_ID --wait mom6-ci-run-pgi-script.sh && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - - test -f .CI-PGI-BATCH-SUCCESS || ( echo Batch job did not complete ; exit 911 ) - - git checkout . # reset working space so we can use it to compare against + - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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: ["work-space:intel","compile:intel:repro"] + needs: ["s:work-space:intel","compile:intel:repro"] tags: - ncrc4 script: - - echo 911 - - cd tmp-intel-MOM6-examples - - cp ../src/MOM6/.gitlab/mom6-ci-run-intel-script.sh . - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20:00 --account=gfdl_o --qos=debug --job-name=mom6_intel_tests --output=log.$CI_JOB_ID --wait mom6-ci-run-intel-script.sh && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - - test -f .CI-INTEL-BATCH-SUCCESS || ( echo Batch job did not complete ; exit 911 ) - - git checkout . # reset working space so we can use it to compare against + - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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: ["work-space:gnu","compile:gnu:repro","compile:gnu:debug"] + needs: ["s:work-space:gnu","compile:gnu:repro","compile:gnu:debug"] tags: - ncrc4 script: - - cd tmp-gnu-MOM6-examples - - cp ../src/MOM6/.gitlab/mom6-ci-run-gnu-script.sh . - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_tests --output=log.$CI_JOB_ID --wait mom6-ci-run-gnu-script.sh && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - - test -f .CI-GNU-BATCH-SUCCESS || ( echo Batch job did not complete ; exit 911 ) - - git checkout . # reset working space so we can use it to compare against + - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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: ["work-space:gnu","compile:gnu:repro"] + needs: ["s:work-space:gnu-restarts","compile:gnu:repro"] tags: - ncrc4 script: - - echo 911 - - cd tmp-gnu-restarts-MOM6-examples - - cp ../src/MOM6/.gitlab/mom6-ci-run-gnu-restarts-script.sh . - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20:00 --account=gfdl_o --qos=debug --job-name=mom6_gnu_restarts --output=log.$CI_JOB_ID --wait mom6-ci-run-gnu-restarts-script.sh && ( egrep -v 'pagefaults|HiWaterMark=' log.$CI_JOB_ID ; echo Job returned normally ) || ( cat log.$CI_JOB_ID ; echo Job failed ; exit 911 ) - - test -f .CI-GNU-RESTARTS-BATCH-SUCCESS || ( echo Batch job did not complete ; exit 911 ) - - git checkout . # reset working space so we can use it to compare against + - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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 ) -# These "run" stages replace the "before_script" and so start in the transient work-space provided by gitlab +# GH/autoconf tests (duplicates the GH actions tests) +# +# These stages replace the "before_script" and so start in the transient work-space provided by gitlab. # We work here to avoid collisions with parallel jobs -gnu.testing: - stage: run +actions:gnu: + stage: tests needs: [] tags: - ncrc4 @@ -281,10 +185,10 @@ gnu.testing: - make -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" 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 && make test || cat log.$CI_JOB_ID + - 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 && make test || ( cat log.$CI_JOB_ID ; exit 911 ) -intel.testing: - stage: run +actions:intel: + stage: tests needs: [] tags: - ncrc4 @@ -300,7 +204,7 @@ intel.testing: - make -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" 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 && make test || cat log.$CI_JOB_ID + - 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 && make test || ( cat log.$CI_JOB_ID ; exit 911 ) # Tests # @@ -313,7 +217,7 @@ t:pgi:symmetric: tags: - ncrc4 script: - - ( cd results/pgi_all_sym/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats pgi S t:pgi:non-symmetric: stage: tests @@ -321,7 +225,7 @@ t:pgi:non-symmetric: tags: - ncrc4 script: - - ( cd results/pgi_all_nonsym/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats pgi N t:pgi:layout: stage: tests @@ -329,7 +233,7 @@ t:pgi:layout: tags: - ncrc4 script: - - ( cd results/pgi_all_layout/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats pgi L t:pgi:params: stage: tests @@ -337,7 +241,7 @@ t:pgi:params: tags: - ncrc4 script: - - ( cd results/pgi_params/ ; md5sum `find * -type f` ) | md5sum -c + - .gitlab/pipeline-ci-tool.sh check-params pgi allow_failure: true t:intel:symmetric: @@ -346,7 +250,7 @@ t:intel:symmetric: tags: - ncrc4 script: - - ( cd results/intel_all_sym/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats intel S t:intel:non-symmetric: stage: tests @@ -354,7 +258,7 @@ t:intel:non-symmetric: tags: - ncrc4 script: - - ( cd results/intel_all_nonsym/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats intel N t:intel:layout: stage: tests @@ -362,7 +266,7 @@ t:intel:layout: tags: - ncrc4 script: - - ( cd results/intel_all_layout/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats intel L t:intel:params: stage: tests @@ -370,7 +274,7 @@ t:intel:params: tags: - ncrc4 script: - - ( cd results/intel_params/ ; md5sum `find * -type f` ) | md5sum -c + - .gitlab/pipeline-ci-tool.sh check-params intel allow_failure: true t:gnu:symmetric: @@ -379,7 +283,7 @@ t:gnu:symmetric: tags: - ncrc4 script: - - ( cd results/gnu_all_sym/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats gnu S t:gnu:non-symmetric: stage: tests @@ -387,7 +291,7 @@ t:gnu:non-symmetric: tags: - ncrc4 script: - - ( cd results/gnu_all_nonsym/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats gnu N t:gnu:layout: stage: tests @@ -395,7 +299,7 @@ t:gnu:layout: tags: - ncrc4 script: - - ( cd results/gnu_all_layout/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats gnu L t:gnu:static: stage: tests @@ -403,7 +307,7 @@ t:gnu:static: tags: - ncrc4 script: - - ( cd results/gnu_all_static/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats gnu T t:gnu:symmetric-debug: stage: tests @@ -411,7 +315,7 @@ t:gnu:symmetric-debug: tags: - ncrc4 script: - - ( cd results/gnu_ocean_only_debug/ ; md5sum `find * -type f` ) | ( cd ../regressions/ ; md5sum -c ) + - .gitlab/pipeline-ci-tool.sh check-stats gnu D t:gnu:restart: stage: tests @@ -419,9 +323,7 @@ t:gnu:restart: tags: - ncrc4 script: - - cd tmp-gnu-restarts-MOM6-examples - - ( cd ../results/gnu_restarts ; tar cf - * ) | tar xf - # NOTE this unpacks in tmp-gnu-restarts-MOM6-examples (not a new directory) - - make -f tools/MRS/Makefile.restart restart_gnu_ocean_only restart_gnu_ice_ocean_SIS2 -s -k + - .gitlab/pipeline-ci-tool.sh check-stats gnu R t:gnu:params: stage: tests @@ -429,7 +331,16 @@ t:gnu:params: tags: - ncrc4 script: - - ( cd results/gnu_params/ ; md5sum `find * -type f` ) | md5sum -c + - .gitlab/pipeline-ci-tool.sh check-params gnu + allow_failure: true + +t:gnu:diags: + stage: tests + needs: ["run:gnu"] + tags: + - ncrc4 + script: + - .gitlab/pipeline-ci-tool.sh check-diags gnu allow_failure: true # We cleanup ONLY if the preceding stages were completed successfully diff --git a/.gitlab/README.md b/.gitlab/README.md new file mode 100644 index 0000000000..6e11900f9e --- /dev/null +++ b/.gitlab/README.md @@ -0,0 +1,148 @@ +# CI script pipeline-ci-tool.sh + +pipeline-ci-tool.sh contains functions corresponding to each job within the gitlab CI pipeline for MOM6 at GFDL, specifically on the gaea HPC. +Each function can be run by a parser function so that the functions can be invoked from the command line or a shell. +Some functions take arguments. +Encapsulating the job commands in a function allows us to develop/debug the pipeline by issuing the same, relatively short, commands at the command line. + +pipeline-ci-tool.sh relies on three environment variables to execute. They are mandatory. + - JOB_DIR is a scratch location that will be created and populated + - CI_PROJECT_DIR is normally set by gitlab and will point to the working directory where MOM6 is cloned + - CI_COMMIT_SHA is the commit of MOM6 to be tested + +To use pipeline-ci-tool.sh interactively from an existing MOM6 clone, you could use + `JOB_DIR=tmp CI_PROJECT_DIR=. CI_COMMIT_SHA=`git rev-parse HEAD` .gitlab/pipeline-ci-tool.sh ...` +This will use the HEAD commit in the current working dir and setup an independent test suite under tmp/. + +## Usage + `pipeline-ci-tool.sh FUNCTION [-x|+x] [-n|+n] [ARG1] [ARG2] [...]` + `pipeline-ci-tool.sh FUNCTION [-x|+x] [-n|+n] [ARG1] [ARG2] [[-x|+x] [-n|+n] FUNCTION [ARG1] [ARG2] [...]] [...]` + +FUNCTION can be one of + - `create-job-dir` : Create a "job directory" using the environment variable JOB_DIR. This is a where all the compilation and running takes place. + - `clean-job-dir` : Not used by .gitlab-ci.yml but useful for resetting an interactive session. + - `copy-test-space LABEL` : Within $JOB_DIR, clones MOM6-examples to tmp-MOM6-examples-LABEL to use as a workspace for tests + - `mrs-compile TARGET` : Invokes tools/MRS/Makefile.build to build MODE_VENDER. VENDER can be gnu, intel, or pgi. MODE can be repro, debug, static, etc. + - `nolibs-ocean-only-compile VENDER` : Compiles the "no libraries" executables. These are not used elsewhere in the CI but check we have no namespace problems. VENDER can be gnu, intel, or pgi. + - `run-suite VENDER CODE` : runs subsets of the MOM6-examples according to CODE using the VENDER executables. CODE is a string of the characters S (symmetric), N (non-symmetric), L (layout), D (debug), or R (restart), and if present executes the corresponding tests. + - `check-stats VENDER CODE` : check the stats files for the corresponding VENDOR/CODE resulting from run-suite + - `check-params VENDER CODE` : check the parameter documentation files for the corresponding VENDOR/CODE resulting from run-suite + - `check-diags VENDER CODE` : check the available diagnostics files for the corresponding VENDOR/CODE resulting from run-suite + +Options: + - `-x` : shows commands as they are executed. `+x` turns back to silent executions. You can precede each function as needed so that only commands from selected functions are shown. + - `-n` : for many function, disables all functionality and simply prints the banner that each sections was reached. `+n` turns the functions back on. + +## Correspondance to jobs in .gitlab-ci.yml + +The .gitlab-ci.yml jobs names and pipeline-ci-tool.sh commands are: + + clone: + `pipeline-ci-tool.sh create-job-dir` + + work-space:pgi: + `pipeline-ci-tool.sh copy-test-space pgi` + + work-space:intel: + `pipeline-ci-tool.sh copy-test-space intel` + + work-space:gnu: + `pipeline-ci-tool.sh copy-test-space gnu` + + work-space:gnu-restarts: + `pipeline-ci-tool.sh copy-test-space gnu-rst` + + compile:pgi:repro: + `pipeline-ci-tool.sh mrs-compile repro_pgi` + + compile:intel:repro: + `pipeline-ci-tool.sh mrs-compile repro_intel` + + compile:gnu:repro: + `pipeline-ci-tool.sh mrs-compile repro_gnu mrs-compile static_gnu` + + compile:gnu:debug: + `pipeline-ci-tool.sh mrs-compile debug_gnu` + + compile:gnu:ocean-only-nolibs: + `pipeline-ci-tool.sh nolibs-ocean-only-compile gnu` + + compile:gnu:ice-ocean-nolibs: + `pipeline-ci-tool.sh nolibs-ocean-ice-compile gnu` + + run:pgi: + `pipeline-ci-tool.sh run-suite pgi SNL` + + run:intel: + `pipeline-ci-tool.sh run-suite intel SNL` + + run:gnu: + `pipeline-ci-tool.sh run-suite gnu SNLD` + + run:gnu-restarts: + `pipeline-ci-tool.sh run-suite gnu R` + + t:pgi:symmetric: + `pipeline-ci-tool.sh check-stats pgi S` + + t:pgi:non-symmetric: + `pipeline-ci-tool.sh check-stats pgi N` + + t:pgi:layout: + `pipeline-ci-tool.sh check-stats pgi L` + + t:pgi:params: + `pipeline-ci-tool.sh check-params pgi S` + + t:intel:symmetric: + `pipeline-ci-tool.sh check-stats intel S` + + t:intel:non-symmetric: + `pipeline-ci-tool.sh check-stats intel N` + + t:intel:layout: + `pipeline-ci-tool.sh check-stats intel L` + + t:intel:params: + `pipeline-ci-tool.sh check-params intel S` + + t:gnu:symmetric: + `pipeline-ci-tool.sh check-stats gnu S` + + t:gnu:non-symmetric: + `pipeline-ci-tool.sh check-stats gnu N` + + t:gnu:layout: + `pipeline-ci-tool.sh check-stats gnu L` + + t:gnu:static: + `pipeline-ci-tool.sh check-stats gnu T` + + t:gnu:symmetric-debug: + `pipeline-ci-tool.sh check-stats gnu D` + + t:gnu:restart: + `pipeline-ci-tool.sh check-stats gnu R` + + t:gnu:params: + `pipeline-ci-tool.sh check-params gnu S` + + t:gnu:diags: + `pipeline-ci-tool.sh check-diags gnu S` + +### Duplicating the pipeline interactively + +You can run a sequence of commands as follows. The setup and compile phases of the CI pipeline can be summarized with +``` +pipeline-ci-tool.sh create-job-dir copy-test-space pgi copy-test-space intel copy-test-space gnu copy-test-space gnu-rst mrs-compile repro_pgi mrs-compile repro_intel mrs-compile repro_gnu mrs-compile static_gnu mrs-compile debug_gnu nolibs-ocean-only-compile gnu nolibs-ocean-ice-compile gnu +``` + +The run stage (works on compute nodes only) can be summarized with: +``` +pipeline-ci-tool.sh run-suite pgi SNL run-suite intel SNL run-suite gnu SNLDT run-suite gnu R +``` + +The test stage is summarized by: +``` +pipeline-ci-tool.sh check-stats pgi S check-stats pgi N check-stats pgi L check-params pgi S check-stats intel S check-stats intel N check-stats intel L check-params intel S check-stats gnu S check-stats gnu N check-stats gnu L check-stats gnu T check-stats gnu D check-stats gnu R check-params gnu S check-diags gnu S +``` diff --git a/.gitlab/mom6-ci-run-gnu-script.sh b/.gitlab/mom6-ci-run-gnu-script.sh index 82e37abc5e..8577eff6d2 100644 --- a/.gitlab/mom6-ci-run-gnu-script.sh +++ b/.gitlab/mom6-ci-run-gnu-script.sh @@ -34,7 +34,7 @@ set -v section_start gnu_all_sym "Running symmetric gnu" time make -f tools/MRS/Makefile.run gnu_all -s -j tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/gnu_all_sym -xf - -tar cf - `find [oicl]* -name "*_parameter_doc.*"` | tar --one-top-level=results/gnu_params -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/gnu_params -xf - check_for_core_files section_end diff --git a/.gitlab/mom6-ci-run-intel-script.sh b/.gitlab/mom6-ci-run-intel-script.sh index c5a361a202..875d60c191 100644 --- a/.gitlab/mom6-ci-run-intel-script.sh +++ b/.gitlab/mom6-ci-run-intel-script.sh @@ -34,7 +34,7 @@ set -v section_start intel_all_sym "Running symmetric intel" time make -f tools/MRS/Makefile.run intel_all -s -j tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/intel_all_sym -xf - -tar cf - `find [oicl]* -name "*_parameter_doc.*"` | tar --one-top-level=results/intel_params -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/intel_params -xf - check_for_core_files section_end diff --git a/.gitlab/mom6-ci-run-pgi-script.sh b/.gitlab/mom6-ci-run-pgi-script.sh index 98ba9a08c3..27216e4a9f 100644 --- a/.gitlab/mom6-ci-run-pgi-script.sh +++ b/.gitlab/mom6-ci-run-pgi-script.sh @@ -34,7 +34,7 @@ set -v section_start pgi_all_sym "Running symmetric pgi" time make -f tools/MRS/Makefile.run pgi_all -s -j tar cf - `find [oicl]* -name "*.stats.*[a-z][a-z][a-z]"` | tar --one-top-level=results/pgi_all_sym -xf - -tar cf - `find [oicl]* -name "*_parameter_doc.*"` | tar --one-top-level=results/pgi_params -xf - +tar cf - `find [oicl]* -name "*_parameter_doc.*" -o -name "*available_diags*"` | tar --one-top-level=results/pgi_params -xf - check_for_core_files section_end diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh new file mode 100755 index 0000000000..e23d64523d --- /dev/null +++ b/.gitlab/pipeline-ci-tool.sh @@ -0,0 +1,444 @@ +#!/bin/bash + +# 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 '$JOB_DIR is derived from $CI_PIPELINE_ID in MOM6/.gitlab-ci.yml' + echo 'To use interactively try:' + echo ' JOB_DIR=tmp' $0 $@ + exit 911 +fi +if [ -z $CI_PROJECT_DIR ]; then + echo Environment variable "$"CI_PROJECT_DIR should be defined and point to where gitlab has cloned the MOM6 repository for this pipeline. + echo 'To use interactively try:' + echo ' CI_PROJECT_DIR=.' $0 $@ + exit 911 +else + CI_PROJECT_DIR=`realpath $CI_PROJECT_DIR` +fi +if [ -z $CI_COMMIT_SHA ]; then + echo Environment variable "$"CI_COMMIT_SHA should be defined and indicate the MOM6 commit to used in this pipeline. + echo 'To use interactively try:' + echo ' CI_COMMIT_SHA=`git rev-parse HEAD`' $0 $@ + exit 911 +fi + +# Use CI=true to enable the gitlab folding + +set -e # Stop if we encounter an error + +# Environment variables that can be set outside +STATS_REPO_URL="${STATS_REPO_URL:-https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git}" +STATS_REPO_BRANCH="${STATS_REPO_BRANCH:-dev/gfdl}" +CONFIGS_DIR="${CONFIGS_DIR:-MOM6-examples}" +CONFIGS_REPO_BRANCH="${CONFIGS_REPO_BRANCH:-$STATS_REPO_BRANCH}" + +# Global variables derived from the above +DRYRUN= +STATS_REPO=$(basename $STATS_REPO_URL) +STATS_REPO_DIR=$(basename $STATS_REPO .git) + +# Static variables +RED=$'\033[1;31m' +GRN=$'\033[1;32m' +OFF=$'\e[m' + +# Print the start of a fold in the log +section-start () { + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=true]\r\e[0K$2" +} + +# Print the start of a fold in the log but not collapsed +section-start-open () { + echo -e "\e[0Ksection_start:`date +%s`:$1[collapsed=false]\r\e[0K$2" +} + +# Print the end of a fold in the log +section-end () { + echo -e "\e[0Ksection_end:`date +%s`:$1\r\e[0K" +} + +# Create $JOB_DIR and clean out any prior work-spaces +# Location: run in MOM6 directory +clean-job-dir () { + section-start clean-job-dir "Cleaning $JOB_DIR directory" + if [ ! $DRYRUN ] ; then + #NOT USED? cd $CI_PROJECT_DIR + #NOT USED? git submodule init ; git submodule update + echo Job directory set to $JOB_DIR + mkdir -p $JOB_DIR + cd $JOB_DIR + test -d $STATS_REPO_DIR && rm -rf $STATS_REPO_DIR # In case we are re-running this stage + fi + section-end clean-job-dir +} + +# Create the full work space starting at the regression repository (usually Gaea-stats-MOM6-examples) +# Location: run in MOM6 directory +create-job-dir () { + section-start create-job-dir "Creating and populating $JOB_DIR" + if [ ! $DRYRUN ] ; then + mkdir -p $JOB_DIR + cd $JOB_DIR + git clone $STATS_REPO_URL $STATS_REPO_DIR + cd $STATS_REPO_DIR + git checkout $STATS_REPO_BRANCH + git submodule update --init + cd $CONFIGS_DIR + git checkout $CONFIGS_REPO_BRANCH + git submodule init + git submodule set-url src/MOM6 $CI_PROJECT_DIR/.git + git submodule update --recursive --jobs 8 + (cd src/MOM6 ; git checkout $CI_COMMIT_SHA) # Get commit to be tested + (cd src/MOM6 ; git submodule update --recursive --init) + make -f tools/MRS/Makefile.clone clone_gfdl -j # Extras and link to datasets + bash tools/MRS/generate_manifest.sh . tools/MRS/excluded-expts.txt > manifest.mk + mkdir -p results + fi + section-end create-job-dir +} + +# Create a copy of the configurations working directory +# Location: run in MOM6 directory +copy-test-space () { + if [ -z $1 ]; then echo "copy-test-space needs an argument" ; exit 911 ; fi + section-start copy-test-space-$1 "Copying $CONFIGS_DIR for $1" + if [ ! $DRYRUN ] ; then + COPIED_DIR=tmp-$CONFIGS_DIR-$1 + cd $JOB_DIR/$STATS_REPO_DIR + git clone -s $CONFIGS_DIR/.git $COPIED_DIR + cd $COPIED_DIR + ln -s ../$CONFIGS_DIR/{build,results,.datasets} . + cp ../$CONFIGS_DIR/manifest.mk . + fi + section-end copy-test-space-$1 +} + +# Build a group of executables using the tools/MRS/Makefile.build template +# Location: run in MOM6 directory +mrs-compile () { + if [ -z $1 ]; then echo "mrs-compile needs an argument" ; exit 911 ; fi + section-start mrs-compile-$1 "Compiling target $1" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + time make -f tools/MRS/Makefile.build $1 -s -j + fi + section-end mrs-compile-$1 +} + +# Build an ocean-only executable without intermediate libraries +# Location: run in MOM6 directory +nolibs-ocean-only-compile () { + if [ -z $1 ]; then echo "nolibs-ocean-only-compile needs an argument" ; exit 911 ; fi + section-start nolibs-ocean-only-compile-$1 "Compiling ocean-only $1 executable" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + mkdir -p build-ocean-only-nolibs-$1 + cd build-ocean-only-nolibs-$1 + make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. -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 + (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + fi + section-end nolibs-ocean-only-compile-$1 +} + +# Build an ocean-ice executable without intermediate libraries +# Location: run in MOM6 directory +nolibs-ocean-ice-compile () { + if [ -z $1 ]; then echo "nolibs-ocean-ice-compile needs an argument" ; exit 911 ; fi + section-start nolibs-ocean-ice-compile-$1 "Compiling ocean-ice $1 executable" + if [ ! $DRYRUN ] ; then + cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + mkdir -p build-ocean-only-nolibs-$1 + cd build-ocean-only-nolibs-$1 + make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. -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 + (source $1/env ; make NETCDF=3 REPRO=1 MOM6 -s -j) + fi + section-end nolibs-ocean-ice-compile-$1 +} + +# Internal function to clean up stats files +# Args: list of top level directories to scan +clean-stats () { + find $@ -name "*.stats.*[a-z][a-z][a-z]" -delete +} + +# Internal function to clean up param files +# Args: list of top level directories to scan +clean-params () { + find $@ -name "*_parameter_doc.*" -delete + find $@ -name "*available_diags*" -delete +} + +# Internal function to check for core files +# Args: list of top level directories to scan +check-for-core-files () { + EXIT_CODE=0 + find $@ -name core -type f | grep . && EXIT_CODE=1 + if [[ $EXIT_CODE -gt 0 ]] + then + echo "Error: core files found!" + exit 911 + fi +} + +# Internal function to clean up core files (needed for re-running) +# Args: list of top level directories to scan +clean-core-files () { + find $@ -name core -type f -delete +} + +# Internal function to run a sub-suite and copy results to storage +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +# $2 is sub-suite (_all, _ocean_only, _static_ocean_only, ...) +# $3 is MEMORY macro (dynamic_symmetric, dynamic_nonsymmetric, static) +# $4 is MODE macro (repro, debug) +# $5 is LAYOUT macro (def, alt) +mrs-run-sub-suite () { + if [ "$#" -ne 5 ]; then echo "mrs-run-sub-suite needs 5 arguments" ; exit 911 ; fi + section-start mrs-run-sub-suite-$1-$2-$3-$4-$5 "Running target $1-$2-$3-$4-$5" + EXP_GROUPS=`grep / manifest.mk | sed 's:/.*::' | uniq` + clean-stats $EXP_GROUPS + clean-params $EXP_GROUPS + clean-core-files $EXP_GROUPS + if [[ "$3" == *"_nonsym"* ]]; then + 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 + 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 - + check-for-core-files $EXP_GROUPS + section-end mrs-run-sub-suite-$1-$2-$3-$4-$5 +} + +# Internal function to run restarts on a sub-suite and copy results to storage +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +# $2 is sub-suite (_all, _ocean_only, _static_ocean_only, ...) +# $3 is MEMORY macro (dynamic_symmetric, dynamic_nonsymmetric, static) +# $4 is MODE macro (repro, debug) +# $5 is LAYOUT macro (def, alt) +mrs-run-restarts-sub-suite () { + if [ "$#" -ne 5 ]; then echo "mrs-run-restarts-sub-suite needs 5 arguments" ; exit 911 ; fi + section-start mrs-run-restarts-sub-suite-$1-$2-$3-$4-$5 "Running target $1-$2-$3-$4-$5" + clean-stats $2 + clean-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=01 + check-for-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=02 + check-for-core-files $2 + time make -f tools/MRS/Makefile.restart $1_$2 MEMORY=$3 MODE=$4 LAYOUT=$5 -s -j RESTART_STAGE=12 + check-for-core-files $2 + section-end mrs-run-restarts-sub-suite-$1-$2-$3-$4-$5 +} + +# Run a suite of experiments +# $1 - compiler brand +# $2 - any combination of "SNLDTR" +# S = symmetric +# N = non-symmetric +# L = layout +# D = debug +# R = restarts +run-suite () { + if [ "$#" -ne 2 ]; then echo "run-suite needs 2 arguments" ; exit 911 ; fi + section-start run-suite-$1-$2 "Running suite for $1-$2" + WORK_DIR=tmp-$CONFIGS_DIR-$1 + rm -f $JOB_DIR/CI-BATCH-SUCCESS-$1-$2 + set -e + set -v + + pushd $JOB_DIR/$STATS_REPO_DIR/$WORK_DIR > /dev/null + if [[ "$2" =~ "S" ]]; then # Symmetric + mrs-run-sub-suite $1 all dynamic_symmetric repro def + fi + if [[ "$2" =~ "N" ]]; then # Non-symmetric + mrs-run-sub-suite $1 all dynamic_nonsymmetric repro def + fi + if [[ "$2" =~ "L" ]]; then # Layout + mrs-run-sub-suite $1 all dynamic_symmetric repro alt + fi + if [[ "$2" =~ "D" ]]; then # Debug + mrs-run-sub-suite $1 ocean_only dynamic_symmetric debug def + fi + if [[ "$2" =~ "T" ]]; then # sTatic + mrs-run-sub-suite $1 static_ocean_only static repro def + fi + popd > /dev/null + if [[ "$2" =~ "R" ]]; then # Restarts + pushd $JOB_DIR/$STATS_REPO_DIR/$WORK_DIR-rst > /dev/null + mrs-run-restarts-sub-suite $1 ocean_only dynamic_symmetric repro def + mrs-run-restarts-sub-suite $1 ice_ocean_SIS2 dynamic_symmetric repro def + popd > /dev/null + fi + + # Indicate all went well + touch $JOB_DIR/CI-BATCH-SUCCESS-$1-$2 + + section-end run-suite-$1-$2 +} + +# Test the value of stats files. All files in results/ are checked for in regressions/. It is assumed +# missing files are intended and failed runs were caught earlier in the CI process. +# Args: +# $1 is path of results to test (relative to $STATS_REPO_DIR) +# $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'" + # 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]} + if [ ! $FAIL == 0 ]; then + exit 911 + fi + section-end compare-stats-$1-$2-$3-$4-$5 +} + +# Test the value of stats files for a class of run +# $1 - compiler brand +# $2 - any combination of "SNLDTR" +# S = symmetric +# N = non-symmetric +# L = layout +# D = debug +# T = static +# R = restarts +# +# Many tests are tested against the "dynamic_symmetric repro" suite which must also have been run. +# The "dynamic_symmetric repro" tests alone are checked against the regressions. This is so that +# the pipelines might separate errors that are internally inconsistent. +check-stats () { + if [ "$#" -ne 2 ]; then echo "check-stats needs 2 arguments" ; exit 911 ; fi + + if [[ "$2" =~ "S" ]]; then # Symmetric + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats regressions + fi + if [[ "$2" =~ "N" ]]; then # Non-symmetric + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_nonsymmetric-repro-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "L" ]]; then # Layout + compare-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-alt-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "D" ]]; then # Debug + compare-stats $CONFIGS_DIR/results/$1-ocean_only-dynamic_symmetric-debug-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "T" ]]; then # sTatic + compare-stats $CONFIGS_DIR/results/$1-static_ocean_only-static-repro-def-stats $CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-stats + fi + if [[ "$2" =~ "R" ]]; then # Restarts + pushd $JOB_DIR/$STATS_REPO_DIR/tmp-$CONFIGS_DIR-$1-rst > /dev/null + make -f tools/MRS/Makefile.restart restart_$1_ocean_only restart_$1_ice_ocean_SIS2 -s -k + popd > /dev/null + fi + +} + +# Helper function to compare two files +# Args: +# $1 is source directory +# $2 is target directory +# $3- are file names that should exist relative to both $1 and $2 +# +# Operations for `compare-files src/ tgt/ file1 file2 file3`: +# 1. create the md5sum of file1, file2, and file3, in src/ and then run `md5sum-c` in tgt/ +# 2. if differences are detected, +# a. report the "OK" results first, then the "FAILED". +# b. report the "FAILED". +# c. for each failed file, show the `diff src/$f tgt/$f` +# 3. if no differences are detected, show `md5sum -c` output so the log lists all files that were checked +compare-files () { + SRC=$1 + TGT=$2 + shift; shift + FILES=$@ + ( cd $SRC ; md5sum $FILES ) | ( cd $TGT ; md5sum -c ) | sed -r "s/([A-Za-z0-9_\.\/\-]*): ([A-Z]*)/\2 \1/;s/OK /${GRN}PASS$OFF /;s/FAILED /${RED}FAILED$OFF /" + FAIL=${PIPESTATUS[1]} + if [ ! $FAIL == 0 ]; then + echo Differences follow: + # All is not well so re-order md5sum to summarize status + DFILES=$( ( cd $SRC ; md5sum $FILES ) | ( cd $TGT ; md5sum -c 2> /dev/null ) | grep ": FAILED" | sed 's/:.*//') + for f in $DFILES; do + echo diff $SRC/$f $TGT/$f | sed "s:$JOB_DIR/$STATS_REPO_DIR/::g;s:$CONFIGS_DIR/results/::" + diff $SRC/$f $TGT/$f || true + done + echo Files $DFILES had differences + exit 911 + fi +} + +# Test the value of param files. All files generated in results/ are looked for $CONFIGS_DIR +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +check-params () { + if [ "$#" -ne 1 ]; then echo "check-params needs 1 argument" ; exit 911 ; fi + section-start-open check-params-$1 "Checking params for $1" + SRC=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-params + FILES=$( cd $SRC ; find * -name "*parameter_doc*" -type f ) + compare-files $SRC $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR $FILES + section-end check-params-$1 +} + +# Test the value of available_diag files. Only those recorded in $CONFIGS_DIR are checked. +# Args: +# $1 is compiler (gnu, intel, pgi, ...) +check-diags () { + if [ "$#" -ne 1 ]; then echo "check-diags needs 1 argument" ; exit 911 ; fi + section-start-open check-diags-$1 "Checking diagnostics for $1" + # This checks that any file in the results directory is exactly the same as in regressions/ + SRC=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR/results/$1-all-dynamic_symmetric-repro-def-params + TGT=$JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR + EXP_GROUPS=`grep / $TGT/manifest.mk | sed 's:/.*::' | uniq` + #FILES=$( cd $TGT ; find $EXP_GROUPS -name "*available_diags*" -type f ) + # The following option finds the intersection between all available_diags in both $TGT and $SRC because + # $SRC contains more than are recorded in $TGT but $TGT might have some that we no longer monitor + FILES=$( comm -12 <(cd $SRC; find $EXP_GROUPS -name '*available_diags*' -type f | sort) <(cd $TGT; find $EXP_GROUPS -name '*available_diags*' -type f | sort) ) + compare-files $SRC $TGT $FILES + section-end check-diags-$1 +} + +# Process command line +START_DIR=`pwd` +while [[ $# -gt 0 ]]; do # Loop through arguments + cd $START_DIR + arg=$1 + shift + case "$arg" in + -n | --norun) + DRYRUN=1; echo Dry-run enabled; continue ;; + +n | ++norun) + DRYRUN=; echo Dry-run disabled; continue ;; + -x) + set -x; continue ;; + +x) + set +x; continue ;; + clean-job-dir) + clean-job-dir; continue ;; + create-job-dir) + create-job-dir https://gitlab.gfdl.noaa.gov/ogrp/Gaea-stats-MOM6-examples.git dev/gfdl; continue ;; + copy-test-space) + copy-test-space $1; shift; continue ;; + mrs-compile) + mrs-compile $1; shift; continue ;; + nolibs-ocean-only-compile) + nolibs-ocean-only-compile $1; shift; continue ;; + nolibs-ocean-ice-compile) + nolibs-ocean-ice-compile $1; shift; continue ;; + run-suite) + run-suite $1 $2; shift; shift; continue ;; + check-stats) + check-stats $1 $2; shift; shift; continue ;; + check-params) + check-params $1; shift; continue ;; + check-diags) + check-diags $1; shift; continue ;; + *) + echo \"$arg\" is not a recognized argument! ; exit 9 ;; + esac +done From f95a5ffe81f5225c0b63c5477df323cab44d6b08 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 17 Oct 2022 16:20:01 -0400 Subject: [PATCH 026/629] Bug fix for categorize_axes causing crash - The subroutine categorize_axes cannot find the axes in ice restart files and gives warnings WARNING from PE 0: categorize_axes: Failed to identify x- and y- axes in the axis list (xaxis_1, yaxis_1, Time) of a variable being read from INPUT/ice_model.res.nc - This leads to an incorrect initializations and a subsequent sat.vap.press.overflow crash when using infra/FMS2 - Same experiment runs fine with infra/FMS1 - After the fix the infra/FMS1 and infra/FMS2 answers are bitwise identical --- config_src/infra/FMS2/MOM_io_infra.F90 | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index dc8a9af3d5..955c39fd02 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -1686,6 +1686,12 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. + elseif (variable_att_exists(fileobj, trim(dim_names(i)), "axis")) then + call get_variable_attribute(fileobj, trim(dim_names(i)), "axis", cartesian) + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. endif endif endif From 7d9bf03a2f3e78375bd862358c709d384c5eab51 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Mon, 17 Oct 2022 20:09:54 -0400 Subject: [PATCH 027/629] Bug fix for categorize_axes causing crash - The subroutine categorize_axes cannot find the axes in ice restart files and gives warnings WARNING from PE 0: categorize_axes: Failed to identify x- and y- axes in the axis list (xaxis_1, yaxis_1, Time) of a variable being read from I NPUT/ice_model.res.nc - This leads to an incorrect initializations and a subsequent sat.vap.press.overflow crash when using infra/FMS2 - Same experiment runs fine with infra/FMS1 - After the fix the infra/FMS1 and infra/FMS2 answers are bitwise identical --- config_src/infra/FMS2/MOM_io_infra.F90 | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 955c39fd02..555d03d05f 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -1682,17 +1682,13 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t if (variable_exists(fileobj, trim(dim_names(i)))) then if (variable_att_exists(fileobj, trim(dim_names(i)), "cartesian_axis")) then call get_variable_attribute(fileobj, trim(dim_names(i)), "cartesian_axis", cartesian) - cartesian = adjustl(cartesian) - if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. - if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. - if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. elseif (variable_att_exists(fileobj, trim(dim_names(i)), "axis")) then call get_variable_attribute(fileobj, trim(dim_names(i)), "axis", cartesian) - cartesian = adjustl(cartesian) - if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. - if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. - if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. endif + cartesian = adjustl(cartesian) + if ((index(cartesian, "X") == 1) .or. (index(cartesian, "x") == 1)) is_x(i) = .true. + if ((index(cartesian, "Y") == 1) .or. (index(cartesian, "y") == 1)) is_y(i) = .true. + if ((index(cartesian, "T") == 1) .or. (index(cartesian, "t") == 1)) is_t(i) = .true. endif endif if (is_x(i)) x_found = .true. From e26d8dada95b96f76d0770733b2e11fd97217eff Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Oct 2022 15:53:59 -0400 Subject: [PATCH 028/629] Avoid an uninitialized string in categorize_axes Added a line initializing the string Cartesian to a blank string in categorize_axes, so that it not be uninitialized when it is used a few lines later. --- config_src/infra/FMS2/MOM_io_infra.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 555d03d05f..c49c124ae0 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -1680,6 +1680,7 @@ subroutine categorize_axes(fileObj, filename, ndims, dim_names, is_x, is_y, is_t ! First look for indicative variable attributes if (.not.is_t(i)) then 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) elseif (variable_att_exists(fileobj, trim(dim_names(i)), "axis")) then From 82cbb09b7c741ea78715613849432fefad55e2ea Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 25 Oct 2022 06:04:03 -0400 Subject: [PATCH 029/629] (*)Simplify interpolate_column weight calculations Set the interpolation weights inside of interpolate_column to explicitly be the complement of one another, thereby saving an extra division at each point and reducing the number of variables that need to be stored, in preparation for the creation of a separate subroutine to find interface positions. This commit is mathematically equivalent to what was there before, and the extensive unit testing of interpolate_column is still passing, but it changes the value of some interpolated interface diagnostics at the level of roundoff (but not the MOM6 solutions themselves, as they do not depend on interpolate_column yet). --- src/ALE/MOM_remapping.F90 | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index fa79c50c3c..bfd74b435c 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -877,12 +877,13 @@ subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest) enddo if (dh>0.) then - weight_a = max(0., ( dh - x_dest ) / dh) ! Weight of u1 - weight_b = min(1., x_dest / dh) ! Weight of u2 - u_dest(k_dest) = weight_a * u1 + weight_b * u2 ! Linear interpolation between u1 and u2 - else - u_dest(k_dest) = 0.5 * ( u1 + u2 ) ! For a vanished layer we need to do something reasonable... + weight_b = max(0., min(1., x_dest / dh)) ! Weight of u2 + else ! For a vanished source layer we need to do something reasonable... + weight_b = 0.5 endif + weight_a = 1.0 - weight_b ! Weight of u1 + ! Linear interpolation between u1 and u2 + u_dest(k_dest) = weight_a * u1 + weight_b * u2 ! Mask vanished layers at the surface which would be under an ice-shelf. ! TODO: Need to figure out what to do for an isopycnal coordinate diagnostic that could From d46de87a5329d63ee2257fd7d66ad4d7cb4315b0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 3 Nov 2022 13:36:54 -0400 Subject: [PATCH 030/629] Autoconf: Fortran-netCDF C compatibility test This patch introduces a new autoconf macro, AX_FC_CHECK_C_LIB, which confirms if the Fortran compiler can be linked to the netCDF C library. As with other netCDF tests, the nc-config tool is used if necessary (and available). This resolves some recent issues on platforms where netCDF and netCDF-Fortran are installed in separate locations, with different library directories (-L). It also resolves some false assumptions in configure.ac which presumed equivalent access by the configured C and Fortran compilers. Previously, we would test if the C compiler could be linked to netCDF, and then assume that the Fortran compiler shared the same relationship. We now use the Fortran compiler for both C and Fortran tests. This patch fixes many issues observed on MacOS systems, including some persistent problems on the GitHub Actions MacOS tests. For example, we can now use the default GCC 12 compilers, rather than forcing a rollback to GCC 11. --- .github/actions/macos-setup/action.yml | 2 +- .github/workflows/macos-regression.yml | 4 +-- .github/workflows/macos-stencil.yml | 4 +-- ac/configure.ac | 43 ++++++++++++------------ ac/m4/ax_fc_check_c_lib.m4 | 45 ++++++++++++++++++++++++++ 5 files changed, 70 insertions(+), 28 deletions(-) create mode 100644 ac/m4/ax_fc_check_c_lib.m4 diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml index 197a2d83c8..fecbe787b5 100644 --- a/.github/actions/macos-setup/action.yml +++ b/.github/actions/macos-setup/action.yml @@ -10,7 +10,7 @@ runs: shell: bash run: | echo "::group::Install packages" - brew update + brew reinstall gcc brew install automake brew install netcdf brew install netcdf-fortran diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml index d975854e0c..dc86a52212 100644 --- a/.github/workflows/macos-regression.yml +++ b/.github/workflows/macos-regression.yml @@ -8,8 +8,8 @@ jobs: runs-on: macOS-latest env: - CC: gcc-11 - FC: gfortran-11 + CC: gcc + FC: gfortran defaults: run: diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml index 33436c221f..96240f31f8 100644 --- a/.github/workflows/macos-stencil.yml +++ b/.github/workflows/macos-stencil.yml @@ -8,8 +8,8 @@ jobs: runs-on: macOS-latest env: - CC: gcc-11 - FC: gfortran-11 + CC: gcc + FC: gfortran defaults: run: diff --git a/ac/configure.ac b/ac/configure.ac index 8d74d71fbd..58b05c7aaa 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -105,7 +105,7 @@ AX_FC_CHECK_MODULE([mpi], # netCDF configuration -# Search for the Fortran netCDF module, fallback to nf-config. +# Search for the Fortran netCDF module. AX_FC_CHECK_MODULE([netcdf], [], [ AS_UNSET([ax_fc_cv_mod_netcdf]) AC_PATH_PROG([NF_CONFIG], [nf-config]) @@ -118,39 +118,37 @@ AX_FC_CHECK_MODULE([netcdf], [], [ ]) ]) -# FMS may invoke netCDF C calls, so we link to libnetcdf. -AC_LANG_PUSH([C]) -AC_CHECK_LIB([netcdf], [nc_create], [], [ - AS_UNSET([ac_cv_lib_netcdf_nc_create]) +# Confirm that the Fortran compiler can link the netCDF C library +AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AS_UNSET([ax_fc_cv_c_lib_netcdf_nc_create]) AC_PATH_PROG([NC_CONFIG], [nc-config]) AS_IF([test -n "$NC_CONFIG"], [ - AC_SUBST([LDFLAGS], - ["$LDFLAGS -L$($NC_CONFIG --libdir)"] - ) - ], [AC_MSG_ERROR([Could not find nc-config.])] - ) - AC_CHECK_LIB([netcdf], [nc_create], [], [ - AC_MSG_ERROR([Could not find libnetcdf.]) + AC_SUBST([LDFLAGS], ["$LDFLAGS -L$($NC_CONFIG --libdir)"]) + ], [ + AC_MSG_ERROR([Could not find nc-config.]) + ]) + AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AC_MSG_ERROR([Could not find netCDF C library.]) ]) ]) -AC_LANG_POP([C]) -# NOTE: We test for nf_create, rather than nf90_create, because AX_FC_CHECK_LIB -# is currently not yet able to properly probe inside modules. -# NOTE: nf-config does not have --libdir, so we use the first term of flibs. - -# Link to Fortran netCDF library, netcdff +# Confirm that the Fortran compiler can link to the netCDF Fortran library. +# NOTE: +# - We test nf_create, rather than nf90_create, since AX_FC_CHECK_LIB can +# not currently probe the Fortran 90 interfaces. +# - nf-config does not have --libdir, so we parse the --flibs output. AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [ AS_UNSET([ax_fc_cv_lib_netcdff_nf_create]) AC_PATH_PROG([NF_CONFIG], [nf-config]) AS_IF([test -n "$NF_CONFIG"], [ AC_SUBST([LDFLAGS], - ["$LDFLAGS $($NF_CONFIG --flibs | cut -f1 -d" ")"] + ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"] ) - ], [AC_MSG_ERROR([Could not find nf_create.])] - ) + ], [ + AC_MSG_ERROR([Could not find nf-config.]) + ]) AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [ - AC_MSG_ERROR([Could not find libnetcdff.]) + AC_MSG_ERROR([Could not find netCDF Fortran library.]) ]) ]) @@ -268,4 +266,3 @@ AC_LANG_POP([C]) AC_SUBST([CPPFLAGS]) AC_CONFIG_FILES([Makefile:${srcdir}/ac/Makefile.in]) AC_OUTPUT - diff --git a/ac/m4/ax_fc_check_c_lib.m4 b/ac/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..ea41786fb7 --- /dev/null +++ b/ac/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,45 @@ +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C binding is available to the compiler. +dnl +dnl Equivalently, it checks if the Fortran compiler can see a C function. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) From 522e7aa67cba9cc21884d7b014b98d2fe2ca3c11 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 9 Nov 2022 12:52:16 -0500 Subject: [PATCH 031/629] Autoconf: Fortran testing of C bindings This patch fixes some issues with testing of C bindings in Fortran. Specifically, some tests are using a C compiler which may be unconfigured, causing unexpected errors. The autoconf script now uses the Fortran compiler to test these bindings, rather than using the C compiler to test for their existence. A new macro (AX_FC_CHECK_BIND_C) was added to run these tests. This achieves the actual goal (test of Fortran binding) on top of the original goal (availability of C function), while ensuring that the actual compiler of interest (FC) is used in the test. Two C-based tests are still present in the script for testing the size of jmp_buf and sigjmp_buf. The C compiler is now configured with the AX_MPI macro, and is only used to determine the size of these structs. --- ac/configure.ac | 25 ++++++++++++++-------- ac/m4/ax_fc_check_bind_c.m4 | 42 +++++++++++++++++++++++++++++++++++++ ac/m4/ax_fc_check_c_lib.m4 | 6 +++--- 3 files changed, 61 insertions(+), 12 deletions(-) create mode 100644 ac/m4/ax_fc_check_bind_c.m4 diff --git a/ac/configure.ac b/ac/configure.ac index 58b05c7aaa..049325a891 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -88,8 +88,9 @@ AC_FC_SRCEXT(f90) # - This can cause standard AC_PROG_FC tests to fail if FCFLAGS is configured # with flags from another compiler. # - I do not yet know how to resolve this possible issue. -AX_MPI([], - [AC_MSG_ERROR([Could not find MPI launcher.])]) +AX_MPI([], [ + AC_MSG_ERROR([Could not find MPI launcher.]) +]) # Explicitly replace FC and LD with MPI wrappers @@ -233,13 +234,13 @@ AC_CONFIG_COMMANDS(Makefile.dep, [make depend]) # POSIX verification tests -AC_LANG_PUSH([C]) # These symbols may be defined as macros, making them inaccessible by Fortran. -# The following exist in BSD and Linux, so we just test for them. -AC_CHECK_FUNC([setjmp], [], [AC_MSG_ERROR([Could not find setjmp.])]) -AC_CHECK_FUNC([longjmp], [], [AC_MSG_ERROR([Could not find longjmp.])]) -AC_CHECK_FUNC([siglongjmp], [], [AC_MSG_ERROR([Could not find siglongjmp.])]) +# 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.])]) # Determine the sigsetjmp symbol. If missing, then point to sigsetjmp_missing. # @@ -248,14 +249,20 @@ AC_CHECK_FUNC([siglongjmp], [], [AC_MSG_ERROR([Could not find siglongjmp.])]) # __sigsetjmp glibc (Linux) SIGSETJMP="sigsetjmp_missing" for sigsetjmp_fn in sigsetjmp __sigsetjmp; do - AC_CHECK_FUNC([${sigsetjmp_fn}], [ + AX_FC_CHECK_BIND_C([${sigsetjmp_fn}], [ SIGSETJMP=${sigsetjmp_fn} break ]) done AC_DEFINE_UNQUOTED([SIGSETJMP_NAME], ["${SIGSETJMP}"]) -# Determine the size of jmp_buf and sigjmp_buf +# 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]) + +AX_MPI([], [AC_MSG_ERROR([Could not find MPI launcher.])]) +AC_SUBST([CC], [$MPICC]) + AC_CHECK_SIZEOF([jmp_buf], [], [#include ]) AC_CHECK_SIZEOF([sigjmp_buf], [], [#include ]) diff --git a/ac/m4/ax_fc_check_bind_c.m4 b/ac/m4/ax_fc_check_bind_c.m4 new file mode 100644 index 0000000000..9b9f821d4c --- /dev/null +++ b/ac/m4/ax_fc_check_bind_c.m4 @@ -0,0 +1,42 @@ +dnl AX_FC_CHECK_C_LIB(FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C binding is available to the compiler. +dnl +dnl Equivalently, it checks if the Fortran compiler can see a C function. +dnl +dnl Results are cached in `ax_fc_cv_bind_c_FUNCTION`. +dnl +AC_DEFUN([AX_FC_CHECK_BIND_C], [ + AS_VAR_PUSHDEF([ax_fc_Bind_C], [ax_fc_cv_bind_c_$1]) + m4_ifval([$4], + [ax_fc_bind_c_msg_LDFLAGS=" with $4"], + [ax_fc_bind_c_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [if $FC can bind $1$ax_fc_bind_c_msg_LDFLAGS], [ax_fc_cv_bind_c_$1], [ + ax_fc_check_bind_c_save_LDFLAGS=$LDFLAGS + LDFLAGS="$4 $LDFLAGS" + ax_fc_check_bind_c_save_LIBS=$LIBS + LIBS="$5 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$1") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_Bind_C], [yes])], + [AS_VAR_SET([ax_fc_Bind_C], [no])] + ) + LDFLAGS=$ax_fc_check_bind_c_save_LDFLAGS + LIBS=$ax_fc_check_bind_c_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_Bind_C], [yes], [$2], [$3]) + AS_VAR_POPDEF([ax_fc_Bind_C]) +]) diff --git a/ac/m4/ax_fc_check_c_lib.m4 b/ac/m4/ax_fc_check_c_lib.m4 index ea41786fb7..af5765282a 100644 --- a/ac/m4/ax_fc_check_c_lib.m4 +++ b/ac/m4/ax_fc_check_c_lib.m4 @@ -2,12 +2,12 @@ dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], dnl [OTHER-LDFLAGS], [OTHER-LIBS]) dnl -dnl This macro checks if a C binding is available to the compiler. -dnl -dnl Equivalently, it checks if the Fortran compiler can see a C function. +dnl This macro checks if a C library can be referenced by a Fortran compiler. dnl dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl AC_DEFUN([AX_FC_CHECK_C_LIB], [ AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) m4_ifval([$5], From 9d5a320db71309220061cf2a5dfbfa0c9e7e81c1 Mon Sep 17 00:00:00 2001 From: Niki Zadeh Date: Thu, 10 Nov 2022 04:33:34 -0500 Subject: [PATCH 032/629] Obc setup plus segment update period (#198) * Setup OBC segments for COBALT/OBGC tracers - These are updates required to setup OBC segments for OBGC tracers. - Since COBALT package has more than 50 tracers using the MOM6 table mechanism for setting up OBC segments is not feasible. Rather, this update delegates such setup to mechanims used in ocean_BGS tracers leaving MOM6 mechanism for native tracers intact. - Fixed issues caught by MOM6 githubCI * Add capability to change obc segment update period - COBALT tracers do not need as frequent segment bc updates and can use a larger update period to speed up the model. This commit introduces a new parameter DT_OBC_SEG_UPDATE_OBGC that can be adjusted for obc segment update period. - This commit applies the change only to BGC tracers but can easily be changed to apply for all. * Insert missing US%T_to_sec - The unit conversion factor was missing causing a crash in a newer test. * Updates from Andrew Ross - Avoid low initial values in the tracer reservoirs * Per Andrew Ross review * corrected indentation per review * Avoid using module vars per review request - Reviewer asked to avoid using module variables with "save" attributes. - This commit hides the module variables inside the existing OBC type. * Coding style corrections per review * Modification per review: do_not_log if .not.associated(CS%OBC) Co-authored-by: Robert Hallberg --- .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 14 + src/core/MOM.F90 | 34 ++- src/core/MOM_open_boundary.F90 | 246 +++++++++++++++++- src/tracer/MOM_generic_tracer.F90 | 62 ++++- src/tracer/MOM_tracer_flow_control.F90 | 24 +- 5 files changed, 358 insertions(+), 22 deletions(-) diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index cbc310eb7d..e0d3b1d6a9 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -25,6 +25,8 @@ module g_tracer_utils character(len=fm_string_len) :: src_var_name !< Tracer source variable name character(len=fm_string_len) :: src_var_unit !< Tracer source variable units character(len=fm_string_len) :: src_var_gridspec !< Tracer source grid file name + character(len=fm_string_len) :: obc_src_file_name !< Boundary condition tracer source filename + character(len=fm_string_len) :: obc_src_field_name !< Boundary condition tracer source fieldname integer :: src_var_record !< Unknown logical :: requires_src_info = .false. !< Unknown real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin @@ -61,6 +63,7 @@ module g_tracer_utils public :: g_tracer_get_next public :: g_tracer_is_prog public :: g_diag_type + public :: g_tracer_get_obc_segment_props !> Set the values of various (array) members of the tracer node g_tracer_type !! @@ -284,6 +287,17 @@ subroutine g_tracer_get_next(g_tracer,g_tracer_next) type(g_tracer_type), pointer :: g_tracer_next !< Pointer to the next tracer node in the list end subroutine g_tracer_get_next + !> get obc segment properties for each tracer + subroutine g_tracer_get_obc_segment_props(g_tracer_list, name, obc_has, src_file, src_var_name,lfac_in,lfac_out) + type(g_tracer_type), pointer :: g_tracer_list !< pointer to the head of the generic tracer list + character(len=*), intent(in) :: name !< tracer name + logical, intent(out):: obc_has !< .true. if This tracer has OBC + real, optional,intent(out):: lfac_in !< OBC reservoir inverse lengthscale factor + real, optional,intent(out):: lfac_out !< OBC reservoir inverse lengthscale factor + character(len=*),optional,intent(out):: src_file !< OBC source file + character(len=*),optional,intent(out):: src_var_name !< OBC source variable in file + end subroutine g_tracer_get_obc_segment_props + !>Vertical Diffusion of a tracer node !! !! This subroutine solves a tridiagonal equation to find and set values of vertically diffused field diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c61f130ef7..fef71ab4d5 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -133,7 +133,7 @@ module MOM use MOM_tracer_registry, only : lock_tracer_registry, tracer_registry_end use MOM_tracer_flow_control, only : call_tracer_register, tracer_flow_control_CS use MOM_tracer_flow_control, only : tracer_flow_control_init, call_tracer_surface_state -use MOM_tracer_flow_control, only : tracer_flow_control_end +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 @@ -294,7 +294,11 @@ module MOM !! barotropic time step [s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. - type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. + type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. + real :: dt_obc_seg_period !< The time interval between OBC segment updates for OBGC tracers + type(time_type) :: dt_obc_seg_interval !< A time_time representation of dt_obc_seg_period. + type(time_type) :: dt_obc_seg_time !< The next time OBC segment update is applied to OBGC tracers. + real, dimension(:,:), pointer :: frac_shelf_h => NULL() !< fraction of total area occupied !! by ice shelf [nondim] real, dimension(:,:), pointer :: mass_shelf => NULL() !< Mass of ice shelf [R Z ~> kg m-2] @@ -1132,6 +1136,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call disable_averaging(CS%diag) endif + !OBC segment data update for some fields can be less frequent than others + if(associated(CS%OBC)) then + CS%OBC%update_OBC_seg_data = .false. + if (CS%dt_obc_seg_period == 0.0) CS%OBC%update_OBC_seg_data = .true. + if (CS%dt_obc_seg_period > 0.0) then + if (Time_local >= CS%dt_obc_seg_time) then + CS%OBC%update_OBC_seg_data = .true. + CS%dt_obc_seg_time = CS%dt_obc_seg_time + CS%dt_obc_seg_interval + endif + endif + endif if (CS%do_dynamics .and. CS%split) then !--------------------------- start SPLIT ! This section uses a split time stepping scheme for the dynamic equations, @@ -2152,6 +2167,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & units="s", default=default_val, do_not_read=(dtbt > 0.0)) endif + CS%dt_obc_seg_period = -1.0 + call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & + "The time between OBC segment data updates for OBGC tracers. "//& + "This must be an integer multiple of DT and DT_THERM. "//& + "The default is set to DT.", & + units="s", default=US%T_to_s*CS%dt, do_not_log=.not.associated(CS%OBC)) + ! 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 @@ -2627,6 +2649,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! could occur with the call to update_OBC_data or after the main initialization. if (use_temperature) & call register_temp_salt_segments(GV, US, CS%OBC, CS%tracer_Reg, param_file) + !This is the equivalent call to register_temp_salt_segments for external tracers with OBC + call call_tracer_register_obc_segments(GV, param_file, CS%tracer_flow_CSp, CS%tracer_Reg, CS%OBC) ! This needs the number of tracers and to have called any code that sets whether ! reservoirs are used. @@ -2962,6 +2986,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%ntrunc, cont_stencil=CS%cont_stencil) endif + !Set OBC segment data update period + if (associated(CS%OBC) .and. CS%dt_obc_seg_period > 0.0) then + CS%dt_obc_seg_interval = real_to_time(US%T_to_s*CS%dt_obc_seg_period) + CS%dt_obc_seg_time = Time + CS%dt_obc_seg_interval + endif + call callTree_waypoint("dynamics initialized (initialize_MOM)") CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 1cc8505d17..7d89d97c0f 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -57,7 +57,11 @@ module MOM_open_boundary public segment_tracer_registry_end public register_segment_tracer public register_temp_salt_segments +public register_obgc_segments public fill_temp_salt_segments +public fill_obgc_segments +public set_obgc_segments_props +public setup_OBC_tracer_reservoirs public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp @@ -78,7 +82,8 @@ module MOM_open_boundary 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 - character(len=8) :: name !< a name identifier for the segment data + 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 !! the internal units of this field real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces @@ -91,6 +96,10 @@ module MOM_open_boundary !! 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 :: 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 + !< the general 1/Lscale_OUT is multiplied by this factor for each tracer end type OBC_segment_data_type !> Tracer on OBC segment data structure, for putting into a segment tracer registry. @@ -262,6 +271,8 @@ module MOM_open_boundary logical :: user_BCs_set_globally = .false. !< True if any OBC_USER_CONFIG is set !! for input from user directory. logical :: update_OBC = .false. !< Is OBC data time-dependent + logical :: update_OBC_seg_data = .false. !< Is it the time for OBC segment data update for fields that + !! require less frequent update logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero @@ -304,6 +315,9 @@ module MOM_open_boundary ! Which segment object describes the current point. integer, allocatable :: segnum_u(:,:) !< Segment number of u-points. integer, allocatable :: segnum_v(:,:) !< Segment number of v-points. + ! Keep the OBC segment properties for external BGC tracers + type(external_tracers_segments_props), pointer :: obgc_segments_props => NULL() !< obgc segment properties + integer :: num_obgc_tracers = 0 !< The total number of obgc tracers ! The following parameters are used in the baroclinic radiation code: real :: gamma_uv !< The relative weighting for the baroclinic radiation @@ -370,6 +384,15 @@ module MOM_open_boundary !! When locked=.true.,no more boundaries can be registered. end type OBC_registry_type +!> Type to carry OBC information needed for setting segments for OBGC tracers +type, private :: external_tracers_segments_props + type(external_tracers_segments_props), pointer :: next => NULL() !< pointer to the next node + character(len=128) :: tracer_name !< tracer name + character(len=128) :: tracer_src_file !< tracer source file for BC + character(len=128) :: tracer_src_field !< name of the field in source file to extract BC + real :: lfac_in !< multiplicative factor for inbound tracer reservoir length scale + real :: lfac_out !< multiplicative factor for outbound tracer reservoir length scale +end type external_tracers_segments_props integer :: id_clock_pass !< A CPU time clock character(len=40) :: mdl = "MOM_open_boundary" !< This module's name. @@ -704,7 +727,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) type(ocean_OBC_type), target, intent(inout) :: OBC !< Open boundary control structure type(param_file_type), intent(in) :: PF !< Parameter file handle - integer :: n, m, num_fields + integer :: n, m, num_fields, mm character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix @@ -721,6 +744,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) integer, dimension(:), allocatable :: saved_pelist integer :: current_pe integer, dimension(1) :: single_pelist + type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() !will be able to dynamically switch between sub-sampling refined grid data or model grid is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -772,8 +796,9 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) cycle ! cycle to next segment endif - allocate(segment%field(num_fields)) - segment%num_fields = num_fields + !There are OBC%num_obgc_tracers obgc tracers are there that are not listed in param file + segment%num_fields = num_fields + OBC%num_obgc_tracers + allocate(segment%field(segment%num_fields)) segment%temp_segment_data_exists = .false. segment%salt_segment_data_exists = .false. @@ -786,9 +811,28 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB - do m=1,num_fields - call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & - value, filename, fieldname) + obgc_segments_props_list => OBC%obgc_segments_props !pointer to the head node + do m=1,segment%num_fields + if (m .le. num_fields) then + !These are tracers with segments specified in MOM6 style override files + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) + else + !These are obgc tracers with segments specified by external modules. + !Set a flag so that these can be distinguished from native tracers as they may need + !extra steps for preparation and handling. + segment%field(m)%genre = 'obgc' + !Query the obgc segment properties by traversing the linkedlist + call get_obgc_segments_props(obgc_segments_props_list,fields(m),filename,fieldname,& + segment%field(m)%resrv_lfac_in,segment%field(m)%resrv_lfac_out) + !Make sure the obgc tracer is not specified in the MOM6 param file too. + do mm=1,num_fields + if(trim(fields(m)) == trim(fields(mm))) then + if(is_root_pe()) & + call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// & + " appears in OBC_SEGMENT_XXX_DATA string in MOM6 param file. This is not supported!") + endif + enddo + endif if (trim(filename) /= 'none') then OBC%update_OBC = .true. ! Data is assumed to be time-dependent if we are reading from file OBC%needs_IO_for_data = .true. ! At least one segment is using I/O for OBC data @@ -1737,7 +1781,7 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) logical, intent(in) :: use_temperature !< If true, T and S are used ! Local variables - integer :: n,m,num_fields + integer :: n,m,num_fields,na character(len=1024) :: segstr character(len=256) :: filename character(len=20) :: segnam, suffix @@ -1789,6 +1833,23 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) OBC%tracer_y_reservoirs_used(2) = .true. endif endif + !Add reservoirs for external/obgc tracers + !There is a diconnect in the above logic between tracer index and reservoir index. + !It arbitarily assigns reservoir indexes 1&2 to tracers T&S, + !So we need to start from reservoir index for non-native tracers from 3, hence na=2 below. + !num_fields is the number of vars in segstr (6 of them now, U,V,SSH,TEMP,SALT,dye) + !but OBC%tracer_x_reservoirs_used is allocated to size Reg%ntr, which is the total number of tracers + na=2 !number of native MOM6 tracers (T&S) with reservoirs + do m=1,OBC%num_obgc_tracers + !This logic assumes all external tarcers need a reservoir + !The segments for tracers are not initialized yet (that happens later in initialize_segment_data()) + !so we cannot query to determine if this tracer needs a reservoir. + if (segment%is_E_or_W_2) then + OBC%tracer_x_reservoirs_used(m+na) = .true. + else + OBC%tracer_y_reservoirs_used(m+na) = .true. + endif + enddo enddo return @@ -3491,6 +3552,22 @@ function lookup_seg_field(OBC_seg,field) end function lookup_seg_field +!> Return the tracer index from its name +function get_tracer_index(OBC_seg,tr_name) + type(OBC_segment_type), pointer :: OBC_seg !< OBC segment + character(len=*), intent(in) :: tr_name !< The field name + integer :: get_tracer_index, it + get_tracer_index=-1 + it=1 + do while(allocated(OBC_seg%tr_Reg%Tr(it)%t)) + if (trim(OBC_seg%tr_Reg%Tr(it)%name) == trim(tr_name)) then + get_tracer_index=it + exit + endif + it=it+1 + enddo + return +end function get_tracer_index !> Allocate segment data fields subroutine allocate_OBC_segment_data(OBC, segment) @@ -3715,7 +3792,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) type(time_type), intent(in) :: Time !< Model time ! Local variables integer :: c, i, j, k, is, ie, js, je, isd, ied, jsd, jed - integer :: IsdB, IedB, JsdB, JedB, n, m, nz + integer :: IsdB, IedB, JsdB, JedB, n, m, nz, nt type(OBC_segment_type), pointer :: segment => NULL() integer, dimension(4) :: siz real, dimension(:,:,:), pointer :: tmp_buffer_in => NULL() ! Unrotated input [various units] @@ -3810,6 +3887,10 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) allocate(h_stack(GV%ke), source=0.0) do m = 1,segment%num_fields + !This field may not require a high frequency OBC segment update and might be allowed + !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 siz(1)=size(segment%field(m)%buffer_src,1) siz(2)=size(segment%field(m)%buffer_src,2) @@ -4173,6 +4254,8 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) ! Start second loop to update all fields now that data for all fields are available. ! (split because tides depend on multiple variables). 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 ! calculate external BT velocity and transport if needed if (trim(segment%field(m)%name) == 'U' .or. trim(segment%field(m)%name) == 'V') then @@ -4359,6 +4442,25 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) else segment%tr_Reg%Tr(2)%OBC_inflow_conc = segment%field(m)%value endif + elseif (trim(segment%field(m)%genre) == 'obgc') then + nt=get_tracer_index(segment,trim(segment%field(m)%name)) + if(nt .lt. 0) then + call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) + endif + if (allocated(segment%field(m)%buffer_dst)) then + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(nt)%t(i,j,k) = segment%field(m)%buffer_dst(i,j,k) + enddo ; enddo ; enddo + if (.not. segment%tr_Reg%Tr(nt)%is_initialized) then + !if the tracer reservoir has not yet been initialized, then set to external value. + do k=1,nz; do j=js_obc2, je_obc; do i=is_obc2,ie_obc + segment%tr_Reg%Tr(nt)%tres(i,j,k) = segment%tr_Reg%Tr(nt)%t(i,j,k) + enddo ; enddo ; enddo + segment%tr_Reg%Tr(nt)%is_initialized=.true. + endif + else + segment%tr_Reg%Tr(nt)%OBC_inflow_conc = segment%field(m)%value + endif endif enddo ! end field loop @@ -4660,6 +4762,123 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) end subroutine register_temp_salt_segments +!> Sets the OBC properties of external obgc tracers, such as their source file and field name +subroutine set_obgc_segments_props(OBC,tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + type(ocean_OBC_type),pointer :: OBC !< Open boundary structure + character(len=*), intent(in) :: tr_name !< Tracer name + character(len=*), intent(in) :: obc_src_file_name !< OBC source file name + character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file + real, intent(in) :: lfac_in !< factors for tracer reservoir length scales + real, intent(in) :: lfac_out !< factors for tracer reservoir length scales + + type(external_tracers_segments_props),pointer :: node_ptr => NULL() !pointer to type that keeps + ! the tracer segment properties + allocate(node_ptr) + node_ptr%tracer_name = trim(tr_name) + node_ptr%tracer_src_file = trim(obc_src_file_name) + node_ptr%tracer_src_field = trim(obc_src_field_name) + node_ptr%lfac_in = lfac_in + node_ptr%lfac_out = lfac_out + ! Reversed Linked List implementation! Make this new node to be the head of the list. + node_ptr%next => OBC%obgc_segments_props + OBC%obgc_segments_props => node_ptr + OBC%num_obgc_tracers = OBC%num_obgc_tracers+1 +end subroutine set_obgc_segments_props + +!> Get the OBC properties of external obgc tracers, such as their source file, field name, +!! reservoir length scale factors +subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + type(external_tracers_segments_props),pointer :: node !< pointer to tracer segment properties + character(len=*), intent(out) :: tr_name !< Tracer name + character(len=*), intent(out) :: obc_src_file_name !< OBC source file name + character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file + real, intent(out) :: lfac_in !< multiplicative factor for inbound reservoir length scale + real, intent(out) :: lfac_out !< multiplicative factor for outbound reservoir length scale + tr_name = trim(node%tracer_name) + obc_src_file_name = trim(node%tracer_src_file) + obc_src_field_name = trim(node%tracer_src_field) + lfac_in = node%lfac_in + lfac_out = node%lfac_out + node => node%next +end subroutine get_obgc_segments_props + +subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry + type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values + character(len=*), intent(in) :: tr_name!< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf + integer :: i, j, k, n + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + type(tracer_type), pointer :: tr_ptr => NULL() + + if (.not. associated(OBC)) return + + do n=1, OBC%number_of_segments + segment=>OBC%segment(n) + if (.not. segment%on_pe) cycle + call tracer_name_lookup(tr_Reg, tr_ptr, tr_name) + call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.True.) + enddo + +end subroutine register_obgc_segments + +subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field + character(len=*), intent(in) :: tr_name!< Tracer name +! Local variables + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt + integer :: i, j, k + type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list + real :: I_scale + + if (.not. associated(OBC)) return + call pass_var(tr_ptr, G%Domain) + nz = G%ke + do n=1, OBC%number_of_segments + segment => OBC%segment(n) + if (.not. segment%on_pe) cycle + nt=get_tracer_index(segment,tr_name) + if(nt .lt. 0) then + call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) + endif + isd = segment%HI%isd ; ied = segment%HI%ied + jsd = segment%HI%jsd ; jed = segment%HI%jed + IsdB = segment%HI%IsdB ; IedB = segment%HI%IedB + JsdB = segment%HI%JsdB ; JedB = segment%HI%JedB + I_scale = 1.0 + if (segment%tr_Reg%Tr(nt)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(nt)%scale + ! Fill with Tracer values + if (segment%is_E_or_W) then + I=segment%HI%IsdB + do k=1,nz ; do j=segment%HI%jsd,segment%HI%jed + if (segment%direction == OBC_DIRECTION_W) then + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i+1,j,k) + else + segment%tr_Reg%Tr(nt)%t(I,j,k) = tr_ptr(i,j,k) + endif + OBC%tres_x(I,j,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%t(I,j,k) + enddo ; enddo + else + J=segment%HI%JsdB + do k=1,nz ; do i=segment%HI%isd,segment%HI%ied + if (segment%direction == OBC_DIRECTION_S) then + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j+1,k) + else + segment%tr_Reg%Tr(nt)%t(i,J,k) = tr_ptr(i,j,k) + endif + OBC%tres_y(i,J,k,nt) = I_scale * segment%tr_Reg%Tr(nt)%t(i,J,k) + enddo ; enddo + endif + segment%tr_Reg%Tr(nt)%tres(:,:,:) = segment%tr_Reg%Tr(nt)%t(:,:,:) + enddo +end subroutine fill_obgc_segments + subroutine fill_temp_salt_segments(G, GV, US, OBC, tv) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -5109,7 +5328,6 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward ! It's clear that a_in and a_out cannot be both non-zero [nodim] - nz = GV%ke ntr = Reg%ntr @@ -5140,9 +5358,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out / & + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*segment%field(m)%resrv_lfac_out / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in / & + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*segment%field(m)%resrv_lfac_in / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1) * & @@ -5171,9 +5389,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out / & + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*segment%field(m)%resrv_lfac_out / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in / & + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*segment%field(m)%resrv_lfac_in / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) fac1 = 1.0 + (v_L_out-v_L_in) fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 3cbed68467..4e88944958 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -27,6 +27,7 @@ module MOM_generic_tracer use g_tracer_utils, only: g_tracer_get_next,g_tracer_type,g_tracer_is_prog,g_tracer_flux_init use g_tracer_utils, only: g_tracer_send_diag,g_tracer_get_values use g_tracer_utils, only: g_tracer_get_pointer,g_tracer_get_alias,g_tracer_set_csdiag + use g_tracer_utils, only: g_tracer_get_obc_segment_props use MOM_ALE_sponge, only : set_up_ALE_sponge_field, ALE_sponge_CS use MOM_coms, only : EFP_type, max_across_PEs, min_across_PEs, PE_here @@ -39,6 +40,8 @@ module MOM_generic_tracer use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_open_boundary, only : ocean_OBC_type + use MOM_open_boundary, only : register_obgc_segments, fill_obgc_segments + use MOM_open_boundary, only : set_obgc_segments_props use MOM_restart, only : register_restart_field, query_initialized, set_initialized, MOM_restart_CS use MOM_spatial_means, only : global_area_mean, global_mass_int_EFP use MOM_sponge, only : set_up_sponge_field, sponge_CS @@ -65,6 +68,7 @@ module MOM_generic_tracer public MOM_generic_flux_init public MOM_generic_tracer_min_max public MOM_generic_tracer_fluxes_accumulate + public register_MOM_generic_tracer_segments !> Control structure for generic tracers type, public :: MOM_generic_tracer_CS ; private @@ -79,7 +83,7 @@ module MOM_generic_tracer type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Restart control structure - + type(ocean_OBC_type), pointer :: OBC => NULL() ! Pointer to the first element of the linked list of generic tracers. type(g_tracer_type), pointer :: g_tracer_list => NULL() @@ -98,10 +102,9 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer !! advection and diffusion module. type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct - ! Local variables logical :: register_MOM_generic_tracer - + logical :: obc_has ! This include declares and sets the variable "version". # include "version_variable.h" @@ -112,6 +115,8 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) integer :: ntau, axes(3) type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name,longname,units + character(len=fm_string_len) :: obc_src_file_name,obc_src_field_name + real :: lfac_in,lfac_out real, dimension(:,:,:,:), pointer :: tr_field real, dimension(:,:,:), pointer :: tr_ptr real, dimension(HI%isd:HI%ied, HI%jsd:HI%jed,GV%ke) :: grid_tmask @@ -156,7 +161,6 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) CS%restart_CSp => restart_CS - ntau=1 ! MOM needs the fields at only one time step @@ -216,6 +220,52 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) register_MOM_generic_tracer = .true. end function register_MOM_generic_tracer + !> Register OBC segments for generic tracers + subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables + logical :: obc_has + ! This include declares and sets the variable "version". +# include "version_variable.h" + + character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer_segments' + type(g_tracer_type), pointer :: g_tracer,g_tracer_next + character(len=fm_string_len) :: g_tracer_name + character(len=fm_string_len) :: obc_src_file_name,obc_src_field_name + real :: lfac_in,lfac_out + + if (.NOT. associated(OBC)) return + !Get the tracer list + call generic_tracer_get_list(CS%g_tracer_list) + if (.NOT. associated(CS%g_tracer_list)) call MOM_error(FATAL, trim(sub_name)//& + ": No tracer in the list.") + + g_tracer=>CS%g_tracer_list + do + call g_tracer_get_alias(g_tracer,g_tracer_name) + if (g_tracer_is_prog(g_tracer)) then + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ,& + obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + if (obc_has) then + call set_obgc_segments_props(OBC,g_tracer_name,obc_src_file_name,obc_src_field_name,lfac_in,lfac_out) + call register_obgc_segments(GV, OBC, tr_Reg, param_file, g_tracer_name) + endif + endif + + !traverse the linked list till hit NULL + call g_tracer_get_next(g_tracer, g_tracer_next) + if (.NOT. associated(g_tracer_next)) exit + g_tracer=>g_tracer_next + + enddo + + end subroutine register_MOM_generic_tracer_segments !> Initialize phase II: Initialize required variables for generic tracers !! There are some steps of initialization that cannot be done in register_MOM_generic_tracer !! This is the place and time to do them: @@ -244,7 +294,7 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, !! ALE sponges. character(len=128), parameter :: sub_name = 'initialize_MOM_generic_tracer' - logical :: OK + logical :: OK,obc_has integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name @@ -348,6 +398,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, call set_initialized(tr_ptr, g_tracer_name, CS%restart_CSp) endif + call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) + if(obc_has .and. g_tracer_is_prog(g_tracer)) call fill_obgc_segments(G, GV, OBC, tr_ptr, g_tracer_name) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) if (.NOT. associated(g_tracer_next)) exit diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 1345126d73..af0dded244 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -60,6 +60,7 @@ module MOM_tracer_flow_control use MOM_generic_tracer, only : MOM_generic_tracer_column_physics, MOM_generic_tracer_surface_state use MOM_generic_tracer, only : end_MOM_generic_tracer, MOM_generic_tracer_get, MOM_generic_flux_init use MOM_generic_tracer, only : MOM_generic_tracer_stock, MOM_generic_tracer_min_max, MOM_generic_tracer_CS +use MOM_generic_tracer, only : register_MOM_generic_tracer_segments use pseudo_salt_tracer, only : register_pseudo_salt_tracer, initialize_pseudo_salt_tracer use pseudo_salt_tracer, only : pseudo_salt_tracer_column_physics, pseudo_salt_tracer_surface_state use pseudo_salt_tracer, only : pseudo_salt_stock, pseudo_salt_tracer_end, pseudo_salt_tracer_CS @@ -75,6 +76,7 @@ module MOM_tracer_flow_control public call_tracer_register, tracer_flow_control_init, call_tracer_set_forcing public call_tracer_column_fns, call_tracer_surface_state, call_tracer_stocks public call_tracer_flux_init, get_chl_from_model, tracer_flow_control_end +public call_tracer_register_obc_segments !> The control structure for orchestrating the calling of tracer packages type, public :: tracer_flow_control_CS ; private @@ -114,6 +116,7 @@ module MOM_tracer_flow_control contains + !> This subroutine carries out a series of calls to initialize the air-sea !! tracer fluxes, but it does not record the generated indicies, and it may !! be called _before_ the ocean model has been initialized and may be called @@ -163,7 +166,6 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(MOM_restart_CS), intent(inout) :: restart_CS !< A pointer to the restart control !! structure. - ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_flow_control" ! This module's name. @@ -357,6 +359,26 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag end subroutine tracer_flow_control_init +!> This subroutine calls all registered tracers to register their OBC segments +!! similar to register_temp_salt_segments for T&S +subroutine call_tracer_register_obc_segments(GV, param_file, CS, tr_Reg, OBC) + 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(tracer_flow_control_CS), pointer :: CS !< A pointer that is set to point to the + !! control structure for this module. + type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the + !! control structure for the tracer + !! advection and diffusion module. + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition + !! type specifies whether, where, + !! and what open boundary + !! conditions are used. + + if (CS%use_MOM_generic_tracer) & + call register_MOM_generic_tracer_segments(CS%MOM_generic_tracer_CSp, GV, OBC, tr_Reg, param_file) + +end subroutine call_tracer_register_obc_segments !> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, G, GV, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. From f92a4ab7911c108289569b2d781d4db598b3ebbb Mon Sep 17 00:00:00 2001 From: OlgaSergienko <39838355+OlgaSergienko@users.noreply.github.com> Date: Fri, 11 Nov 2022 13:04:44 -0500 Subject: [PATCH 033/629] Ice dynamics (#228) In this PR an option is added to use ice viscosity computed from the observed surface velocity, computed by the model and use a constant value (for debugging purposes). A new (char) parameter "ICE_VISCOSITY_COMPUTE" is introduced; its values can be "MODEL" (the ice viscosity computed by the model); "OBS" the ice viscosity is computed at the preprocessing step and read from a file (its name is defined by the parameter "ICE_STIFFNESS_FILE") into a variable with a name defined by "A_GLEN_VARNAME" parameter; "CONSANT" is a constant value defined by a parameter "A_GLEN". These changes are in MOM_ice_shelf_dynamics.F90. Minor changes are done to MOM_ice_shelf_initialize.F90 to correct units, scales. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 51 ++++++++++++++-------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 24 +++++----- 2 files changed, 45 insertions(+), 30 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 63ccc3d33c..e605f3e581 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -77,7 +77,8 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [C ~> degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. - real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity, often in [R L4 Z T-1 ~> kg m2 s-1]. + real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), + !! in [R L2 T-1 ~> kg m-1 s-1]. real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, !! often in [kg-1/3 m-1/3 s-1]. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. @@ -94,7 +95,7 @@ module MOM_ice_shelf_dynamics !! Sign convention: positive below sea-level, negative above. real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" - !! basal stress [R Z L2 T-1 ~> kg s-1]. + !! basal stress (Pa) [R L2 T-2 ~> Pa]. !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), !! units= Pa (m yr-1)-(n_basal_fric) @@ -117,6 +118,9 @@ module MOM_ice_shelf_dynamics real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. + character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally + !! according to Glen's flow law; is constant (for debugging purposes) + !! or using observed strain rates and read from a file logical :: GL_regularize !< Specifies whether to regularize the floatation condition !! at the grounding line as in Goldberg Holland Schoof 2009 integer :: n_sub_regularize @@ -261,7 +265,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate( CS%t_shelf(isd:ied,jsd:jed), source=-10.0*US%degC_to_C ) ! [C ~> degC] allocate( CS%ice_visc(isd:ied,jsd:jed), source=0.0 ) allocate( CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25 ) ! [Pa-3 s-1] - allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) + allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) ! [Pa] allocate( CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10 ) ! [Pa (m-1 s)^n_sliding] allocate( CS%OD_av(isd:ied,jsd:jed), source=0.0 ) allocate( CS%ground_frac(isd:ied,jsd:jed), source=0.0 ) @@ -429,6 +433,10 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & "If true, do not allow an ice shelf where prohibited by a mask.", & default=.false.) + call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & + "If MODEL, compute ice viscosity internally, if OBS read from a file,"//& + "if CONSTANT a constant value (for debugging).", & + default="MODEL") endif call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & @@ -581,7 +589,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_col_thick = register_diag_field('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & - 'vi-viscosity', 'Pa s-1 m', conversion=US%RL2_T2_to_Pa*US%L_T_to_m_s) !vertically integrated viscosity + 'vi-viscosity', 'Pa m s', conversion=US%RL2_T2_to_Pa*US%Z_to_m*US%T_to_s) !vertically integrated viscosity CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & 'taub', 'MPa', conversion=1e-6*US%RL2_T2_to_Pa) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & @@ -1961,13 +1969,12 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) endif if (CS%ground_frac(i,j) == 1) then -! neumann_val = (.5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) - neumann_val = .5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2 + neumann_val = (.5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) else neumann_val = (.5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2) endif - if ((CS%u_face_mask(I-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -1981,19 +1988,19 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val endif - if ((CS%u_face_mask(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif - if ((CS%v_face_mask(i,J-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif - if ((CS%v_face_mask(i,J) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2560,7 +2567,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, end subroutine apply_boundary_values -!> Update depth integrated viscosity, based on horizontal strain rates, and also update the +!> Update depth integrated viscosity, based on horizontal strain rates subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -2575,7 +2582,6 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve -! also this subroutine updates the nonlinear part of the basal traction ! this may be subject to change later... to make it "hybrid" ! real, dimension(SZDIB_(G),SZDJB_(G)) :: eII, ux, uy, vx, vy @@ -2609,8 +2615,8 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) do j=jsc,jec ; do i=isc,iec if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%AGlen_visc(i,j))**(-1./CS%n_glen) - + Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * (CS%AGlen_visc(i,j))**(-1./CS%n_glen) + ! Units of Aglen_visc [Pa-3 s-1] do iq=1,2 ; do jq=1,2 ux = ( (u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & @@ -2633,14 +2639,23 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) enddo ; enddo -! CS%ice_visc(i,j) =1e15*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) - endif + if (trim(CS%ice_viscosity_compute)=="CONSTANT") then + CS%ice_visc(i,j) =1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) + ! constant viscocity for debugging + elseif (trim(CS%ice_viscosity_compute)=="MODEL") then + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + elseif(trim(CS%ice_viscosity_compute)=="OBS") then + if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) =CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) + ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file + endif + endif enddo ; enddo deallocate(Phi) end subroutine calc_shelf_visc + +!> Update basal shear subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 618f0e66fe..2de064e93e 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -395,6 +395,8 @@ end subroutine initialize_ice_shelf_boundary_channel !> Initialize ice shelf flow from file subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& G, US, PF) +!subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,ice_visc,& +! G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The bed elevation [Z ~> m]. @@ -402,7 +404,6 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: float_cond !< An array indicating where the ice !! shelf is floating: 0 if floating, 1 if not. [nondim] @@ -450,14 +451,12 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& floatfr_varname = "float_frac" - !### I think that the following two lines should have ..., scale=US%m_s_to_L_T - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=1.0) - call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=1.0) -! call MOM_read_data(filename, trim(ice_visc_varname), ice_visc, G%Domain,position=CORNER,scale=1.0) + call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) filename = trim(inputdir)//trim(bed_topo_file) - call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.) + call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.0) end subroutine initialize_ice_flow_from_file @@ -543,11 +542,12 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, scale=1.0) - call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, scale=1.0) - !### I think that the following two lines should have ..., scale=US%m_s_to_L_T - call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=1.0) - call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=1.) + call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, & + scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, & + scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) + call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(umask_varname), umask, G%Domain, position=CORNER, scale=1.) call MOM_read_data(filename, trim(vmask_varname), vmask, G%Domain, position=CORNER, scale=1.) filename = trim(inputdir)//trim(icethick_file) @@ -615,7 +615,7 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) end subroutine -!> Initialize ice basal friction +!> Initialize ice-stiffness parameter subroutine initialize_ice_AGlen(AGlen, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & From f666a67cb5132d6ff5c2b31bd52c1469a3143429 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Sat, 12 Nov 2022 14:20:50 -0700 Subject: [PATCH 034/629] Rename module to hor_bnd_diffusion * Rename MOM_lateral_boundary_diffusion.F90 to MOM_hor_bnd_diffusion.F90. * Following the suggestion from a reviewer, MOM_lateral_boundary_diffusion has been renamed to MOM_hor_bnd_diffusion. Many submodules related to the 'old; lateral diffusion have been renamed throughout the code. LBD has been replaced to HBD. * Tested that answers for GMOM do not change. --- src/core/MOM_unit_tests.F90 | 2 +- src/tracer/MOM_lateral_boundary_diffusion.F90 | 1095 ----------------- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/tracer/MOM_tracer_hor_diff.F90 | 79 +- src/tracer/MOM_tracer_registry.F90 | 66 +- src/tracer/MOM_tracer_types.F90 | 30 +- 6 files changed, 82 insertions(+), 1192 deletions(-) delete mode 100644 src/tracer/MOM_lateral_boundary_diffusion.F90 diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 08f8dea634..b962606410 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -10,7 +10,7 @@ module MOM_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_diag_vkernels, only : diag_vkernels_unit_tests use MOM_random, only : random_unit_tests -use MOM_lateral_boundary_diffusion, only : near_boundary_unit_tests +use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests implicit none ; private diff --git a/src/tracer/MOM_lateral_boundary_diffusion.F90 b/src/tracer/MOM_lateral_boundary_diffusion.F90 deleted file mode 100644 index e7e47370e1..0000000000 --- a/src/tracer/MOM_lateral_boundary_diffusion.F90 +++ /dev/null @@ -1,1095 +0,0 @@ -!> Calculates and applies diffusive fluxes as a parameterization of lateral mixing (non-neutral) by -!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. - -module MOM_lateral_boundary_diffusion - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE -use MOM_checksums, only : hchksum -use MOM_domains, only : pass_var -use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_diag_mediator, only : post_data, register_diag_field -use MOM_diag_vkernels, only : reintegrate_column -use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_remapping, only : remapping_CS, initialize_remapping -use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h -use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme -use MOM_spatial_means, only : global_mass_integral -use MOM_tracer_registry, only : tracer_registry_type, tracer_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS -use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS -use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member -use MOM_io, only : stdout, stderr - -implicit none ; private - -public near_boundary_unit_tests, lateral_boundary_diffusion, lateral_boundary_diffusion_init -public boundary_k_range - -! Private parameters to avoid doing string comparisons for bottom or top boundary layer -integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary -integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary -#include - -!> Sets parameters for lateral boundary mixing module. -type, public :: lbd_CS ; private - logical :: debug !< If true, write verbose checksums for debugging. - integer :: deg !< Degree of polynomial reconstruction. - integer :: surface_boundary_scheme !< Which boundary layer scheme to use - !! 1. ePBL; 2. KPP - logical :: limiter !< Controls whether a flux limiter is applied in the - !! native grid (default is true). - logical :: limiter_remap !< Controls whether a flux limiter is applied in the - !! remapped grid (default is false). - logical :: linear !< If True, apply a linear transition at the base/top of the boundary. - !! The flux will be fully applied at k=k_min and zero at k=k_max. - 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. - type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration. - type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD. - type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD. - type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to - !! regulate the timing of diagnostic output. -end type lbd_CS - -! This include declares and sets the variable "version". -#include "version_variable.h" -character(len=40) :: mdl = "MOM_lateral_boundary_diffusion" !< Name of this module -integer :: id_clock_lbd !< CPU clock for lbd - -contains - -!> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be -!! needed for lateral boundary diffusion. -logical function lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, diabatic_CSp, CS) - type(time_type), target, intent(in) :: Time !< Time structure - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(param_file_type), intent(in) :: param_file !< Parameter file structure - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure - type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD - type(lbd_CS), pointer :: CS !< Lateral boundary mixing control structure - - ! local variables - character(len=80) :: string ! Temporary strings - logical :: boundary_extrap ! controls if boundary extrapolation is used in the LBD code - - if (ASSOCIATED(CS)) then - call MOM_error(FATAL, "lateral_boundary_diffusion_init called with associated control structure.") - return - endif - - ! Log this module and master switch for turning it on/off - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & - default=.false., do_not_log=.true.) - call log_version(param_file, mdl, version, & - "This module implements lateral diffusion of tracers near boundaries", & - all_default=.not.lateral_boundary_diffusion_init) - call get_param(param_file, mdl, "USE_LATERAL_BOUNDARY_DIFFUSION", lateral_boundary_diffusion_init, & - "If true, enables the lateral boundary tracer's diffusion module.", & - default=.false.) - if (.not. lateral_boundary_diffusion_init) return - - allocate(CS) - CS%diag => diag - CS%H_subroundoff = GV%H_subroundoff - call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) - call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) - - CS%surface_boundary_scheme = -1 - if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then - call MOM_error(FATAL,"Lateral boundary diffusion is true, but no valid boundary layer scheme was found") - endif - - ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mdl, "LBD_LINEAR_TRANSITION", CS%linear, & - "If True, apply a linear transition at the base/top of the boundary. \n"//& - "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) - call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & - "If True, apply a flux limiter in the native grid.", default=.true.) - call get_param(param_file, mdl, "APPLY_LIMITER_REMAP", CS%limiter_remap, & - "If True, apply a flux limiter in the remapped grid.", default=.false.) - call get_param(param_file, mdl, "LBD_BOUNDARY_EXTRAP", boundary_extrap, & - "Use boundary extrapolation in LBD code", & - default=.false.) - call get_param(param_file, mdl, "LBD_REMAPPING_SCHEME", string, & - "This sets the reconstruction scheme used "//& - "for vertical remapping for all variables. "//& - "It can be one of the following schemes: "//& - trim(remappingSchemesDoc), default=remappingDefaultScheme) - !### Revisit this hard-coded answer_date. - call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction=.false., check_remapping=.false., answer_date=20190101) - call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) - call get_param(param_file, mdl, "LBD_DEBUG", CS%debug, & - "If true, write out verbose debugging data in the LBD module.", & - default=.false.) - - id_clock_lbd = cpu_clock_id('(Ocean LBD)', grain=CLOCK_MODULE) - -end function lateral_boundary_diffusion_init - -!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. -!! Diffusion is applied using only information from neighboring cells, as follows: -!! 1) remap tracer to a z* grid (LBD grid) -!! 2) calculate diffusive tracer fluxes (F) in the LBD grid using a layer by layer approach -!! 3) remap fluxes to the native grid -!! 4) update tracer by adding the divergence of F -subroutine lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) - type(ocean_grid_type), intent(inout) :: 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts - !! (I_numitts in tracer_hordiff) [T ~> s] - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(lbd_CS), pointer :: CS !< Control structure for this module - - ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uFlx !< Zonal flux of tracer [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vFlx !< Meridional flux of tracer - !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport - !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport - !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic [conc T-1 ~> conc s-1] - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn - type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, - !! only used to compute tendencies. - real :: tracer_int_prev !< Globally integrated tracer before LBD is applied, in mks units [conc kg] - real :: tracer_int_end !< Integrated tracer after LBD is applied, in mks units [conc kg] - real :: Idt !< inverse of the time step [T-1 ~> s-1] - character(len=256) :: mesg !< Message for error messages. - integer :: i, j, k, m !< indices to loop over - - call cpu_clock_begin(id_clock_lbd) - Idt = 1./dt - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & - m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) - do m = 1,Reg%ntr - ! current tracer - tracer => Reg%tr(m) - - if (CS%debug) then - call hchksum(tracer%t, "before LBD "//tracer%name,G%HI) - endif - - ! for diagnostics - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 .or. CS%debug) then - tendency(:,:,:) = 0.0 - tracer_old(:,:,:) = tracer%t(:,:,:) - endif - - ! Diffusive fluxes in the i- and j-direction - uFlx(:,:,:) = 0. - vFlx(:,:,:) = 0. - - ! LBD layer by layer - do j=G%jsc,G%jec - do i=G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & - h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & - Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS) - endif - enddo - enddo - do J=G%jsc-1,G%jec - do i=G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - call fluxes_layer_method(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & - h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & - Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS) - endif - enddo - enddo - - ! Update the tracer fluxes - do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (G%mask2dT(i,j)>0.) then - tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & - G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) - - if (tracer%id_lbdxy_conc > 0 .or. tracer%id_lbdxy_cont > 0 .or. tracer%id_lbdxy_cont_2d > 0 ) then - tendency(i,j,k) = ((uFlx(I-1,j,k)-uFlx(I,j,k)) + (vFlx(i,J-1,k)-vFlx(i,J,k))) * & - G%IareaT(i,j) * Idt - endif - endif - enddo ; enddo ; enddo - - ! Do user controlled underflow of the tracer concentrations. - if (tracer%conc_underflow > 0.0) then - do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 - enddo ; enddo ; enddo - endif - - if (CS%debug) then - call hchksum(tracer%t, "after LBD "//tracer%name,G%HI) - ! tracer (native grid) integrated tracer amounts before and after LBD - tracer_int_prev = global_mass_integral(h, G, GV, tracer_old) - tracer_int_end = global_mass_integral(h, G, GV, tracer%t) - write(mesg,*) 'Total '//tracer%name//' before/after LBD:', tracer_int_prev, tracer_int_end - call MOM_mesg(mesg) - endif - - ! Post the tracer diagnostics - if (tracer%id_lbd_dfx>0) call post_data(tracer%id_lbd_dfx, uFlx(:,:,:)*Idt, CS%diag) - if (tracer%id_lbd_dfy>0) call post_data(tracer%id_lbd_dfy, vFlx(:,:,:)*Idt, CS%diag) - if (tracer%id_lbd_dfx_2d>0) then - uwork_2d(:,:) = 0. - do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec - uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) - enddo ; enddo ; enddo - call post_data(tracer%id_lbd_dfx_2d, uwork_2d, CS%diag) - endif - - if (tracer%id_lbd_dfy_2d>0) then - vwork_2d(:,:) = 0. - do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec - vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) - enddo ; enddo ; enddo - call post_data(tracer%id_lbd_dfy_2d, vwork_2d, CS%diag) - endif - - ! post tendency of tracer content - if (tracer%id_lbdxy_cont > 0) then - call post_data(tracer%id_lbdxy_cont, tendency, CS%diag) - endif - - ! post depth summed tendency for tracer content - if (tracer%id_lbdxy_cont_2d > 0) then - tendency_2d(:,:) = 0. - do j=G%jsc,G%jec ; do i=G%isc,G%iec - do k=1,GV%ke - tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) - enddo - enddo ; enddo - call post_data(tracer%id_lbdxy_cont_2d, tendency_2d, CS%diag) - endif - - ! post tendency of tracer concentration; this step must be - ! done after posting tracer content tendency, since we alter - ! the tendency array and its units. - if (tracer%id_lbdxy_conc > 0) then - do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + CS%H_subroundoff ) - enddo ; enddo ; enddo - call post_data(tracer%id_lbdxy_conc, tendency, CS%diag) - endif - - enddo - - call cpu_clock_end(id_clock_lbd) - -end subroutine lateral_boundary_diffusion - -!> Calculate the harmonic mean of two quantities -!! See \ref section_harmonic_mean. -real function harmonic_mean(h1,h2) - real :: h1 !< Scalar quantity - real :: h2 !< Scalar quantity - if (h1 + h2 == 0.) then - harmonic_mean = 0. - else - harmonic_mean = 2.*(h1*h2)/(h1+h2) - endif -end function harmonic_mean - -!> Returns the location of the minimum value in a 1D array -!! between indices s and e. -integer function find_minimum(x, s, e) - integer, intent(in) :: s !< start index - integer, intent(in) :: e !< end index - real, dimension(e), intent(in) :: x !< 1D array to be checked - - ! local variables - real :: minimum - integer :: location - integer :: i - - minimum = x(s) ! assume the first is the min - location = s ! record its position - do i = s+1, e ! start with next elements - if (x(i) < minimum) then ! if x(i) less than the min? - minimum = x(i) ! Yes, a new minimum found - location = i ! record its position - end if - enddo - find_minimum = location ! return the position -end function find_minimum - -!> Swaps the values of its two formal arguments. -subroutine swap(a, b) - real, intent(inout) :: a !< First value to be swaped - real, intent(inout) :: b !< Second value to be swaped - - ! local variables - real :: tmp - - tmp = a - a = b - b = tmp -end subroutine swap - -!> Receives a 1D array x and sorts it into ascending order. -subroutine sort(x, n) - integer, intent(in ) :: n !< # of pts in the array - real, dimension(n), intent(inout) :: x !< 1D array to be sorted - - ! local variables - integer :: i, location - - do i = 1, n-1 - location = find_minimum(x, i, n) ! find min from this to last - call swap(x(i), x(location)) ! swap this and the minimum - enddo -end subroutine sort - -!> Returns the unique values in a 1D array. -subroutine unique(val, n, val_unique, val_max) - integer, intent(in ) :: n !< # of pts in the array. - real, dimension(n), intent(in ) :: val !< 1D array to be checked. - real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values. - real, optional, intent(in ) :: val_max !< sets the maximum value in val_unique to - !! this value. - ! local variables - real, dimension(n) :: tmp - integer :: i, j, ii - real :: min_val, max_val - logical :: limit - - limit = .false. - if (present(val_max)) then - limit = .true. - if (val_max > MAXVAL(val)) then - if (is_root_pe()) write(*,*)'val_max, MAXVAL(val)',val_max, MAXVAL(val) - call MOM_error(FATAL,"Houston, we've had a problem in unique (val_max cannot be > MAXVAL(val))") - endif - endif - - tmp(:) = 0. - min_val = MINVAL(val)-1 - max_val = MAXVAL(val) - i = 0 - do while (min_valmin_val) - tmp(i) = min_val - enddo - ii = i - if (limit) then - do j=1,ii - if (tmp(j) <= val_max) i = j - enddo - endif - allocate(val_unique(i), source=tmp(1:i)) -end subroutine unique - - -!> Given layer thicknesses (and corresponding interfaces) and BLDs in two adjacent columns, -!! return a set of 1-d layer thicknesses whose interfaces cover all interfaces in the left -!! and right columns plus the two BLDs. This can be used to accurately remap tracer tendencies -!! in both columns. -subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) - integer, intent(in ) :: nk !< Number of layers [nondim] - real, dimension(nk), intent(in ) :: h_L !< Layer thicknesses in the left column [H ~> m or kg m-2] - real, dimension(nk), intent(in ) :: h_R !< Layer thicknesses in the right column [H ~> m or kg m-2] - real, intent(in ) :: hbl_L !< Thickness of the boundary layer in the left column - !! [H ~> m or kg m-2] - real, intent(in ) :: hbl_R !< Thickness of the boundary layer in the right column - !! [H ~> m or kg m-2] - real, intent(in ) :: H_subroundoff !< GV%H_subroundoff [H ~> m or kg m-2] - real, dimension(:), allocatable, intent(inout) :: h !< Combined thicknesses [H ~> m or kg m-2] - - ! Local variables - integer :: n !< Number of layers in eta_all - real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right coloumns - real, dimension(:), allocatable :: eta_all !< Combined interfaces in the left/right columns + hbl_L and hbl_R - real, dimension(:), allocatable :: eta_unique !< Combined interfaces (eta_L, eta_R), possibly hbl_L and hbl_R - real :: min_depth !< Minimum depth - real :: max_depth !< Maximum depth - real :: max_bld !< Deepest BLD - integer :: k, kk, nk1 !< loop indices (k and kk) and array size (nk1) - - n = (2*nk)+3 - allocate(eta_all(n)) - ! compute and merge interfaces - eta_L(:) = 0.0; eta_R(:) = 0.0; eta_all(:) = 0.0 - kk = 0 - do k=2,nk+1 - eta_L(k) = eta_L(k-1) + h_L(k-1) - eta_R(k) = eta_R(k-1) + h_R(k-1) - kk = kk + 2 - eta_all(kk) = eta_L(k) - eta_all(kk+1) = eta_R(k) - enddo - - ! add hbl_L and hbl_R into eta_all - eta_all(kk+2) = hbl_L - eta_all(kk+3) = hbl_R - - ! find maximum depth - min_depth = MIN(MAXVAL(eta_L), MAXVAL(eta_R)) - max_bld = MAX(hbl_L, hbl_R) - max_depth = MIN(min_depth, max_bld) - - ! sort eta_all - call sort(eta_all, n) - ! remove duplicates from eta_all and sets maximum depth - call unique(eta_all, n, eta_unique, max_depth) - - nk1 = SIZE(eta_unique) - allocate(h(nk1-1)) - do k=1,nk1-1 - h(k) = (eta_unique(k+1) - eta_unique(k)) + H_subroundoff - enddo -end subroutine merge_interfaces - -!> Calculates the maximum flux that can leave a cell and uses that to apply a -!! limiter to F_layer. -subroutine flux_limiter(F_layer, area_L, area_R, phi_L, phi_R, h_L, h_R) - real, intent(inout) :: F_layer !< Tracer flux to be checked [H L2 conc ~> m3 conc] - real, intent(in) :: area_L !< Area of left cell [L2 ~> m2] - real, intent(in) :: area_R !< Area of right cell [L2 ~> m2] - real, intent(in) :: h_L !< Thickness of left cell [H ~> m or kg m-2] - real, intent(in) :: h_R !< Thickness of right cell [H ~> m or kg m-2] - real, intent(in) :: phi_L !< Tracer concentration in the left cell [conc] - real, intent(in) :: phi_R !< Tracer concentration in the right cell [conc] - - ! local variables - real :: F_max !< maximum flux allowed - ! limit the flux to 0.2 of the tracer *gradient* - ! Why 0.2? - ! t=0 t=inf - ! 0 .2 - ! 0 1 0 .2.2.2 - ! 0 .2 - ! - F_max = -0.2 * ((area_R*(phi_R*h_R))-(area_L*(phi_L*h_L))) - - if ( SIGN(1.,F_layer) == SIGN(1., F_max)) then - ! Apply flux limiter calculated above - if (F_max >= 0.) then - F_layer = MIN(F_layer,F_max) - else - F_layer = MAX(F_layer,F_max) - endif - else - F_layer = 0.0 - endif -end subroutine flux_limiter - -!> Find the k-index range corresponding to the layers that are within the boundary-layer region -subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) - integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] - integer, intent(in ) :: nk !< Number of layers [nondim] - real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the column [H ~> m or kg m-2] - real, intent(in ) :: hbl !< Thickness of the boundary layer [H ~> m or kg m-2] - !! If surface, with respect to zbl_ref = 0. - !! If bottom, with respect to zbl_ref = SUM(h) - integer, intent( out) :: k_top !< Index of the first layer within the boundary - real, intent( out) :: zeta_top !< Distance from the top of a layer to the intersection of the - !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] - integer, intent( out) :: k_bot !< Index of the last layer within the boundary - real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth - !! (0 at top, 1 at bottom) [nondim] - ! Local variables - real :: htot ! Summed thickness [H ~> m or kg m-2] - integer :: k - ! Surface boundary layer - if ( boundary == SURFACE ) then - k_top = 1 - zeta_top = 0. - htot = 0. - k_bot = 1 - zeta_bot = 0. - if (hbl == 0.) return - if (hbl >= SUM(h(:))) then - k_bot = nk - zeta_bot = 1. - return - endif - do k=1,nk - htot = htot + h(k) - if ( htot >= hbl) then - k_bot = k - zeta_bot = 1 - (htot - hbl)/h(k) - return - endif - enddo - ! Bottom boundary layer - elseif ( boundary == BOTTOM ) then - k_top = nk - zeta_top = 1. - k_bot = nk - zeta_bot = 0. - htot = 0. - if (hbl == 0.) return - if (hbl >= SUM(h(:))) then - k_top = 1 - zeta_top = 1. - return - endif - do k=nk,1,-1 - htot = htot + h(k) - if (htot >= hbl) then - k_top = k - zeta_top = 1 - (htot - hbl)/h(k) - return - endif - enddo - else - call MOM_error(FATAL,"Houston, we've had a problem in boundary_k_range") - endif - -end subroutine boundary_k_range - -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method -subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, area_L, area_R, CS) - - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] - real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] - real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (right) [H ~> m or kg m-2] - real, dimension(ke), intent(in ) :: h_L !< Thicknesses in the native grid (left) [H ~> m or kg m-2] - real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] - real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] - real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step - !! at a velocity point [L2 ~> m2] - real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point - !! in the native grid [H L2 conc ~> m3 conc] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - type(lbd_CS), pointer :: CS !< Lateral diffusion control structure - - ! Local variables - real, allocatable :: dz_top(:) !< The LBD z grid to be created [H ~> m or kg m-2] - real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] - real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] - real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] - real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid - !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] - real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k - integer :: k_bot_min !< Minimum k-index for the bottom - integer :: k_bot_max !< Maximum k-index for the bottom - integer :: k_bot_diff !< Difference between bottom left and right k-indices - !integer :: k_top_max !< Minimum k-index for the top - !integer :: k_top_min !< Maximum k-index for the top - !integer :: k_top_diff !< Difference between top left and right k-indices - integer :: k_top_L, k_bot_L !< k-indices left native grid - integer :: k_top_R, k_bot_R !< k-indices right native grid - real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary - !! layer depth in the native grid [nondim] - real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary - !! layer depth in the native grid [nondim] - real :: wgt !< weight to be used in the linear transition to the interior [nondim] - real :: a !< coefficient to be used in the linear transition to the interior [nondim] - real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] - real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] - integer :: nk !< number of layers in the LBD grid - - F_layer(:) = 0.0 - if (hbl_L == 0. .or. hbl_R == 0.) then - return - endif - - ! Define vertical grid, dz_top - call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - nk = SIZE(dz_top) - - ! allocate arrays - allocate(phi_L_z(nk), source=0.0) - allocate(phi_R_z(nk), source=0.0) - allocate(F_layer_z(nk), source=0.0) - - ! remap tracer to dz_top - call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & - CS%H_subroundoff, CS%H_subroundoff) - call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & - CS%H_subroundoff, CS%H_subroundoff) - - ! Calculate vertical indices containing the boundary layer in dz_top - call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - - if (boundary == SURFACE) then - k_bot_min = MIN(k_bot_L, k_bot_R) - k_bot_max = MAX(k_bot_L, k_bot_R) - k_bot_diff = (k_bot_max - k_bot_min) - - ! tracer flux where the minimum BLD intersets layer - if ((CS%linear) .and. (k_bot_diff > 1)) then - ! apply linear decay at the base of hbl - do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) - if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & - phi_R_z(k), dz_top(k), dz_top(k)) - enddo - htot = 0.0 - do k = k_bot_min+1,k_bot_max, 1 - htot = htot + dz_top(k) - enddo - - a = -1.0/htot - htot = 0. - do k = k_bot_min+1,k_bot_max, 1 - wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt - htot = htot + dz_top(k) - if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & - phi_R_z(k), dz_top(k), dz_top(k)) - enddo - else - do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) - if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & - phi_R_z(k), dz_top(k), dz_top(k)) - enddo - endif - endif - -! TODO, boundary == BOTTOM -! if (boundary == BOTTOM) then -! ! TODO: GMM add option to apply linear decay -! k_top_max = MAX(k_top_L, k_top_R) -! ! make sure left and right k indices span same range -! if (k_top_max /= k_top_L) then -! k_top_L = k_top_max -! zeta_top_L = 1.0 -! endif -! if (k_top_max /= k_top_R) then -! k_top_R= k_top_max -! zeta_top_R = 1.0 -! endif -! -! ! tracer flux where the minimum BLD intersets layer -! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) -! -! do k = k_top_max+1,nk -! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) -! enddo -! endif - - ! thicknesses at velocity points - do k = 1,ke - h_vel(k) = harmonic_mean(h_L(k), h_R(k)) - enddo - - ! remap flux to h_vel (native grid) - call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) - - ! used to avoid fluxes below hbl - if (CS%linear) then - htot_max = MAX(hbl_L, hbl_R) - else - htot_max = MIN(hbl_L, hbl_R) - endif - - tmp1 = 0.0; tmp2 = 0.0 - do k = 1,ke - ! apply flux_limiter - if (CS%limiter .and. F_layer(k) /= 0.) then - call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), phi_R(k), h_L(k), h_R(k)) - endif - - ! if tracer point is below htot_max, set flux to zero - if (MAX(tmp1+(h_L(k)*0.5), tmp2+(h_R(k)*0.5)) > htot_max) then - F_layer(k) = 0. - endif - - tmp1 = tmp1 + h_L(k) - tmp2 = tmp2 + h_R(k) - enddo - - ! deallocated arrays - deallocate(dz_top) - deallocate(phi_L_z) - deallocate(phi_R_z) - deallocate(F_layer_z) - -end subroutine fluxes_layer_method - -!> Unit tests for near-boundary horizontal mixing -logical function near_boundary_unit_tests( verbose ) - logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests - - ! Local variables - integer, parameter :: nk = 2 ! Number of layers - real, dimension(nk+1) :: eta1 ! Updated interfaces with one extra value [m] - real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] - real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] - real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real :: khtr_u ! Horizontal diffusivities at U-point [m2 s-1] - real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] - real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] - character(len=120) :: test_name ! Title of the unit test - integer :: k_top ! Index of cell containing top of boundary - real :: zeta_top ! Nondimension position [nondim] - integer :: k_bot ! Index of cell containing bottom of boundary - real :: zeta_bot ! Nondimension position [nondim] - type(lbd_CS), pointer :: CS - - allocate(CS) - ! fill required fields in CS - CS%linear=.false. - call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& - check_reconstruction=.true., check_remapping=.true.) - call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) - CS%H_subroundoff = 1.0E-20 - CS%debug=.false. - CS%limiter=.false. - CS%limiter_remap=.false. - - near_boundary_unit_tests = .false. - write(stdout,*) '==== MOM_lateral_boundary_diffusion =======================' - - ! Unit tests for boundary_k_range - test_name = 'Surface boundary spans the entire top cell' - h_L = (/5.,5./) - call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) - - test_name = 'Surface boundary spans the entire column' - h_L = (/5.,5./) - call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) - - test_name = 'Bottom boundary spans the entire bottom cell' - h_L = (/5.,5./) - call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 1., 2, 0., test_name, verbose) - - test_name = 'Bottom boundary spans the entire column' - h_L = (/5.,5./) - call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 1., 2, 0., test_name, verbose) - - test_name = 'Surface boundary intersects second layer' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) - - test_name = 'Surface boundary intersects first layer' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) - - test_name = 'Surface boundary is deeper than column thickness' - h_L = (/10.,10./) - call boundary_k_range(SURFACE, nk, h_L, 21.0, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) - - test_name = 'Bottom boundary intersects first layer' - h_L = (/10.,10./) - call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 0., test_name, verbose) - - test_name = 'Bottom boundary intersects second layer' - h_L = (/10.,10./) - call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 0., test_name, verbose) - - if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed boundary_k_range' - - ! unit tests for sorting array and finding unique values - test_name = 'Sorting array' - eta1 = (/1., 0., 0.1/) - call sort(eta1, nk+1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+1, test_name, eta1, (/0., 0.1, 1./) ) - - test_name = 'Unique values' - call unique((/0., 1., 1., 2./), nk+2, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) - deallocate(h1) - - test_name = 'Unique values with maximum depth' - call unique((/0., 1., 1., 2., 3./), nk+3, h1, 2.) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) - deallocate(h1) - - if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed sort and unique' - - ! unit tests for merge_interfaces - test_name = 'h_L = h_R and BLD_L = BLD_R' - call merge_interfaces(nk, (/1., 2./), (/1., 2./), 1.5, 1.5, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, h1, (/1., 0.5/) ) - deallocate(h1) - - test_name = 'h_L = h_R and BLD_L /= BLD_R' - call merge_interfaces(nk, (/1., 2./), (/1., 2./), 0.5, 1.5, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+1, test_name, h1, (/0.5, 0.5, 0.5/) ) - deallocate(h1) - - test_name = 'h_L /= h_R and BLD_L = BLD_R' - call merge_interfaces(nk, (/1., 3./), (/2., 2./), 1.5, 1.5, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, h1, (/1., 0.5/) ) - deallocate(h1) - - test_name = 'h_L /= h_R and BLD_L /= BLD_R' - call merge_interfaces(nk, (/1., 3./), (/2., 2./), 0.5, 1.5, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+1, test_name, h1, (/0.5, 0.5, 0.5/) ) - deallocate(h1) - - test_name = 'Left deeper than right, h_L /= h_R and BLD_L /= BLD_R' - call merge_interfaces(nk, (/2., 3./), (/2., 2./), 1.0, 2.0, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) - deallocate(h1) - - test_name = 'Left has zero thickness, h_L /= h_R and BLD_L = BLD_R' - call merge_interfaces(nk, (/4., 0./), (/2., 2./), 2.0, 2.0, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk-1, test_name, h1, (/2./) ) - deallocate(h1) - - test_name = 'Left has zero thickness, h_L /= h_R and BLD_L /= BLD_R' - call merge_interfaces(nk, (/4., 0./), (/2., 2./), 1.0, 2.0, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) - deallocate(h1) - - test_name = 'Right has zero thickness, h_L /= h_R and BLD_L = BLD_R' - call merge_interfaces(nk, (/2., 2./), (/0., 4./), 2.0, 2.0, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk-1, test_name, h1, (/2./) ) - deallocate(h1) - - test_name = 'Right has zero thickness, h_L /= h_R and BLD_L /= BLD_R' - call merge_interfaces(nk, (/2., 2./), (/0., 4./), 1.0, 2.0, CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) - deallocate(h1) - - test_name = 'Right deeper than left, h_L /= h_R and BLD_L = BLD_R' - call merge_interfaces(nk+1, (/2., 2., 0./), (/2., 2., 1./), 4., 4., CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, h1, (/2., 2./) ) - deallocate(h1) - - test_name = 'Right and left small values at bottom, h_L /= h_R and BLD_L = BLD_R' - call merge_interfaces(nk+2, (/2., 2., 1., 1./), (/1., 1., .5, .5/), 3., 3., CS%H_subroundoff, h1) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 1., .5, .5/) ) - deallocate(h1) - - if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed merge interfaces' - - ! All cases in this section have hbl which are equal to the column thicknesses - test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' - hbl_L = 2.; hbl_R = 2. - h_L = (/2.,2./) ; h_R = (/2.,2./) - phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) ) - - test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' - hbl_L = 2.; hbl_R = 2. - h_L = (/2.,2./) ; h_R = (/2.,2./) - phi_L = (/2.,1./) ; phi_R = (/1.,1./) - khtr_u = 0.5 - call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) ) - - test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' - hbl_L = 2; hbl_R = 2 - h_L = (/1.,2./) ; h_R = (/1.,2./) - phi_L = (/0.,0./) ; phi_R = (/0.5,2./) - khtr_u = 2. - call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) - - test_name = 'Different hbl and different column thicknesses (zero gradient)' - hbl_L = 12; hbl_R = 20 - h_L = (/6.,6./) ; h_R = (/10.,10./) - phi_L = (/1.,1./) ; phi_R = (/1.,1./) - khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) - - test_name = 'Different hbl and different column thicknesses (gradient from left to right)' - - hbl_L = 15; hbl_R = 10. - h_L = (/10.,5./) ; h_R = (/10.,0./) - phi_L = (/1.,1./) ; phi_R = (/0.,0./) - khtr_u = 1. - call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - - near_boundary_unit_tests = near_boundary_unit_tests .or. & - test_layer_fluxes( verbose, nk, test_name, F_layer, (/10.,0.0/) ) - - if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed fluxes_layer_method' - -end function near_boundary_unit_tests - -!> Returns true if output of near-boundary unit tests does not match correct computed values -!! and conditionally writes results to stream -logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) - logical, intent(in) :: verbose !< If true, write results to stdout - character(len=80), intent(in) :: test_name !< Brief description of the unit test - integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] - real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] - ! Local variables - integer :: k - - test_layer_fluxes = .false. - do k=1,nk - if ( F_calc(k) /= F_ans(k) ) then - test_layer_fluxes = .true. - write(stdout,*) "MOM_lateral_boundary_diffusion, UNIT TEST FAILED: ", test_name - write(stdout,10) k, F_calc(k), F_ans(k) - elseif (verbose) then - write(stdout,10) k, F_calc(k), F_ans(k) - endif - enddo - -10 format("Layer=",i3," F_calc=",f20.16," F_ans",f20.16) -end function test_layer_fluxes - -!> Return true if output of unit tests for boundary_k_range does not match answers -logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& - k_bot_ans, zeta_bot_ans, test_name, verbose) - integer :: k_top !< Index of cell containing top of boundary - real :: zeta_top !< Nondimension position - integer :: k_bot !< Index of cell containing bottom of boundary - real :: zeta_bot !< Nondimension position - integer :: k_top_ans !< Index of cell containing top of boundary - real :: zeta_top_ans !< Nondimension position - integer :: k_bot_ans !< Index of cell containing bottom of boundary - real :: zeta_bot_ans !< Nondimension position - character(len=80) :: test_name !< Name of the unit test - logical :: verbose !< If true always print output - - test_boundary_k_range = k_top /= k_top_ans - test_boundary_k_range = test_boundary_k_range .or. (zeta_top /= zeta_top_ans) - test_boundary_k_range = test_boundary_k_range .or. (k_bot /= k_bot_ans) - test_boundary_k_range = test_boundary_k_range .or. (zeta_bot /= zeta_bot_ans) - - if (test_boundary_k_range) write(stdout,*) "UNIT TEST FAILED: ", test_name - if (test_boundary_k_range .or. verbose) then - write(stdout,20) "k_top", k_top, "k_top_ans", k_top_ans - write(stdout,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans - write(stdout,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans - write(stdout,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans - endif - - 20 format(A,"=",i3,1X,A,"=",i3) - 30 format(A,"=",f20.16,1X,A,"=",f20.16) - - -end function test_boundary_k_range - -!> \namespace mom_lateral_boundary_diffusion -!! -!! \section section_LBD The Lateral Boundary Diffusion (LBD) framework -!! -!! The LBD framework accounts for the effects of diabatic mesoscale fluxes -!! within surface and bottom boundary layers. Unlike the equivalent adiabatic -!! fluxes, which is applied along neutral density surfaces, LBD is purely -!! horizontal. To assure that diffusive fluxes are strictly horizontal -!! regardless of the vertical coordinate system, this method relies on -!! regridding/remapping techniques. -!! -!! The bottom boundary layer fluxes remain to be implemented, although some -!! of the steps needed to do so have already been added and tested. -!! -!! Boundary lateral diffusion is applied as follows: -!! -!! 1) remap tracer to a z* grid (LBD grid) -!! 2) calculate diffusive tracer fluxes (F) in the LBD grid using a layer by layer approach (@ref section_method) -!! 3) remap fluxes to the native grid -!! 4) update tracer by adding the divergence of F -!! -!! \subsection section_method Along layer approach -!! -!! Here diffusion is applied layer by layer using only information from neighboring cells. -!! -!! Step #1: define vertical grid using interfaces and surface boundary layers from left and right -!! columns (see merge_interfaces). -!! -!! Step #2: compute vertical indices containing boundary layer (boundary_k_range). -!! For the TOP boundary layer, these are: -!! -!! k_top, k_bot, zeta_top, zeta_bot -!! -!! Step #2: calculate the diffusive flux at each layer: -!! -!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] -!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness -!! in the left and right columns. -!! -!! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: -!! -!! If LBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay -!! linearly between the top interface of the layer containing the minimum boundary -!! layer depth (k_bot_min) and the lower interface of the layer containing the -!! maximum layer depth (k_bot_max). -!! -!! Step #4: remap the fluxes back to the native grid. This is done at velocity points, whose vertical grid -!! is determined using [harmonic mean](@ref section_harmonic_mean). To assure monotonicity, -!! tracer fluxes are limited so that 1) only down-gradient fluxes are applied, -!! and 2) the flux cannot be larger than F_max, which is defined using the tracer -!! gradient: -!! -!! \f[ F_{max} = -0.2 \times [(V_R(k) \times \phi_R(k)) - (V_L(k) \times \phi_L(k))], \f] -!! where V is the cell volume. Why 0.2? -!! t=0 t=inf -!! 0 .2 -!! 0 1 0 .2.2.2 -!! 0 .2 -!! -!! \subsection section_harmonic_mean Harmonic Mean -!! -!! The harmonic mean (HM) betwen h1 and h2 is defined as: -!! -!! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] -!! -end module MOM_lateral_boundary_diffusion diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 9ef59821e3..d09c3e2870 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -27,8 +27,8 @@ module MOM_neutral_diffusion use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member -use MOM_lateral_boundary_diffusion, only : boundary_k_range, SURFACE, BOTTOM use MOM_io, only : stdout, stderr +use MOM_hor_bnd_diffusion, only : boundary_k_range, SURFACE, BOTTOM implicit none ; private diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 1e0c80079c..bee9d2984b 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -3,32 +3,32 @@ module MOM_tracer_hor_diff ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, diag_ctrl -use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type -use MOM_domains, only : sum_across_PEs, max_across_PEs -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_domains, only : pass_vector -use MOM_debugging, only : hchksum, uvchksum -use MOM_diabatic_driver, only : diabatic_CS -use MOM_EOS, only : calculate_density, EOS_type, EOS_domain -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery -use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_lateral_mixing_coeffs, only : VarMix_CS -use MOM_MEKE_types, only : MEKE_type -use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end -use MOM_neutral_diffusion, only : neutral_diffusion_CS -use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion -use MOM_lateral_boundary_diffusion, only : lbd_CS, lateral_boundary_diffusion_init -use MOM_lateral_boundary_diffusion, only : lateral_boundary_diffusion -use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, diag_ctrl +use MOM_diag_mediator, only : register_diag_field, safe_alloc_ptr, time_type +use MOM_domains, only : sum_across_PEs, max_across_PEs +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_diabatic_driver, only : diabatic_CS +use MOM_EOS, only : calculate_density, EOS_type, EOS_domain +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_neutral_diffusion, only : neutral_diffusion_init, neutral_diffusion_end +use MOM_neutral_diffusion, only : neutral_diffusion_CS +use MOM_neutral_diffusion, only : neutral_diffusion_calc_coeffs, neutral_diffusion +use MOM_hor_bnd_diffusion, only : hbd_CS, hor_bnd_diffusion_init +use MOM_hor_bnd_diffusion, only : hor_bnd_diffusion, hor_bnd_diffusion_end +use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -59,13 +59,13 @@ module MOM_tracer_hor_diff !! the CFL limit is not violated. logical :: use_neutral_diffusion !< If true, use the neutral_diffusion module from within !! tracer_hor_diff. - logical :: use_lateral_boundary_diffusion !< If true, use the lateral_boundary_diffusion module from within + logical :: use_hor_bnd_diffusion !< If true, use the hor_bnd_diffusion module from within !! tracer_hor_diff. logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been !! exceeded type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. - type(lbd_CS), pointer :: lateral_boundary_diffusion_CSp => NULL() !< Control structure for - !! lateral boundary mixing. + type(hbd_CS), pointer :: hor_bnd_diffusion_CSp => NULL() !< Control structure for + !! horizontal boundary diffusion. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -386,9 +386,9 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif enddo - if (CS%use_lateral_boundary_diffusion) then + if (CS%use_hor_bnd_diffusion) then - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary mixing (tracer_hordiff)") + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)") call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) @@ -402,12 +402,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online enddo do itt=1,num_itts - if (CS%show_call_tree) call callTree_waypoint("Calling lateral boundary diffusion (tracer_hordiff)",itt) + if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)",itt) if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call lateral_boundary_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & - CS%lateral_boundary_diffusion_CSp) + call hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & + CS%hor_bnd_diffusion_CSp) enddo ! itt endif @@ -417,7 +417,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) ! We are assuming that neutral surfaces do not evolve (much) as a result of multiple - ! lateral diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() + !horizontal diffusion iterations. Otherwise the call to neutral_diffusion_calc_coeffs() ! would be inside the itt-loop. -AJA if (associated(tv%p_surf)) then @@ -1525,10 +1525,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic diabatic_CSp, CS%neutral_diffusion_CSp ) if (CS%use_neutral_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & "USE_NEUTRAL_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") - CS%use_lateral_boundary_diffusion = lateral_boundary_diffusion_init(Time, G, GV, param_file, diag, diabatic_CSp, & - CS%lateral_boundary_diffusion_CSp) - if (CS%use_lateral_boundary_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & - "USE_LATERAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") + CS%use_hor_bnd_diffusion = hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, & + CS%hor_bnd_diffusion_CSp) + if (CS%use_hor_bnd_diffusion .and. CS%Diffuse_ML_interior) call MOM_error(FATAL, "MOM_tracer_hor_diff: "// & + "USE_HORIZONTAL_BOUNDARY_DIFFUSION and DIFFUSE_ML_TO_INTERIOR are mutually exclusive!") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) @@ -1568,6 +1568,7 @@ subroutine tracer_hor_diff_end(CS) type(tracer_hor_diff_CS), pointer :: CS !< module control structure call neutral_diffusion_end(CS%neutral_diffusion_CSp) + call hor_bnd_diffusion_end(CS%hor_bnd_diffusion_CSp) if (associated(CS)) deallocate(CS) end subroutine tracer_hor_diff_end diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c3f5f64edf..3f8c9b5232 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -358,12 +358,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux" , & trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the horizontal boundary diffusion "//& "scheme", trim(flux_units), v_extensive=.true., y_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the horizontal boundary diffusion "//& "scheme", trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else @@ -381,12 +381,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesCvL, Time, "Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') - Tr%id_lbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx", & - diag%axesCuL, Time, "Lateral Boundary Diffusive Zonal Flux of "//trim(flux_longname), & + Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & + diag%axesCuL, Time, "Horizontal Boundary Diffusive Zonal Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & y_cell_method='sum') - Tr%id_lbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy", & - diag%axesCvL, Time, "Lateral Boundary Diffusive Meridional Flux of "//trim(flux_longname), & + Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & + diag%axesCvL, Time, "Horizontal Boundary Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, v_extensive=.true., conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') endif @@ -394,8 +394,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u if (Tr%id_ady > 0) call safe_alloc_ptr(Tr%ad_y,isd,ied,JsdB,JedB,nz) if (Tr%id_dfx > 0) call safe_alloc_ptr(Tr%df_x,IsdB,IedB,jsd,jed,nz) if (Tr%id_dfy > 0) call safe_alloc_ptr(Tr%df_y,isd,ied,JsdB,JedB,nz) - if (Tr%id_lbd_dfx > 0) call safe_alloc_ptr(Tr%lbd_dfx,IsdB,IedB,jsd,jed,nz) - if (Tr%id_lbd_dfy > 0) call safe_alloc_ptr(Tr%lbd_dfy,isd,ied,JsdB,JedB,nz) + if (Tr%id_hbd_dfx > 0) call safe_alloc_ptr(Tr%hbd_dfx,IsdB,IedB,jsd,jed,nz) + if (Tr%id_hbd_dfy > 0) call safe_alloc_ptr(Tr%hbd_dfy,isd,ied,JsdB,JedB,nz) Tr%id_adx_2d = register_diag_field("ocean_model", trim(shortnm)//"_adx_2d", & diag%axesCu1, Time, & @@ -415,22 +415,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u "Vertically Integrated Diffusive Meridional Flux of "//trim(flux_longname), & flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') - Tr%id_lbd_bulk_dfx = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffx", & - diag%axesCu1, Time, & - "Total Bulk Diffusive Zonal Flux of "//trim(flux_longname), & - flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - y_cell_method='sum') - Tr%id_lbd_bulk_dfy = register_diag_field("ocean_model", trim(shortnm)//"_lbd_bulk_diffy", & - diag%axesCv1, Time, & - "Total Bulk Diffusive Meridional Flux of "//trim(flux_longname), & - flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & - x_cell_method='sum') - Tr%id_lbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffx_2d", & - diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfx_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx_2d", & + diag%axesCu1, Time, "Vertically-integrated zonal diffusive flux from the horizontal boundary diffusion "//& "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & y_cell_method='sum') - Tr%id_lbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_lbd_diffy_2d", & - diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the lateral boundary diffusion "//& + Tr%id_hbd_dfy_2d = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy_2d", & + diag%axesCv1, Time, "Vertically-integrated meridional diffusive flux from the horizontal boundary diffusion "//& "scheme for "//trim(flux_longname), flux_units, conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T, & x_cell_method='sum') @@ -438,10 +428,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u if (Tr%id_ady_2d > 0) call safe_alloc_ptr(Tr%ad2d_y,isd,ied,JsdB,JedB) if (Tr%id_dfx_2d > 0) call safe_alloc_ptr(Tr%df2d_x,IsdB,IedB,jsd,jed) if (Tr%id_dfy_2d > 0) call safe_alloc_ptr(Tr%df2d_y,isd,ied,JsdB,JedB) - if (Tr%id_lbd_bulk_dfx > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_x,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_bulk_dfy > 0) call safe_alloc_ptr(Tr%lbd_bulk_df_y,isd,ied,JsdB,JedB) - if (Tr%id_lbd_dfx_2d > 0) call safe_alloc_ptr(Tr%lbd_dfx_2d,IsdB,IedB,jsd,jed) - if (Tr%id_lbd_dfy_2d > 0) call safe_alloc_ptr(Tr%lbd_dfy_2d,isd,ied,JsdB,JedB) + if (Tr%id_hbd_dfx_2d > 0) call safe_alloc_ptr(Tr%hbd_dfx_2d,IsdB,IedB,jsd,jed) + if (Tr%id_hbd_dfy_2d > 0) call safe_alloc_ptr(Tr%hbd_dfy_2d,isd,ied,JsdB,JedB) Tr%id_adv_xy = register_diag_field('ocean_model', trim(shortnm)//"_advection_xy", & diag%axesTL, Time, & @@ -466,7 +454,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u enddo ; enddo ; enddo endif - ! Neutral/Lateral diffusion convergence tendencies + ! Neutral/Horizontal diffusion convergence tendencies if (Tr%diag_form == 1) then Tr%id_dfxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_dfxy_cont_tendency', & diag%axesTL, Time, "Neutral diffusion tracer content tendency for "//trim(shortnm), & @@ -477,12 +465,12 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum') - Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) - Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral diffusion tracer content "//& + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion tracer content "//& "tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum') else @@ -503,13 +491,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u cmor_long_name=trim(cmor_var_lname), cmor_standard_name=trim(cmor_long_std(cmor_var_lname)), & x_cell_method='sum', y_cell_method='sum') - Tr%id_lbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer content tendency for "//trim(shortnm), & + Tr%id_hbdxy_cont = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency', & + diag%axesTL, Time, "Horizontal boundary diffusion tracer content tendency for "//trim(shortnm), & conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum', v_extensive=.true.) - Tr%id_lbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_cont_tendency_2d', & - diag%axesT1, Time, "Depth integrated lateral diffusion tracer "//& + Tr%id_hbdxy_cont_2d = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_cont_tendency_2d', & + diag%axesT1, Time, "Depth integrated horizontal boundary diffusion of tracer "//& "content tendency for "//trim(shortnm), conv_units, conversion=Tr%conv_scale*US%s_to_T, & x_cell_method='sum', y_cell_method='sum') endif @@ -517,8 +505,8 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u diag%axesTL, Time, "Neutral diffusion tracer concentration tendency for "//trim(shortnm), & trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) - Tr%id_lbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_lbdxy_conc_tendency', & - diag%axesTL, Time, "Lateral diffusion tracer concentration tendency for "//trim(shortnm), & + Tr%id_hbdxy_conc = register_diag_field("ocean_model", trim(shortnm)//'_hbdxy_conc_tendency', & + diag%axesTL, Time, "Horizontal diffusion tracer concentration tendency for "//trim(shortnm), & trim(units)//' s-1', conversion=Tr%conc_scale*US%s_to_T) var_lname = "Net time tendency for "//lowercase(flux_longname) diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index 51c4508db6..bdae8bcee9 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -27,20 +27,16 @@ module MOM_tracer_types real, dimension(:,:,:), pointer :: df_x => NULL() !< diagnostic array for x-diffusive tracer flux !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), pointer :: df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:,:), pointer :: lbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - !### These two arrays may be allocated but are never used. - real, dimension(:,:), pointer :: lbd_bulk_df_x => NULL() !< diagnostic array for x-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] - real, dimension(:,:), pointer :: lbd_bulk_df_y => NULL() !< diagnostic array for y-diffusive tracer flux - !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfx => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:,:), pointer :: hbd_dfy => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfx_2d => NULL() !< diagnostic array for x-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + real, dimension(:,:), pointer :: hbd_dfy_2d => NULL() !< diagnostic array for y-diffusive tracer flux + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] + !! [conc H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_x => NULL() !< diagnostic vertical sum x-diffusive flux !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:), pointer :: df2d_y => NULL() !< diagnostic vertical sum y-diffusive flux @@ -106,12 +102,12 @@ module MOM_tracer_types !>@{ Diagnostic IDs integer :: id_tr = -1, id_tr_post_horzn = -1 integer :: id_adx = -1, id_ady = -1, id_dfx = -1, id_dfy = -1 - integer :: id_lbd_bulk_dfx = -1, id_lbd_bulk_dfy = -1, id_lbd_dfx = -1, id_lbd_dfy = -1 - integer :: id_lbd_dfx_2d = -1 , id_lbd_dfy_2d = -1 + integer :: id_hbd_dfx = -1, id_hbd_dfy = -1 + integer :: id_hbd_dfx_2d = -1, id_hbd_dfy_2d = -1 integer :: id_adx_2d = -1, id_ady_2d = -1, id_dfx_2d = -1, id_dfy_2d = -1 integer :: id_adv_xy = -1, id_adv_xy_2d = -1 integer :: id_dfxy_cont = -1, id_dfxy_cont_2d = -1, id_dfxy_conc = -1 - integer :: id_lbdxy_cont = -1, id_lbdxy_cont_2d = -1, id_lbdxy_conc = -1 + integer :: id_hbdxy_cont = -1, id_hbdxy_cont_2d = -1, id_hbdxy_conc = -1 integer :: id_remap_conc = -1, id_remap_cont = -1, id_remap_cont_2d = -1 integer :: id_tendency = -1, id_trxh_tendency = -1, id_trxh_tendency_2d = -1 integer :: id_tr_vardec = -1 From c2a30839c25046983fdadfabccfd4c7c398a56eb Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Sat, 12 Nov 2022 14:32:32 -0700 Subject: [PATCH 035/629] Improve performance of hor_bnd_diffusion Build and store the HBD grid outside the tracer loop since the same grid is used in all tracers. This makes this module more computationaly efficient. A GMOM case run for 10 days and with 3 tracer is ~ 7.5 % faster. --- src/tracer/MOM_hor_bnd_diffusion.F90 | 1375 ++++++++++++++++++++++++++ 1 file changed, 1375 insertions(+) create mode 100644 src/tracer/MOM_hor_bnd_diffusion.F90 diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 new file mode 100644 index 0000000000..4b9bd5ca40 --- /dev/null +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -0,0 +1,1375 @@ +!> Calculates and applies diffusive fluxes as a parameterization of horizontal mixing (non-neutral) by +!! mesoscale eddies near the top and bottom (to be implemented) boundary layers of the ocean. + +module MOM_hor_bnd_diffusion + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE +use MOM_checksums, only : hchksum +use MOM_domains, only : pass_var +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_diag_mediator, only : post_data, register_diag_field +use MOM_diag_vkernels, only : reintegrate_column +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, is_root_pe +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_remapping, only : extract_member_remapping_CS, remapping_core_h +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme +use MOM_spatial_means, only : global_mass_integral +use MOM_tracer_registry, only : tracer_registry_type, tracer_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member +use MOM_io, only : stdout, stderr + +implicit none ; private + +public near_boundary_unit_tests, hor_bnd_diffusion, hor_bnd_diffusion_init +public boundary_k_range, hor_bnd_diffusion_end + +! Private parameters to avoid doing string comparisons for bottom or top boundary layer +integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary +#include + +!> Sets parameters for lateral boundary mixing module. +type, public :: hbd_CS ; private + logical :: debug !< If true, write verbose checksums for debugging. + integer :: deg !< Degree of polynomial reconstruction. + integer :: hbd_nk !< Maximum number of levels in the HBD grid [nondim] + integer :: surface_boundary_scheme !< Which boundary layer scheme to use + !! 1. ePBL; 2. KPP + logical :: limiter !< Controls whether a flux limiter is applied in the + !! native grid (default is true). + logical :: limiter_remap !< Controls whether a flux limiter is applied in the + !! remapped grid (default is false). + logical :: linear !< If True, apply a linear transition at the base/top of the boundary. + !! The flux will be fully applied at k=k_min and zero at k=k_max. + 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. + ! HBD dynamic grids + real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjecent to + !! u-points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: hbd_grd_v !< HBD thicknesses at t-points adjacent to + !! v-points (left and right) [H ~> m or kg m-2] + integer, allocatable, dimension(:,:) :: hbd_u_kmax !< Maximum vertical index in hbd_grd_u [nondim] + integer, allocatable, dimension(:,:) :: hbd_v_kmax !< Maximum vertical index in hbd_grd_v [nondim + type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD. + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD. + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to + !! regulate the timing of diagnostic output. +end type hbd_CS + +! This include declares and sets the variable "version". +#include "version_variable.h" +character(len=40) :: mdl = "MOM_hor_bnd_diffusion" !< Name of this module +integer :: id_clock_hbd !< CPU clock for hbd + +contains + +!> Initialization routine that reads runtime parameters and sets up pointers to other control structures that might be +!! needed for horizontal boundary diffusion. +logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diabatic_CSp, CS) + type(time_type), target, intent(in) :: Time !< Time structure + type(ocean_grid_type), intent(in) :: G !< Grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file structure + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(diabatic_CS), pointer :: diabatic_CSp !< KPP control structure needed to get BLD + type(hbd_CS), pointer :: CS !< Horizontal boundary mixing control structure + + ! local variables + character(len=80) :: string ! Temporary strings + logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + + if (ASSOCIATED(CS)) then + call MOM_error(FATAL, "hor_bnd_diffusion_init called with associated control structure.") + return + endif + + ! Log this module and master switch for turning it on/off + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & + default=.false., do_not_log=.true.) + call log_version(param_file, mdl, version, & + "This module implements horizontal diffusion of tracers near boundaries", & + all_default=.not.hor_bnd_diffusion_init) + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", hor_bnd_diffusion_init, & + "If true, enables the horizonal boundary tracer's diffusion module.", & + default=.false.) + if (.not. hor_bnd_diffusion_init) return + + allocate(CS) + CS%diag => diag + CS%H_subroundoff = GV%H_subroundoff + call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) + call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) + + ! max. number of vertical layers + CS%hbd_nk = 2 + (GV%ke*2) + ! allocate the hbd grids and k_max + allocate(CS%hbd_grd_u(SZIB_(G),SZJ_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_grd_v(SZI_(G),SZJB_(G),CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(SZIB_(G),SZJ_(G)), source=0) + allocate(CS%hbd_v_kmax(SZI_(G),SZJB_(G)), source=0) + + CS%surface_boundary_scheme = -1 + if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then + call MOM_error(FATAL,"Lateral boundary diffusion is true, but no valid boundary layer scheme was found") + endif + + ! Read all relevant parameters and write them to the model log. + call get_param(param_file, mdl, "HBD_LINEAR_TRANSITION", CS%linear, & + "If True, apply a linear transition at the base/top of the boundary. \n"//& + "The flux will be fully applied at k=k_min and zero at k=k_max.", default=.false.) + call get_param(param_file, mdl, "APPLY_LIMITER", CS%limiter, & + "If True, apply a flux limiter in the native grid.", default=.true.) + call get_param(param_file, mdl, "APPLY_LIMITER_REMAP", CS%limiter_remap, & + "If True, apply a flux limiter in the remapped grid.", default=.false.) + call get_param(param_file, mdl, "HBD_BOUNDARY_EXTRAP", boundary_extrap, & + "Use boundary extrapolation in HBD code", & + default=.false.) + call get_param(param_file, mdl, "HBD_REMAPPING_SCHEME", string, & + "This sets the reconstruction scheme used "//& + "for vertical remapping for all variables. "//& + "It can be one of the following schemes: "//& + trim(remappingSchemesDoc), default=remappingDefaultScheme) + !### Revisit this hard-coded answer_date. + call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& + check_reconstruction=.false., check_remapping=.false., answer_date=20190101) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & + "If true, write out verbose debugging data in the HBD module.", & + default=.false.) + + id_clock_hbd = cpu_clock_id('(Ocean HBD)', grain=CLOCK_MODULE) + +end function hor_bnd_diffusion_init + +!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. +!! Diffusion is applied using only information from neighboring cells, as follows: +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach +!! 3) remap fluxes to the native grid +!! 4) update tracer by adding the divergence of F +subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) + type(ocean_grid_type), intent(inout) :: 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(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) [T ~> s] + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(hbd_CS), pointer :: CS !< Control structure for this module + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uFlx !< Zonal flux of tracer [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vFlx !< Meridional flux of tracer + !! [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZIB_(G),SZJ_(G)) :: uwork_2d !< Layer summed u-flux transport + !! [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport + !! [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic [conc T-1 ~> conc s-1] + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn + type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, + !! only used to compute tendencies. + real :: tracer_int_prev !< Globally integrated tracer before HBD is applied, in mks units [conc kg] + real :: tracer_int_end !< Integrated tracer after HBD is applied, in mks units [conc kg] + real :: Idt !< inverse of the time step [T-1 ~> s-1] + character(len=256) :: mesg !< Message for error messages. + integer :: i, j, k, m !< indices to loop over + + call cpu_clock_begin(id_clock_hbd) + Idt = 1./dt + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & + m_to_MLD_units=GV%m_to_H) + call pass_var(hbl,G%Domain) + + ! build HBD grid + call hbd_grid(SURFACE, G, GV, hbl, h, CS) + + do m = 1,Reg%ntr + ! current tracer + tracer => Reg%tr(m) + + if (CS%debug) then + call hchksum(tracer%t, "before HBD "//tracer%name,G%HI) + endif + + ! for diagnostics + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 .or. CS%debug) then + tendency(:,:,:) = 0.0 + tracer_old(:,:,:) = tracer%t(:,:,:) + endif + + ! Diffusive fluxes in the i- and j-direction + uFlx(:,:,:) = 0. + vFlx(:,:,:) = 0. + + ! HBD layer by layer + do j=G%jsc,G%jec + do i=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call fluxes_layer_method(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & + h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & + Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & + CS%hbd_grd_u(I,j,:), CS) + ! call fluxes_layer_method_old(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & + ! h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & + ! Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS) + endif + enddo + enddo + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call fluxes_layer_method(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & + h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & + Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & + CS%hbd_grd_v(i,J,:), CS) + !call fluxes_layer_method_old(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & + ! h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & + ! Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS) + endif + enddo + enddo + + ! Update the tracer fluxes + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + tracer%t(i,j,k) = tracer%t(i,j,k) + (( (uFlx(I-1,j,k)-uFlx(I,j,k)) ) + ( (vFlx(i,J-1,k)-vFlx(i,J,k) ) ))* & + G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) + + if (tracer%id_hbdxy_conc > 0 .or. tracer%id_hbdxy_cont > 0 .or. tracer%id_hbdxy_cont_2d > 0 ) then + tendency(i,j,k) = ((uFlx(I-1,j,k)-uFlx(I,j,k)) + (vFlx(i,J-1,k)-vFlx(i,J,k))) * & + G%IareaT(i,j) * Idt + endif + endif + enddo ; enddo ; enddo + + ! Do user controlled underflow of the tracer concentrations. + if (tracer%conc_underflow > 0.0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo ; enddo ; enddo + endif + + if (CS%debug) then + call hchksum(tracer%t, "after HBD "//tracer%name,G%HI) + ! tracer (native grid) integrated tracer amounts before and after HBD + tracer_int_prev = global_mass_integral(h, G, GV, tracer_old) + tracer_int_end = global_mass_integral(h, G, GV, tracer%t) + write(mesg,*) 'Total '//tracer%name//' before/after HBD:', tracer_int_prev, tracer_int_end + call MOM_mesg(mesg) + endif + + ! Post the tracer diagnostics + if (tracer%id_hbd_dfx>0) call post_data(tracer%id_hbd_dfx, uFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfy>0) call post_data(tracer%id_hbd_dfy, vFlx(:,:,:)*Idt, CS%diag) + if (tracer%id_hbd_dfx_2d>0) then + uwork_2d(:,:) = 0. + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + uwork_2d(I,j) = uwork_2d(I,j) + (uFlx(I,j,k) * Idt) + enddo ; enddo ; enddo + call post_data(tracer%id_hbd_dfx_2d, uwork_2d, CS%diag) + endif + + if (tracer%id_hbd_dfy_2d>0) then + vwork_2d(:,:) = 0. + do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + vwork_2d(i,J) = vwork_2d(i,J) + (vFlx(i,J,k) * Idt) + enddo ; enddo ; enddo + call post_data(tracer%id_hbd_dfy_2d, vwork_2d, CS%diag) + endif + + ! post tendency of tracer content + if (tracer%id_hbdxy_cont > 0) then + call post_data(tracer%id_hbdxy_cont, tendency, CS%diag) + endif + + ! post depth summed tendency for tracer content + if (tracer%id_hbdxy_cont_2d > 0) then + tendency_2d(:,:) = 0. + do j=G%jsc,G%jec ; do i=G%isc,G%iec + do k=1,GV%ke + tendency_2d(i,j) = tendency_2d(i,j) + tendency(i,j,k) + enddo + enddo ; enddo + call post_data(tracer%id_hbdxy_cont_2d, tendency_2d, CS%diag) + endif + + ! post tendency of tracer concentration; this step must be + ! done after posting tracer content tendency, since we alter + ! the tendency array and its units. + if (tracer%id_hbdxy_conc > 0) then + do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + tendency(i,j,k) = tendency(i,j,k) / ( h(i,j,k) + CS%H_subroundoff ) + enddo ; enddo ; enddo + call post_data(tracer%id_hbdxy_conc, tendency, CS%diag) + endif + + enddo + + call cpu_clock_end(id_clock_hbd) + +end subroutine hor_bnd_diffusion + +!> Build the HBD grid where tracers will be rammaped to. +subroutine hbd_grid(boundary, G, GV, hbl, h, CS) + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + type(ocean_grid_type), intent(inout) :: G !< Grid type + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: k_bot_min, k_bot_max !< k-indices min and max, respectively. + integer :: k_bot_L, k_bot_R !< k-indices for left and right columns, respectively. + integer :: k_bot_diff !< different between left and right k-indices. + integer :: k_top, k_bot !< indices used to store position of maximum isopycnal slope. + real :: zeta_top !< distance from the top of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: zeta_bot !< distance from the bottom of a layer to the boundary + !! layer depth in the native grid [nondim] + integer :: nk, i, j, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(:,:,:) = 0.0 !CS%H_subroundoff + CS%hbd_grd_v(:,:,:) = 0.0 !CS%H_subroundoff + CS%hbd_u_kmax(:,:) = 0 + CS%hbd_v_kmax(:,:) = 0 + + do j=G%jsc,G%jec + do I=G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + call merge_interfaces(GV%ke, h(I,j,:), h(I+1,j,:), hbl(I,j), hbl(I+1,j), & + CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, u-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(I,j) = nk + !CS%hbd_u_kmax(I,j) = CS%hbd_nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(I,j,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + + do J=G%jsc-1,G%jec + do i=G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + call merge_interfaces(GV%ke, h(i,J,:), h(i,J+1,:), hbl(i,J), hbl(i,J+1), & + CS%H_subroundoff, dz_top) + + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid, v-points (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_v_kmax(i,J) = nk + !CS%hbd_v_kmax(i,J) = CS%hbd_nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_v(i,J,k) = dz_top(k) + enddo + deallocate(dz_top) + endif + enddo + enddo + +end subroutine hbd_grid + +!> Calculate the harmonic mean of two quantities +!! See \ref section_harmonic_mean. +real function harmonic_mean(h1,h2) + real :: h1 !< Scalar quantity + real :: h2 !< Scalar quantity + if (h1 + h2 == 0.) then + harmonic_mean = 0. + else + harmonic_mean = 2.*(h1*h2)/(h1+h2) + endif +end function harmonic_mean + +!> Returns the location of the minimum value in a 1D array +!! between indices s and e. +integer function find_minimum(x, s, e) + integer, intent(in) :: s !< start index + integer, intent(in) :: e !< end index + real, dimension(e), intent(in) :: x !< 1D array to be checked + + ! local variables + real :: minimum + integer :: location + integer :: i + + minimum = x(s) ! assume the first is the min + location = s ! record its position + do i = s+1, e ! start with next elements + if (x(i) < minimum) then ! if x(i) less than the min? + minimum = x(i) ! Yes, a new minimum found + location = i ! record its position + end if + enddo + find_minimum = location ! return the position +end function find_minimum + +!> Swaps the values of its two formal arguments. +subroutine swap(a, b) + real, intent(inout) :: a !< First value to be swaped + real, intent(inout) :: b !< Second value to be swaped + + ! local variables + real :: tmp + + tmp = a + a = b + b = tmp +end subroutine swap + +!> Receives a 1D array x and sorts it into ascending order. +subroutine sort(x, n) + integer, intent(in ) :: n !< # of pts in the array + real, dimension(n), intent(inout) :: x !< 1D array to be sorted + + ! local variables + integer :: i, location + + do i = 1, n-1 + location = find_minimum(x, i, n) ! find min from this to last + call swap(x(i), x(location)) ! swap this and the minimum + enddo +end subroutine sort + +!> Returns the unique values in a 1D array. +subroutine unique(val, n, val_unique, val_max) + integer, intent(in ) :: n !< # of pts in the array. + real, dimension(n), intent(in ) :: val !< 1D array to be checked. + real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values. + real, optional, intent(in ) :: val_max !< sets the maximum value in val_unique to + !! this value. + ! local variables + real, dimension(n) :: tmp + integer :: i, j, ii + real :: min_val, max_val + logical :: limit + + limit = .false. + if (present(val_max)) then + limit = .true. + if (val_max > MAXVAL(val)) then + if (is_root_pe()) write(*,*)'val_max, MAXVAL(val)',val_max, MAXVAL(val) + call MOM_error(FATAL,"Houston, we've had a problem in unique (val_max cannot be > MAXVAL(val))") + endif + endif + + tmp(:) = 0. + min_val = MINVAL(val)-1 + max_val = MAXVAL(val) + i = 0 + do while (min_valmin_val) + tmp(i) = min_val + enddo + ii = i + if (limit) then + do j=1,ii + if (tmp(j) <= val_max) i = j + enddo + endif + allocate(val_unique(i), source=tmp(1:i)) +end subroutine unique + + +!> Given layer thicknesses (and corresponding interfaces) and BLDs in two adjacent columns, +!! return a set of 1-d layer thicknesses whose interfaces cover all interfaces in the left +!! and right columns plus the two BLDs. This can be used to accurately remap tracer tendencies +!! in both columns. +subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) + integer, intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h_L !< Layer thicknesses in the left column [H ~> m or kg m-2] + real, dimension(nk), intent(in ) :: h_R !< Layer thicknesses in the right column [H ~> m or kg m-2] + real, intent(in ) :: hbl_L !< Thickness of the boundary layer in the left column + !! [H ~> m or kg m-2] + real, intent(in ) :: hbl_R !< Thickness of the boundary layer in the right column + !! [H ~> m or kg m-2] + real, intent(in ) :: H_subroundoff !< GV%H_subroundoff [H ~> m or kg m-2] + real, dimension(:), allocatable, intent(inout) :: h !< Combined thicknesses [H ~> m or kg m-2] + + ! Local variables + integer :: n !< Number of layers in eta_all + real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right coloumns + real, dimension(:), allocatable :: eta_all !< Combined interfaces in the left/right columns + hbl_L and hbl_R + real, dimension(:), allocatable :: eta_unique !< Combined interfaces (eta_L, eta_R), possibly hbl_L and hbl_R + real :: min_depth !< Minimum depth + real :: max_depth !< Maximum depth + real :: max_bld !< Deepest BLD + integer :: k, kk, nk1 !< loop indices (k and kk) and array size (nk1) + + n = (2*nk)+3 + allocate(eta_all(n)) + ! compute and merge interfaces + eta_L(:) = 0.0; eta_R(:) = 0.0; eta_all(:) = 0.0 + kk = 0 + do k=2,nk+1 + eta_L(k) = eta_L(k-1) + h_L(k-1) + eta_R(k) = eta_R(k-1) + h_R(k-1) + kk = kk + 2 + eta_all(kk) = eta_L(k) + eta_all(kk+1) = eta_R(k) + enddo + + ! add hbl_L and hbl_R into eta_all + eta_all(kk+2) = hbl_L + eta_all(kk+3) = hbl_R + + ! find maximum depth + min_depth = MIN(MAXVAL(eta_L), MAXVAL(eta_R)) + max_bld = MAX(hbl_L, hbl_R) + max_depth = MIN(min_depth, max_bld) + + ! sort eta_all + call sort(eta_all, n) + ! remove duplicates from eta_all and sets maximum depth + call unique(eta_all, n, eta_unique, max_depth) + + nk1 = SIZE(eta_unique) + allocate(h(nk1-1)) + do k=1,nk1-1 + h(k) = (eta_unique(k+1) - eta_unique(k)) + H_subroundoff + enddo +end subroutine merge_interfaces + +!> Calculates the maximum flux that can leave a cell and uses that to apply a +!! limiter to F_layer. +subroutine flux_limiter(F_layer, area_L, area_R, phi_L, phi_R, h_L, h_R) + real, intent(inout) :: F_layer !< Tracer flux to be checked [H L2 conc ~> m3 conc] + real, intent(in) :: area_L !< Area of left cell [L2 ~> m2] + real, intent(in) :: area_R !< Area of right cell [L2 ~> m2] + real, intent(in) :: h_L !< Thickness of left cell [H ~> m or kg m-2] + real, intent(in) :: h_R !< Thickness of right cell [H ~> m or kg m-2] + real, intent(in) :: phi_L !< Tracer concentration in the left cell [conc] + real, intent(in) :: phi_R !< Tracer concentration in the right cell [conc] + + ! local variables + real :: F_max !< maximum flux allowed + ! limit the flux to 0.2 of the tracer *gradient* + ! Why 0.2? + ! t=0 t=inf + ! 0 .2 + ! 0 1 0 .2.2.2 + ! 0 .2 + ! + F_max = -0.2 * ((area_R*(phi_R*h_R))-(area_L*(phi_L*h_L))) + + if ( SIGN(1.,F_layer) == SIGN(1., F_max)) then + ! Apply flux limiter calculated above + if (F_max >= 0.) then + F_layer = MIN(F_layer,F_max) + else + F_layer = MAX(F_layer,F_max) + endif + else + F_layer = 0.0 + endif +end subroutine flux_limiter + +!> Find the k-index range corresponding to the layers that are within the boundary-layer region +subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_bot) + integer, intent(in ) :: boundary !< SURFACE or BOTTOM [nondim] + integer, intent(in ) :: nk !< Number of layers [nondim] + real, dimension(nk), intent(in ) :: h !< Layer thicknesses of the column [H ~> m or kg m-2] + real, intent(in ) :: hbl !< Thickness of the boundary layer [H ~> m or kg m-2] + !! If surface, with respect to zbl_ref = 0. + !! If bottom, with respect to zbl_ref = SUM(h) + integer, intent( out) :: k_top !< Index of the first layer within the boundary + real, intent( out) :: zeta_top !< Distance from the top of a layer to the intersection of the + !! top extent of the boundary layer (0 at top, 1 at bottom) [nondim] + integer, intent( out) :: k_bot !< Index of the last layer within the boundary + real, intent( out) :: zeta_bot !< Distance of the lower layer to the boundary layer depth + !! (0 at top, 1 at bottom) [nondim] + ! Local variables + real :: htot ! Summed thickness [H ~> m or kg m-2] + integer :: k + ! Surface boundary layer + if ( boundary == SURFACE ) then + k_top = 1 + zeta_top = 0. + htot = 0. + k_bot = 1 + zeta_bot = 0. + if (hbl == 0.) return + if (hbl >= SUM(h(:))) then + k_bot = nk + zeta_bot = 1. + return + endif + do k=1,nk + htot = htot + h(k) + if ( htot >= hbl) then + k_bot = k + zeta_bot = 1 - (htot - hbl)/h(k) + return + endif + enddo + ! Bottom boundary layer + elseif ( boundary == BOTTOM ) then + k_top = nk + zeta_top = 1. + k_bot = nk + zeta_bot = 0. + htot = 0. + if (hbl == 0.) return + if (hbl >= SUM(h(:))) then + k_top = 1 + zeta_top = 1. + return + endif + do k=nk,1,-1 + htot = htot + h(k) + if (htot >= hbl) then + k_top = k + zeta_top = 1 - (htot - hbl)/h(k) + return + endif + enddo + else + call MOM_error(FATAL,"Houston, we've had a problem in boundary_k_range") + endif + +end subroutine boundary_k_range + +!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. +!! See \ref section_method +subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, area_L, area_R, nk, dz_top, CS) + + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] + real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + !! layer (left) [H ~> m or kg m-2] + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary + !! layer (right) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: h_L !< Thicknesses in the native grid (left) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] + real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step + !! at a velocity point [L2 ~> m2] + real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! in the native grid [H L2 conc ~> m3 conc] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + integer, intent(in ) :: nk !< Number of layers in the HBD grid [nondim] + real, dimension(nk), intent(in ) :: dz_top !< The HBD z grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Lateral diffusion control structure + + ! Local variables + real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] + real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] + real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] + real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid + !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] + real :: htot !< Total column thickness [H ~> m or kg m-2] + integer :: k + integer :: k_bot_min !< Minimum k-index for the bottom + integer :: k_bot_max !< Maximum k-index for the bottom + integer :: k_bot_diff !< Difference between bottom left and right k-indices + !integer :: k_top_max !< Minimum k-index for the top + !integer :: k_top_min !< Maximum k-index for the top + !integer :: k_top_diff !< Difference between top left and right k-indices + integer :: k_top_L, k_bot_L !< k-indices left native grid + integer :: k_top_R, k_bot_R !< k-indices right native grid + real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: wgt !< weight to be used in the linear transition to the interior [nondim] + real :: a !< coefficient to be used in the linear transition to the interior [nondim] + real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] + real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] + + F_layer(:) = 0.0 + if (hbl_L == 0. .or. hbl_R == 0.) then + return + endif + + ! allocate arrays + allocate(phi_L_z(nk), source=0.0) + allocate(phi_R_z(nk), source=0.0) + allocate(F_layer_z(nk), source=0.0) + + ! remap tracer to dz_top + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + + ! Calculate vertical indices containing the boundary layer in dz_top + call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + + if (boundary == SURFACE) then + k_bot_min = MIN(k_bot_L, k_bot_R) + k_bot_max = MAX(k_bot_L, k_bot_R) + k_bot_diff = (k_bot_max - k_bot_min) + + ! tracer flux where the minimum BLD intersets layer + if ((CS%linear) .and. (k_bot_diff > 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + htot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + htot = htot + dz_top(k) + enddo + + a = -1.0/htot + htot = 0. + do k = k_bot_min+1,k_bot_max, 1 + wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt + htot = htot + dz_top(k) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + else + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + endif + endif + +! TODO, boundary == BOTTOM +! if (boundary == BOTTOM) then +! ! TODO: GMM add option to apply linear decay +! k_top_max = MAX(k_top_L, k_top_R) +! ! make sure left and right k indices span same range +! if (k_top_max /= k_top_L) then +! k_top_L = k_top_max +! zeta_top_L = 1.0 +! endif +! if (k_top_max /= k_top_R) then +! k_top_R= k_top_max +! zeta_top_R = 1.0 +! endif +! +! ! tracer flux where the minimum BLD intersets layer +! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) +! +! do k = k_top_max+1,nk +! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) +! enddo +! endif + + ! thicknesses at velocity points + do k = 1,ke + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + enddo + + ! remap flux to h_vel (native grid) + call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + + ! used to avoid fluxes below hbl + if (CS%linear) then + htot_max = MAX(hbl_L, hbl_R) + else + htot_max = MIN(hbl_L, hbl_R) + endif + + tmp1 = 0.0; tmp2 = 0.0 + do k = 1,ke + ! apply flux_limiter + if (CS%limiter .and. F_layer(k) /= 0.) then + call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), phi_R(k), h_L(k), h_R(k)) + endif + + ! if tracer point is below htot_max, set flux to zero + if (MAX(tmp1+(h_L(k)*0.5), tmp2+(h_R(k)*0.5)) > htot_max) then + F_layer(k) = 0. + endif + + tmp1 = tmp1 + h_L(k) + tmp2 = tmp2 + h_R(k) + enddo + + ! deallocated arrays + deallocate(phi_L_z) + deallocate(phi_R_z) + deallocate(F_layer_z) + +end subroutine fluxes_layer_method + +!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. +!! See \ref section_method +subroutine fluxes_layer_method_old(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, area_L, area_R, CS) + + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] + real, intent(in ) :: hbl_L !< Thickness of the boundary boundary + !! layer (left) [H ~> m or kg m-2] + real, intent(in ) :: hbl_R !< Thickness of the boundary boundary + !! layer (right) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: h_L !< Thicknesses in the native grid (left) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] + real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] + real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] + real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step + !! at a velocity point [L2 ~> m2] + real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point + !! in the native grid [H L2 conc ~> m3 conc] + real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] + real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] + type(hbd_CS), pointer :: CS !< Lateral diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< The HBD z grid to be created [H ~> m or kg m-2] + real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] + real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] + real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] + real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid + !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] + real :: htot !< Total column thickness [H ~> m or kg m-2] + integer :: k + integer :: k_bot_min !< Minimum k-index for the bottom + integer :: k_bot_max !< Maximum k-index for the bottom + integer :: k_bot_diff !< Difference between bottom left and right k-indices + !integer :: k_top_max !< Minimum k-index for the top + !integer :: k_top_min !< Maximum k-index for the top + !integer :: k_top_diff !< Difference between top left and right k-indices + integer :: k_top_L, k_bot_L !< k-indices left native grid + integer :: k_top_R, k_bot_R !< k-indices right native grid + real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary + !! layer depth in the native grid [nondim] + real :: wgt !< weight to be used in the linear transition to the interior [nondim] + real :: a !< coefficient to be used in the linear transition to the interior [nondim] + real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] + real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] + integer :: nk !< number of layers in the HBD grid + + F_layer(:) = 0.0 + if (hbl_L == 0. .or. hbl_R == 0.) then + return + endif + + ! Define vertical grid, dz_top + call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + + ! allocate arrays + allocate(phi_L_z(nk), source=0.0) + allocate(phi_R_z(nk), source=0.0) + allocate(F_layer_z(nk), source=0.0) + + ! remap tracer to dz_top + call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + + ! Calculate vertical indices containing the boundary layer in dz_top + call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) + call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) + + if (boundary == SURFACE) then + k_bot_min = MIN(k_bot_L, k_bot_R) + k_bot_max = MAX(k_bot_L, k_bot_R) + k_bot_diff = (k_bot_max - k_bot_min) + + ! tracer flux where the minimum BLD intersets layer + if ((CS%linear) .and. (k_bot_diff > 1)) then + ! apply linear decay at the base of hbl + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + htot = 0.0 + do k = k_bot_min+1,k_bot_max, 1 + htot = htot + dz_top(k) + enddo + + a = -1.0/htot + htot = 0. + do k = k_bot_min+1,k_bot_max, 1 + wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt + htot = htot + dz_top(k) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + else + do k = k_bot_min,1,-1 + F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & + phi_R_z(k), dz_top(k), dz_top(k)) + enddo + endif + endif + +! TODO, boundary == BOTTOM +! if (boundary == BOTTOM) then +! ! TODO: GMM add option to apply linear decay +! k_top_max = MAX(k_top_L, k_top_R) +! ! make sure left and right k indices span same range +! if (k_top_max /= k_top_L) then +! k_top_L = k_top_max +! zeta_top_L = 1.0 +! endif +! if (k_top_max /= k_top_R) then +! k_top_R= k_top_max +! zeta_top_R = 1.0 +! endif +! +! ! tracer flux where the minimum BLD intersets layer +! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) +! +! do k = k_top_max+1,nk +! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) +! enddo +! endif + + ! thicknesses at velocity points + do k = 1,ke + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + enddo + + ! remap flux to h_vel (native grid) + call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) + + ! used to avoid fluxes below hbl + if (CS%linear) then + htot_max = MAX(hbl_L, hbl_R) + else + htot_max = MIN(hbl_L, hbl_R) + endif + + tmp1 = 0.0; tmp2 = 0.0 + do k = 1,ke + ! apply flux_limiter + if (CS%limiter .and. F_layer(k) /= 0.) then + call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), phi_R(k), h_L(k), h_R(k)) + endif + + ! if tracer point is below htot_max, set flux to zero + if (MAX(tmp1+(h_L(k)*0.5), tmp2+(h_R(k)*0.5)) > htot_max) then + F_layer(k) = 0. + endif + + tmp1 = tmp1 + h_L(k) + tmp2 = tmp2 + h_R(k) + enddo + + ! deallocated arrays + deallocate(dz_top) + deallocate(phi_L_z) + deallocate(phi_R_z) + deallocate(F_layer_z) + +end subroutine fluxes_layer_method_old + +!> Unit tests for near-boundary horizontal mixing +logical function near_boundary_unit_tests( verbose ) + logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests + + ! Local variables + integer, parameter :: nk = 2 ! Number of layers + real, dimension(nk+1) :: eta1 ! Updated interfaces with one extra value [m] + real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] + real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] + real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] + real :: khtr_u ! Horizontal diffusivities at U-point [m2 s-1] + real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] + real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] + character(len=120) :: test_name ! Title of the unit test + integer :: k_top ! Index of cell containing top of boundary + real :: zeta_top ! Nondimension position [nondim] + integer :: k_bot ! Index of cell containing bottom of boundary + real :: zeta_bot ! Nondimension position [nondim] + type(hbd_CS), pointer :: CS + + allocate(CS) + ! fill required fields in CS + CS%linear=.false. + call initialize_remapping( CS%remap_CS, 'PLM', boundary_extrapolation=.true. ,& + check_reconstruction=.true., check_remapping=.true.) + call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + CS%H_subroundoff = 1.0E-20 + CS%debug=.false. + CS%limiter=.false. + CS%limiter_remap=.false. + + near_boundary_unit_tests = .false. + write(stdout,*) '==== MOM_hor_bnd_diffusion =======================' + + ! Unit tests for boundary_k_range + test_name = 'Surface boundary spans the entire top cell' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 1., test_name, verbose) + + test_name = 'Surface boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(SURFACE, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary spans the entire bottom cell' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 5., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 1., 2, 0., test_name, verbose) + + test_name = 'Bottom boundary spans the entire column' + h_L = (/5.,5./) + call boundary_k_range(BOTTOM, nk, h_L, 10., k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 1., 2, 0., test_name, verbose) + + test_name = 'Surface boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 0.75, test_name, verbose) + + test_name = 'Surface boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 1, 0.25, test_name, verbose) + + test_name = 'Surface boundary is deeper than column thickness' + h_L = (/10.,10./) + call boundary_k_range(SURFACE, nk, h_L, 21.0, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0., 2, 1., test_name, verbose) + + test_name = 'Bottom boundary intersects first layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 17.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 1, 0.75, 2, 0., test_name, verbose) + + test_name = 'Bottom boundary intersects second layer' + h_L = (/10.,10./) + call boundary_k_range(BOTTOM, nk, h_L, 2.5, k_top, zeta_top, k_bot, zeta_bot) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, 2, 0.25, 2, 0., test_name, verbose) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed boundary_k_range' + + ! unit tests for sorting array and finding unique values + test_name = 'Sorting array' + eta1 = (/1., 0., 0.1/) + call sort(eta1, nk+1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, eta1, (/0., 0.1, 1./) ) + + test_name = 'Unique values' + call unique((/0., 1., 1., 2./), nk+2, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) + deallocate(h1) + + test_name = 'Unique values with maximum depth' + call unique((/0., 1., 1., 2., 3./), nk+3, h1, 2.) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0., 1., 2./) ) + deallocate(h1) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed sort and unique' + + ! unit tests for merge_interfaces + test_name = 'h_L = h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/1., 2./), (/1., 2./), 1.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 0.5/) ) + deallocate(h1) + + test_name = 'h_L = h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/1., 2./), (/1., 2./), 0.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0.5, 0.5, 0.5/) ) + deallocate(h1) + + test_name = 'h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/1., 3./), (/2., 2./), 1.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 0.5/) ) + deallocate(h1) + + test_name = 'h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/1., 3./), (/2., 2./), 0.5, 1.5, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+1, test_name, h1, (/0.5, 0.5, 0.5/) ) + deallocate(h1) + + test_name = 'Left deeper than right, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/2., 3./), (/2., 2./), 1.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) + deallocate(h1) + + test_name = 'Left has zero thickness, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/4., 0./), (/2., 2./), 2.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk-1, test_name, h1, (/2./) ) + deallocate(h1) + + test_name = 'Left has zero thickness, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/4., 0./), (/2., 2./), 1.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) + deallocate(h1) + + test_name = 'Right has zero thickness, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk, (/2., 2./), (/0., 4./), 2.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk-1, test_name, h1, (/2./) ) + deallocate(h1) + + test_name = 'Right has zero thickness, h_L /= h_R and BLD_L /= BLD_R' + call merge_interfaces(nk, (/2., 2./), (/0., 4./), 1.0, 2.0, CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/1., 1./) ) + deallocate(h1) + + test_name = 'Right deeper than left, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk+1, (/2., 2., 0./), (/2., 2., 1./), 4., 4., CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, h1, (/2., 2./) ) + deallocate(h1) + + test_name = 'Right and left small values at bottom, h_L /= h_R and BLD_L = BLD_R' + call merge_interfaces(nk+2, (/2., 2., 1., 1./), (/1., 1., .5, .5/), 3., 3., CS%H_subroundoff, h1) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk+2, test_name, h1, (/1., 1., .5, .5/) ) + deallocate(h1) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed merge interfaces' + + ! All cases in this section have hbl which are equal to the column thicknesses + test_name = 'Equal hbl and same layer thicknesses (gradient from right to left)' + hbl_L = 2.; hbl_R = 2. + h_L = (/2.,2./) ; h_R = (/2.,2./) + phi_L = (/0.,0./) ; phi_R = (/1.,1./) + khtr_u = 1. + call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) ) + + test_name = 'Equal hbl and same layer thicknesses (gradient from left to right)' + hbl_L = 2.; hbl_R = 2. + h_L = (/2.,2./) ; h_R = (/2.,2./) + phi_L = (/2.,1./) ; phi_R = (/1.,1./) + khtr_u = 0.5 + call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) ) + + test_name = 'hbl < column thickness, hbl same, linear profile right, khtr=2' + hbl_L = 2; hbl_R = 2 + h_L = (/1.,2./) ; h_R = (/1.,2./) + phi_L = (/0.,0./) ; phi_R = (/0.5,2./) + khtr_u = 2. + call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) + + test_name = 'Different hbl and different column thicknesses (zero gradient)' + hbl_L = 12; hbl_R = 20 + h_L = (/6.,6./) ; h_R = (/10.,10./) + phi_L = (/1.,1./) ; phi_R = (/1.,1./) + khtr_u = 1. + call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS) + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) + + test_name = 'Different hbl and different column thicknesses (gradient from left to right)' + + hbl_L = 15; hbl_R = 10. + h_L = (/10.,5./) ; h_R = (/10.,0./) + phi_L = (/1.,1./) ; phi_R = (/0.,0./) + khtr_u = 1. + call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS) + + near_boundary_unit_tests = near_boundary_unit_tests .or. & + test_layer_fluxes( verbose, nk, test_name, F_layer, (/10.,0.0/) ) + + if (.not. near_boundary_unit_tests) write(stdout,*) 'Passed fluxes_layer_method' + +end function near_boundary_unit_tests + +!> Returns true if output of near-boundary unit tests does not match correct computed values +!! and conditionally writes results to stream +logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) + logical, intent(in) :: verbose !< If true, write results to stdout + character(len=80), intent(in) :: test_name !< Brief description of the unit test + integer, intent(in) :: nk !< Number of layers + real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] + real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] + ! Local variables + integer :: k + + test_layer_fluxes = .false. + do k=1,nk + if ( F_calc(k) /= F_ans(k) ) then + test_layer_fluxes = .true. + write(stdout,*) "MOM_hor_bnd_diffusion, UNIT TEST FAILED: ", test_name + write(stdout,10) k, F_calc(k), F_ans(k) + elseif (verbose) then + write(stdout,10) k, F_calc(k), F_ans(k) + endif + enddo + +10 format("Layer=",i3," F_calc=",f20.16," F_ans",f20.16) +end function test_layer_fluxes + +!> Return true if output of unit tests for boundary_k_range does not match answers +logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& + k_bot_ans, zeta_bot_ans, test_name, verbose) + integer :: k_top !< Index of cell containing top of boundary + real :: zeta_top !< Nondimension position + integer :: k_bot !< Index of cell containing bottom of boundary + real :: zeta_bot !< Nondimension position + integer :: k_top_ans !< Index of cell containing top of boundary + real :: zeta_top_ans !< Nondimension position + integer :: k_bot_ans !< Index of cell containing bottom of boundary + real :: zeta_bot_ans !< Nondimension position + character(len=80) :: test_name !< Name of the unit test + logical :: verbose !< If true always print output + + test_boundary_k_range = k_top /= k_top_ans + test_boundary_k_range = test_boundary_k_range .or. (zeta_top /= zeta_top_ans) + test_boundary_k_range = test_boundary_k_range .or. (k_bot /= k_bot_ans) + test_boundary_k_range = test_boundary_k_range .or. (zeta_bot /= zeta_bot_ans) + + if (test_boundary_k_range) write(stdout,*) "UNIT TEST FAILED: ", test_name + if (test_boundary_k_range .or. verbose) then + write(stdout,20) "k_top", k_top, "k_top_ans", k_top_ans + write(stdout,20) "k_bot", k_bot, "k_bot_ans", k_bot_ans + write(stdout,30) "zeta_top", zeta_top, "zeta_top_ans", zeta_top_ans + write(stdout,30) "zeta_bot", zeta_bot, "zeta_bot_ans", zeta_bot_ans + endif + + 20 format(A,"=",i3,1X,A,"=",i3) + 30 format(A,"=",f20.16,1X,A,"=",f20.16) + + +end function test_boundary_k_range + +!> Deallocates hor_bnd_diffusion control structure +subroutine hor_bnd_diffusion_end(CS) + type(hbd_CS), pointer :: CS !< Horizontal boundary diffusion control structure + + if (associated(CS)) deallocate(CS) + +end subroutine hor_bnd_diffusion_end + +!> \namespace mom_hor_bnd_diffusion +!! +!! \section section_HBD The Horizontal Boundary Diffusion (HBD) framework +!! +!! The HBD framework accounts for the effects of diabatic mesoscale fluxes +!! within surface and bottom boundary layers. Unlike the equivalent adiabatic +!! fluxes, which is applied along neutral density surfaces, HBD is purely +!! horizontal. To assure that diffusive fluxes are strictly horizontal +!! regardless of the vertical coordinate system, this method relies on +!! regridding/remapping techniques. +!! +!! The bottom boundary layer fluxes remain to be implemented, although some +!! of the steps needed to do so have already been added and tested. +!! +!! Boundary lateral diffusion is applied as follows: +!! +!! 1) remap tracer to a z* grid (HBD grid) +!! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach (@ref section_method) +!! 3) remap fluxes to the native grid +!! 4) update tracer by adding the divergence of F +!! +!! \subsection section_method Along layer approach +!! +!! Here diffusion is applied layer by layer using only information from neighboring cells. +!! +!! Step #1: define vertical grid using interfaces and surface boundary layers from left and right +!! columns (see merge_interfaces). +!! +!! Step #2: compute vertical indices containing boundary layer (boundary_k_range). +!! For the TOP boundary layer, these are: +!! +!! k_top, k_bot, zeta_top, zeta_bot +!! +!! Step #2: calculate the diffusive flux at each layer: +!! +!! \f[ F_{k} = -KHTR \times h_{eff}(k) \times (\phi_R(k) - \phi_L(k)), \f] +!! where h_eff is the [harmonic mean](@ref section_harmonic_mean) of the layer thickness +!! in the left and right columns. +!! +!! Step #3: option to linearly decay the flux from k_bot_min to k_bot_max: +!! +!! If HBD_LINEAR_TRANSITION = True and k_bot_diff > 1, the diffusive flux will decay +!! linearly between the top interface of the layer containing the minimum boundary +!! layer depth (k_bot_min) and the lower interface of the layer containing the +!! maximum layer depth (k_bot_max). +!! +!! Step #4: remap the fluxes back to the native grid. This is done at velocity points, whose vertical grid +!! is determined using [harmonic mean](@ref section_harmonic_mean). To assure monotonicity, +!! tracer fluxes are limited so that 1) only down-gradient fluxes are applied, +!! and 2) the flux cannot be larger than F_max, which is defined using the tracer +!! gradient: +!! +!! \f[ F_{max} = -0.2 \times [(V_R(k) \times \phi_R(k)) - (V_L(k) \times \phi_L(k))], \f] +!! where V is the cell volume. Why 0.2? +!! t=0 t=inf +!! 0 .2 +!! 0 1 0 .2.2.2 +!! 0 .2 +!! +!! \subsection section_harmonic_mean Harmonic Mean +!! +!! The harmonic mean (HM) betwen h1 and h2 is defined as: +!! +!! \f[ HM = \frac{2 \times h1 \times h2}{h1 + h2} \f] +!! +end module MOM_hor_bnd_diffusion From 2b03f95adef2271271c8623fe21c693ce25c92ab Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Nov 2022 20:49:03 -0500 Subject: [PATCH 036/629] +Set input file variable names via runtime params Added calls to get_param to set 12 input variable names in files via runtime parameters, including TIDEAMP_VARNAME, TEMP_COORD_VAR, SALT_COORD_VAR, THICKNESS_IC_VAR, INTERFACE_IC_RESCALE, TEMP_IC_VAR, SALT_IC_VAR, BASIN_VAR, TIDAL_DISSIPATION_VAR, ROUGHNESS_VARNAME, TIDEAMP_VARNAME and KH_BG_2D_VARNAME. Also added two new runtime parameters, THICKNESS_IC_RESCALE and INTERFACE_IC_RESCALE, to allow input thickness and interface height fields to be rescaled. A number of spelling errors in comments or output messages in the files that were being modified as a part of this commit, including changes in the documentation that appears in MOM_parameter_doc files. All answers are bitwise identical, but there are new entries and minor changes in many MOM_parameter_doc files. --- src/ice_shelf/MOM_ice_shelf.F90 | 41 ++++---- .../MOM_coord_initialization.F90 | 20 ++-- .../MOM_state_initialization.F90 | 64 ++++++++---- src/ocean_data_assim/MOM_oda_driver.F90 | 16 +-- .../lateral/MOM_hor_visc.F90 | 33 ++++--- .../lateral/MOM_internal_tides.F90 | 98 +++++++------------ .../vertical/MOM_internal_tide_input.F90 | 17 +++- .../vertical/MOM_set_viscosity.F90 | 32 +++--- .../vertical/MOM_tidal_mixing.F90 | 66 ++++++++----- 9 files changed, 215 insertions(+), 172 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 26c74d73ec..1a29ef45e6 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -139,7 +139,7 @@ module MOM_ice_shelf real :: time_step !< this is the shortest timestep that the ice shelf sees [T ~> s], and !! is equal to the forcing timestep (it is passed in when the shelf !! is initialized - so need to reorganize MOM driver. - !! it will be the prognistic timestep ... maybe. + !! it will be the prognostic timestep ... maybe. logical :: solo_ice_sheet !< whether the ice model is running without being !! coupled to the ocean @@ -288,13 +288,13 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) real :: n_star_term ! A term in the expression for nstar [T3 Z-2 ~> s3 m-2] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: dIns_dwB !< The partial derivative of I_n_star with wB_flux, in [T3 Z-2 ~> s3 m-2] - real :: dT_ustar ! The difference between the the freezing point and the ocean boundary layer + real :: dT_ustar ! The difference between the freezing point and the ocean boundary layer ! temperature times the friction velocity [C Z T-1 ~> degC m s-1] real :: dS_ustar ! The difference between the salinity at the ice-ocean interface and the ocean ! boundary layer salinity times the friction velocity [S Z T-1 ~> ppt m s-1] real :: ustar_h ! The friction velocity in the water below the ice shelf [Z T-1 ~> m s-1] real :: Gam_turb ! [nondim] - real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivites [nondim] + real :: Gam_mol_t, Gam_mol_s ! Relative coefficients of molecular diffusivities [nondim] real :: RhoCp ! A typical ocean density times the heat capacity of water [Q R C-1 ~> J m-3 degC-1] real :: ln_neut real :: mass_exch ! A mass exchange rate [R Z T-1 ~> kg m-2 s-1] @@ -312,7 +312,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) real :: Irho0 ! The inverse of the mean density times a unit conversion factor [R-1 L Z-1 ~> m3 kg-1] logical :: Sb_min_set, Sb_max_set logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. - logical :: coupled_GL ! If true, the grouding line position is determined based on + logical :: coupled_GL ! If true, the grounding line position is determined based on ! coupled ice-ocean dynamics. real, parameter :: c2_3 = 2.0/3.0 @@ -524,7 +524,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) wB_flux = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux if (wB_flux < 0.0) then - ! The buoyancy flux is stabilizing and will reduce the tubulent + ! The buoyancy flux is stabilizing and will reduce the turbulent ! fluxes, and iteration is required. n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 do it3 = 1,30 @@ -572,9 +572,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) exch_vel_s(i,j) = ustar_h * I_Gam_S ! Calculate the heat flux inside the ice shelf. - ! Vertical adv/diff as in H+J 1999, eqns (26) & approx from (31). + ! Vertical adv/diff as in H+J 1999, equations (26) & approx from (31). ! Q_ice = density_ice * CS%Cp_ice * K_ice * dT/dz (at interface) - ! vertical adv/diff as in H+J 1999, eqs (31) & (26)... + ! vertical adv/diff as in H+J 1999, equations (31) & (26)... ! dT/dz ~= min( (lprec/(density_ice*K_ice))*(CS%Temp_Ice-T_freeze) , 0.0 ) ! If this approximation is not made, iterations are required... See H+J Fig 3. @@ -1012,7 +1012,7 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) real :: balancing_area !< total area where the balancing flux is applied [m2] type(time_type) :: dTime !< The time step as a time_type type(time_type) :: Time0 !< The previous time (Time-dt) - real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cel1 where the mass flux + real, dimension(SZDI_(G),SZDJ_(G)) :: bal_frac !< Fraction of the cell where the mass flux !! balancing the net melt flux occurs, 0 to 1 [nondim] real, dimension(SZDI_(G),SZDJ_(G)) :: last_mass_shelf !< Ice shelf mass !! at at previous time (Time-dt) [R Z ~> kg m-2] @@ -1235,13 +1235,14 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, logical :: new_sim, save_IC !This include declares and sets the variable "version". # include "version_variable.h" - character(len=200) :: IC_file, inputdir + character(len=200) :: IC_file, inputdir ! Input file names or paths character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) logical :: read_TideAmp, shelf_mass_is_dynamic, debug logical :: global_indexing - character(len=240) :: Tideamp_file + character(len=240) :: Tideamp_file ! Input file names + character(len=80) :: tideamp_var ! Input file variable names real :: utide ! A tidal velocity [L T-1 ~> m s-1] real :: col_thick_melt_thresh ! An ocean column thickness below which iceshelf melting ! does not occur [Z ~> m] @@ -1397,7 +1398,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "consistency to calculate the fluxes at the ice-ocean "//& "interface.", default=.true.) call get_param(param_file, mdl, "SHELF_INSULATOR", CS%insulator, & - "If true, the ice shelf is a perfect insulatior "//& + "If true, the ice shelf is a perfect insulator "//& "(no conduction).", default=.false.) call get_param(param_file, mdl, "MELTING_CUTOFF_DEPTH", CS%cutoff_depth, & "Depth above which the melt is set to zero (it must be >= 0) "//& @@ -1491,7 +1492,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, "The viscosity of the ice.", & units="m2 s-1", default=1.0e10, scale=US%Z_to_L**2*US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "KV_MOLECULAR", CS%kv_molec, & - "The molecular kinimatic viscosity of sea water at the freezing temperature.", & + "The molecular kinematic viscosity of sea water at the freezing temperature.", & units="m2 s-1", default=1.95e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "ICE_SHELF_SALINITY", CS%Salin_ice, & "The salinity of the ice inside the ice shelf.", & @@ -1537,19 +1538,21 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, if (read_TIDEAMP) then call get_param(param_file, mdl, "TIDEAMP_FILE", TideAmp_file, & - "The path to the file containing the spatially varying "//& - "tidal amplitudes.", & + "The path to the file containing the spatially varying tidal amplitudes.", & default="tideamp.nc") - call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) TideAmp_file = trim(inputdir) // trim(TideAmp_file) if (CS%rotate_index) then allocate(tmp2d(CS%Grid_in%isd:CS%Grid_in%ied,CS%Grid_in%jsd:CS%Grid_in%jed), source=0.0) - call MOM_read_data(TideAmp_file, 'tideamp', tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) + call MOM_read_data(TideAmp_file, tideamp_var, tmp2d, CS%Grid_in%domain, timelevel=1, scale=US%m_s_to_L_T) call rotate_array(tmp2d, CS%turns, CS%utide) deallocate(tmp2d) else - call MOM_read_data(TideAmp_file, 'tideamp', CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) + call MOM_read_data(TideAmp_file, tideamp_var, CS%utide, CS%Grid%domain, timelevel=1, scale=US%m_s_to_L_T) endif else call get_param(param_file, mdl, "UTIDE", utide, & @@ -2192,7 +2195,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. - logical :: coupled_GL ! If true the grouding line position is determined based on + logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. integer :: is, iec, js, jec @@ -2261,7 +2264,7 @@ end subroutine solo_step_ice_shelf !! update_shelf_mass - updates ice shelf mass via netCDF file !! USER_update_shelf_mass (TODO). !! solo_step_ice_shelf - called only in ice-only mode. -!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. currently mass_shelf is +!! shelf_calc_flux - after melt rate & fluxes are calculated, ice dynamics are done. Currently mass_shelf is !! updated immediately after ice_shelf_advect in fully dynamic mode. !! !! NOTES: be aware that hmask(:,:) has a number of functions; it is used for front advancement, diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 91b30a1e86..66c09cb6a3 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -261,6 +261,8 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s integer :: k, nz character(len=40) :: mdl = "set_coord_from_TS_profile" ! This subroutine's name. character(len=200) :: filename, coord_file, inputdir ! Strings for file/path + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files + nz = GV%ke call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") @@ -269,15 +271,21 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "COORD_FILE", coord_file, & - "The file from which the coordinate temperatures and "//& - "salinities are read.", fail_if_missing=.true.) + "The file from which the coordinate temperatures and salinities are read.", & + fail_if_missing=.true.) + call get_param(param_file, mdl, "TEMP_COORD_VAR", temp_var, & + "The coordinate reference profile variable name for potential temperature.", & + default="PTEMP") + call get_param(param_file, mdl, "SALT_COORD_VAR", salt_var, & + "The coordinate reference profile variable name for salinity.", & + default="SALT") call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") filename = trim(slasher(inputdir))//trim(coord_file) call log_param(param_file, mdl, "INPUTDIR/COORD_FILE", filename) - call MOM_read_data(filename, "PTEMP", T0(:), scale=US%degC_to_C) - call MOM_read_data(filename, "SALT", S0(:), scale=US%ppt_to_S) + call MOM_read_data(filename, temp_var, T0(:), scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S0(:), scale=US%ppt_to_S) if (.not.file_exists(filename)) call MOM_error(FATAL, & " set_coord_from_TS_profile: Unable to open " //trim(filename)) @@ -357,7 +365,7 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta k_light = GV%nk_rho_varies + 1 - ! Set T0(k) to range from T_LIGHT to T_DENSE, and simliarly for S0(k). + ! Set T0(k) to range from T_LIGHT to T_DENSE, and similarly for S0(k). T0(k_light) = T_Light ; S0(k_light) = S_Light a1 = 2.0 * res_rat / (1.0 + res_rat) do k=k_light+1,nz @@ -458,7 +466,7 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) - ! This following sets the target layer densities such that a the + ! This following sets the target layer densities such that the ! surface interface has density Rlay_ref and the bottom ! is Rlay_range larger do k=1,nz diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 31dbb41dcc..0cd94d1e79 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -135,7 +135,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & !! for model parameter values. type(directories), intent(in) :: dirs !< A structure containing several relevant !! directory paths. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure type(ALE_CS), pointer :: ALE_CSp !< The ALE control structure for remapping type(tracer_registry_type), pointer :: tracer_Reg !< A pointer to the tracer registry type(sponge_CS), pointer :: sponge_CSp !< The layerwise sponge control structure. @@ -342,7 +342,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! Initialize temperature and salinity (T and S). if ( use_temperature ) then call get_param(PF, mdl, "TS_CONFIG", config, & - "A string that determines how the initial tempertures "//& + "A string that determines how the initial temperatures "//& "and salinities are specified for a new run: \n"//& " \t file - read velocities from the file specified \n"//& " \t\t by (TS_FILE). \n"//& @@ -471,7 +471,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "file is read.", default=.not.GV%Boussinesq, do_not_log=just_read) if (new_sim .and. convert .and. .not.GV%Boussinesq) & - ! Convert thicknesses from geomtric distances to mass-per-unit-area. + ! 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. @@ -684,12 +684,18 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f ! Local variables real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Interface heights, in depth units [Z ~> m]. + real :: h_rescale ! A factor by which to rescale the initial thickness variable in the input + ! file to convert it to units of m [various] + real :: eta_rescale ! A factor by which to rescale the initial interface heights to convert + ! them to units of m or correct sign conventions to positive upward [various] + real :: h_tolerance ! A parameter that controls the tolerance when adjusting the + ! thickness to fit the bathymetry [Z ~> m]. integer :: inconsistent = 0 logical :: correct_thickness - real :: h_tolerance ! A parameter that controls the tolerance when adjusting the - ! thickness to fit the bathymetry [Z ~> m]. character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path + character(len=80) :: eta_var ! The interface height variable name in the input file + character(len=80) :: h_var ! The thickness variable name in the input file integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -710,9 +716,16 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f " initialize_thickness_from_file: Unable to open "//trim(filename)) if (file_has_thickness) then - !### Consider adding a parameter to use to rescale h. + call get_param(param_file, mdl, "THICKNESS_IC_VAR", h_var, & + "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.", & + 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", h(:,:,:), G%Domain, scale=GV%m_to_H) + + call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=h_rescale*GV%m_to_H) else call get_param(param_file, mdl, "ADJUST_THICKNESS", correct_thickness, & "If true, all mass below the bottom removed if the "//& @@ -724,9 +737,17 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) endif + call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & + "The variable name for initial conditions for interface heights "//& + "relative to mean sea level, positive upward unless otherwise rescaled.", & + default="eta", do_not_log=just_read) + call get_param(param_file, mdl, "INTERFACE_IC_RESCALE", eta_rescale, & + "A factor by which to rescale the initial interface heights to convert "//& + "them to units of m or correct sign conventions to positive upward.", & + 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, "eta", eta(:,:,:), G%Domain, scale=US%m_to_Z) + call MOM_read_data(filename, eta_var, eta(:,:,:), G%Domain, scale=US%m_to_Z*eta_rescale) if (correct_thickness) then call adjustEtaToFitBathymetry(G, GV, US, eta, h, h_tolerance, dZ_ref_eta=G%Z_ref) @@ -868,7 +889,7 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") if (G%max_depth<=0.) call MOM_error(FATAL,"initialize_thickness_uniform: "// & - "MAXIMUM_DEPTH has a non-sensical value! Was it set?") + "MAXIMUM_DEPTH has a nonsensical value! Was it set?") do k=1,nz e0(K) = -G%max_depth * real(k-1) / real(nz) @@ -915,7 +936,7 @@ subroutine initialize_thickness_list(h, depth_tot, G, GV, US, param_file, just_r real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. character(len=200) :: filename, eta_file, inputdir ! Strings for file/path - character(len=72) :: eta_var + character(len=72) :: eta_var ! The interface height variable name in the input file integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1681,13 +1702,20 @@ subroutine initialize_temp_salt_from_profile(T, S, G, GV, US, param_file, just_r real, dimension(SZK_(GV)) :: T0, S0 integer :: i, j, k character(len=200) :: filename, ts_file, inputdir ! Strings for file/path + character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files character(len=40) :: mdl = "initialize_temp_salt_from_profile" if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(param_file, mdl, "TS_FILE", ts_file, & - "The file with the reference profiles for temperature "//& - "and salinity.", fail_if_missing=.not.just_read, do_not_log=just_read) + "The file with the reference profiles for temperature and salinity.", & + fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "TEMP_IC_VAR", temp_var, & + "The initial condition variable for potential temperature.", & + default="PTEMP", do_not_log=just_read) + call get_param(param_file, mdl, "SALT_IC_VAR", salt_var, & + "The initial condition variable for salinity.", & + default="SALT", do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -1695,12 +1723,12 @@ subroutine initialize_temp_salt_from_profile(T, S, G, GV, US, param_file, just_r inputdir = slasher(inputdir) filename = trim(inputdir)//trim(ts_file) call log_param(param_file, mdl, "INPUTDIR/TS_FILE", filename) - if (.not.file_exists(filename)) call MOM_error(FATAL, & + if (.not.file_exists(filename)) call MOM_error(FATAL, & " initialize_temp_salt_from_profile: Unable to open "//trim(filename)) ! Read the temperatures and salinities from a netcdf file. - call MOM_read_data(filename, "PTEMP", T0(:), scale=US%degC_to_C) - call MOM_read_data(filename, "SALT", S0(:), scale=US%ppt_to_S) + call MOM_read_data(filename, temp_var, T0(:), scale=US%degC_to_C) + call MOM_read_data(filename, salt_var, S0(:), scale=US%ppt_to_S) do k=1,GV%ke ; do j=G%jsc,G%jec ; do i=G%isc,G%iec T(i,j,k) = T0(k) ; S(i,j,k) = S0(k) @@ -2212,14 +2240,14 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(oda_incupd_CS), pointer :: oda_incupd_CSp !< A pointer that is set to point to the control !! structure for this module. - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in !! overrides any value set for !Time. ! Local variables real, allocatable, dimension(:,:,:) :: hoda ! The layer thk inc. and oda layer thk [H ~> m or kg m-2]. real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda fields - real, allocatable, dimension(:,:,:) :: tmp_u,tmp_v ! A temporary array for reading oda fields + real, allocatable, dimension(:,:,:) :: tmp_u, tmp_v ! Temporary arrays for reading oda fields integer :: is, ie, js, je, nz integer :: isd, ied, jsd, jed @@ -2605,7 +2633,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "latter takes precedence.", default=default_remap_ans_date, do_not_log=just_read) endif call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizonal regridding that recovers "//& + "If true, use the order of arithmetic for horizontal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& "forms of the same expressions.", default=default_2018_answers, do_not_log=just_read) ! Revise inconsistent default answer dates for horizontal regridding. diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index fd49ec5a98..c48324962b 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -174,6 +174,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) integer :: npes_pm, ens_info(6) character(len=30) :: coord_mode character(len=200) :: inputdir, basin_file + character(len=80) :: basin_var character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover the @@ -348,27 +349,28 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) if (CS%use_basin_mask) then call get_param(PF, 'oda_driver', "BASIN_FILE", basin_file, & - "A file in which to find the basin masks, in variable 'basin'.", & - default="basin.nc") + "A file in which to find the basin masks.", default="basin.nc") basin_file = trim(inputdir) // trim(basin_file) + call get_param(PF, 'oda_driver', "BASIN_VAR", basin_var, & + "The basin mask variable in BASIN_FILE.", default="basin") allocate(CS%oda_grid%basin_mask(isd:ied,jsd:jed), source=0.0) - call MOM_read_data(basin_file,'basin',CS%oda_grid%basin_mask,CS%Grid%domain, timelevel=1) + call MOM_read_data(basin_file, basin_var, CS%oda_grid%basin_mask, CS%Grid%domain, timelevel=1) endif ! set up diag variables for analysis increments CS%diag_CS => diag_CS - CS%id_inc_t=register_diag_field('ocean_model','temp_increment',diag_CS%axesTL,& + CS%id_inc_t = register_diag_field('ocean_model', 'temp_increment', diag_CS%axesTL, & Time, 'ocean potential temperature increments', 'degC', conversion=US%C_to_degC) - CS%id_inc_s=register_diag_field('ocean_model','salt_increment',diag_CS%axesTL,& + CS%id_inc_s = register_diag_field('ocean_model', 'salt_increment', diag_CS%axesTL, & Time, 'ocean salinity increments', 'psu', conversion=US%S_to_ppt) !! get global grid information from ocean model needed for ODA initialization - T_grid=>NULL() + T_grid => NULL() call set_up_global_tgrid(T_grid, CS, G) call ocean_da_core_init(CS%mpp_domain, T_grid, CS%Profiles, Time) deallocate(T_grid) - CS%Time=Time + CS%Time = Time !! switch back to ensemble member pelist call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 4339a699e5..825ca412d1 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -182,9 +182,9 @@ module MOM_hor_visc type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics ! real, allocatable :: hf_diffu(:,:,:) ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. - ! real, allocatable :: hf_diffv(:,:,:) ! Merdional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, allocatable :: hf_diffv(:,:,:) ! Meridional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. - ! The code is retained for degugging purposes in the future. + ! The code is retained for debugging purposes in the future. integer :: num_smooth_gme !< number of smoothing passes for the GME fluxes. !>@{ @@ -252,13 +252,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & - Del2u, & ! The u-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] + Del2u, & ! The u-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] ubtav ! zonal barotropic vel. ave. over baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - Del2v, & ! The v-compontent of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] + Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] @@ -345,7 +345,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] - real :: DX_dyBu ! Ratio of zonal over meridiononal grid spacing at vertices [nondim] + real :: DX_dyBu ! Ratio of zonal over meridional grid spacing at vertices [nondim] real :: Sh_F_pow ! The ratio of shear over the absolute value of f raised to some power and rescaled [nondim] real :: backscat_subround ! The ratio of f over Shear_mag that is so small that the backscatter ! calculation gives the same value as if f were 0 [nondim]. @@ -1682,7 +1682,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< Structure to regulate diagnostic output. - type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control struct + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v @@ -1705,8 +1705,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! grid spacing, to limit biharmonic viscosity real :: Kh ! Lapacian horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Ah ! biharmonic horizontal viscosity [L4 T-1 ~> m4 s-1] - real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Lap visc - real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives bih visc + real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Laplacian viscosity + real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives biharmonic viscosity real :: Ah_time_scale ! damping time-scale for biharmonic visc [T ~> s] real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant @@ -1730,7 +1730,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! forms of the same expressions. 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 - character(len=64) :: inputdir, filename + character(len=200) :: inputdir, filename ! Input file names and paths + character(len=80) :: Kh_var ! Input variable names real :: deg2rad ! Converts degrees to radians real :: slat_fn ! sin(lat)**Kh_pwr_of_sine real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction @@ -1851,24 +1852,24 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s, & do_not_log=.not.CS%anisotropic) call get_param(param_file, mdl, "ANISOTROPIC_MODE", aniso_mode, & - "Selects the mode for setting the direction of anistropy.\n"//& + "Selects the mode for setting the direction of anisotropy.\n"//& "\t 0 - Points along the grid i-direction.\n"//& "\t 1 - Points towards East.\n"//& "\t 2 - Points along the flow direction, U/|U|.", & default=0, do_not_log=.not.CS%anisotropic) if (aniso_mode == 0) then call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for horizontal viscosity. "//& + "The vector pointing in the direction of anisotropy for horizontal viscosity. "//& "n1,n2 are the i,j components relative to the grid.", & units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic) elseif (aniso_mode == 1) then call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for horizontal viscosity. "//& + "The vector pointing in the direction of anisotropy for horizontal viscosity. "//& "n1,n2 are the i,j components relative to the spherical coordinates.", & units="nondim", fail_if_missing=CS%anisotropic, do_not_log=.not.CS%anisotropic) else call get_param(param_file, mdl, "ANISO_GRID_DIR", aniso_grid_dir, & - "The vector pointing in the direction of anistropy for horizontal viscosity.", & + "The vector pointing in the direction of anisotropy for horizontal viscosity.", & units="nondim", fail_if_missing=.false., do_not_log=.true.) endif @@ -2074,11 +2075,15 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "KH_BG_2D_FILENAME", filename, & 'The filename containing a 2d map of "Kh".', & default='KH_background_2d.nc', do_not_log=.not.CS%use_Kh_bg_2d) + call get_param(param_file, mdl, "KH_BG_2D_VARNAME", Kh_var, & + 'The name in the input file of the horizontal viscosity variable.', & + default='Kh', do_not_log=.not.CS%use_Kh_bg_2d) + if (CS%use_Kh_bg_2d) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) ALLOC_(CS%Kh_bg_2d(isd:ied,jsd:jed)) ; CS%Kh_bg_2d(:,:) = 0.0 - call MOM_read_data(trim(inputdir)//trim(filename), 'Kh', CS%Kh_bg_2d, & + call MOM_read_data(trim(inputdir)//trim(filename), Kh_var, CS%Kh_bg_2d, & G%domain, timelevel=1, scale=US%m_to_L**2*US%T_to_s) call pass_var(CS%Kh_bg_2d, G%domain) endif diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index b152583269..8414e27f8c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -83,7 +83,7 @@ module MOM_internal_tides !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss !< internal tide energy loss due to the residual at slopes [R Z3 T-3 ~> W m-2] - real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc bakground processes, + real, allocatable, dimension(:,:) :: tot_leak_loss !< Energy loss rates due to misc background processes, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: tot_quad_loss !< Energy loss rates due to quadratic bottom drag, !! summed over angle, frequency and mode [R Z3 T-3 ~> W m-2] @@ -124,7 +124,7 @@ 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 struct + type(wave_structure_CS) :: wave_struct !< Wave structure control structure !>@{ Diag handles ! Diag handles relevant to all modes, frequencies, and angles @@ -135,7 +135,7 @@ module MOM_internal_tides ! Diag handles considering: sums over all modes, frequencies, and angles integer :: id_tot_leak_loss = -1, id_tot_quad_loss = -1, id_tot_itidal_loss = -1 integer :: id_tot_Froude_loss = -1, id_tot_residual_loss = -1, id_tot_allprocesses_loss = -1 - ! Diag handles considering: all modes & freqs; summed over angles + ! Diag handles considering: all modes & frequencies; summed over angles integer, allocatable, dimension(:,:) :: & id_En_mode, & id_itidal_loss_mode, & @@ -177,7 +177,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Nb !< Near-bottom buoyancy frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + 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]. @@ -540,7 +540,7 @@ 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 two-dimensional diagnostistics + ! 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) if (CS%id_TKE_itidal_input > 0) call post_data(CS%id_TKE_itidal_input, & @@ -645,7 +645,7 @@ end subroutine propagate_int_tide subroutine sum_En(G, US, CS, En, label) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle), & intent(in) :: En !< The energy density of the internal tides [R Z3 T-2 ~> J m-2]. character(len=*), intent(in) :: label !< A label to use in error messages @@ -684,7 +684,7 @@ end subroutine sum_En subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: Nb !< Near-bottom stratification [T-1 ~> s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & @@ -700,16 +700,16 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. logical,optional, intent(in) :: full_halos !< If true, do the calculation over the - !! entirecomputational domain. + !! entire computational domain. ! Local variables integer :: j,i,m,fr,a, is, ie, js, je real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] - real :: frac_per_sector ! fraction of energy in each wedge + real :: frac_per_sector ! fraction of energy in each wedge [nondim] real :: q_itides ! fraction of energy actually lost to mixing (remainder, 1-q, is - ! assumed to stay in propagating mode for now - BDM) + ! assumed to stay in propagating mode for now - BDM) [nondim] real :: loss_rate ! approximate loss rate for implicit calc [T-1 ~> s-1] - real :: En_negl ! negilibly small number to prevent division by zero + real :: En_negl ! negligibly small number to prevent division by zero [R Z3 T-2 ~> J m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -753,7 +753,7 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, ! if (TKE_loss(i,j,a,fr,m)*dt <= En(i,j,a,fr,m))then ! En(i,j,a,fr,m) = En(i,j,a,fr,m) - TKE_loss(i,j,a,fr,m)*dt ! else - ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than avalable, "// & + ! call MOM_error(WARNING, "itidal_lowmode_loss: energy loss greater than available, "// & ! " setting En to zero.", all_print=.true.) ! En(i,j,a,fr,m) = 0.0 ! endif @@ -775,7 +775,7 @@ subroutine get_lowmode_loss(i,j,G,CS,mechanism,TKE_loss_sum) integer, intent(in) :: i !< The i-index of the value to be reported. integer, intent(in) :: j !< The j-index of the value to be reported. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure character(len=*), intent(in) :: mechanism !< The named mechanism of loss to return real, intent(out) :: TKE_loss_sum !< Total energy loss rate due to specified !! mechanism [R Z3 T-3 ~> W m-2]. @@ -950,7 +950,7 @@ subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) real :: flux real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] real :: Angle_size ! The size of each orientation wedge in radians [Rad] - real :: I_Angle_size ! The inverse of the the orientation wedges [Rad-1] + real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] real :: I_dt ! The inverse of the timestep [T-1 ~> s-1] real :: aR, aL ! Left and right edge estimates of energy density [R Z3 T-2 rad-1 ~> J m-2 rad-1] real :: Ep, Ec, Em ! Mean angular energy density for three successive wedges in angular @@ -1037,7 +1037,7 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) real, intent(in) :: freq !< Wave frequency [T-1 ~> s-1]. real, intent(in) :: dt !< Time step [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed,NAngle), & intent(inout) :: residual_loss !< internal tide energy loss due !! to the residual at slopes [R Z3 T-3 ~> W m-2]. @@ -1166,7 +1166,7 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. real, intent(in) :: dt !< Time increment [T ~> s]. - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables integer :: i, j, ish, ieh, jsh, jeh, m @@ -1452,7 +1452,7 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res !! edges of each angular band. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due @@ -1533,7 +1533,7 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res !! edges of each angular band. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle), & intent(inout) :: residual_loss !< internal tide energy loss due @@ -1699,7 +1699,7 @@ subroutine reflect(En, NAngle, CS, G, LB) intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution !! [R Z3 T-2 ~> J m-2]. - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables @@ -1806,7 +1806,7 @@ subroutine teleport(En, NAngle, CS, G, LB) intent(inout) :: En !< The internal gravity wave energy density as a !! function of space and angular resolution !! [R Z3 T-2 ~> J m-2]. - type(int_tide_CS), intent(in) :: CS !< Internal tide control struct + type(int_tide_CS), intent(in) :: CS !< Internal tide control structure type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables real, dimension(G%isd:G%ied,G%jsd:G%jed) :: angle_c @@ -1831,7 +1831,7 @@ subroutine teleport(En, NAngle, CS, G, LB) ! ! (values exclude halos) integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain ! leaving out outdated halo points (march in) - integer :: id_g, jd_g ! global (decomp-invar) indices + integer :: id_g, jd_g ! global (decomposition-invariant) indices integer :: jos, ios ! offsets real :: cos_normal, sin_normal, angle_wall ! cos/sin of cross-ridge normal, ridge angle @@ -2144,8 +2144,8 @@ end subroutine PPM_limit_pos ! subroutine register_int_tide_restarts(G, param_file, CS, restart_CS) ! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure ! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! type(int_tide_CS), intent(in) :: CS !< Internal tide control struct -! type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct +! type(int_tide_CS), intent(in) :: CS !< Internal tide control structure +! type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! ! This subroutine is not currently in use!! @@ -2189,7 +2189,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !! parameters. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure ! Local variables real :: Angle_size ! size of wedges, rad @@ -2216,8 +2216,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=200) :: refl_angle_file character(len=200) :: refl_pref_file, refl_dbl_file, trans_file character(len=200) :: h2_file - !character(len=200) :: land_mask_file - !character(len=200) :: dy_Cu_file, dx_Cv_file + character(len=80) :: rough_var ! Input file variable names isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2389,11 +2388,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") call get_param(param_file, mdl, "INTERNAL_TIDE_ROUGHNESS_FRAC", RMS_roughness_frac, & "The maximum RMS topographic roughness as a fraction of the nominal ocean depth, "//& "or a negative value for no limit.", units="nondim", default=0.1) - call MOM_read_data(filename, 'h2', h2, G%domain, scale=US%m_to_Z**2) + call MOM_read_data(filename, rough_var, h2, G%domain, scale=US%m_to_Z**2) do j=G%jsc,G%jec ; do i=G%isc,G%iec ! Restrict RMS topographic roughness to a fraction (10 percent by default) of the column depth. if (RMS_roughness_frac >= 0.0) then @@ -2502,40 +2504,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) enddo call pass_var(CS%residual,G%domain) - ! Read in prescribed land mask from file (if overwriting -BDM). - ! This should be done in MOM_initialize_topography subroutine - ! defined in MOM_fixed_initialization.F90 (BDM) - !call get_param(param_file, mdl, "LAND_MASK_FILE", land_mask_file, & - ! "The path to the file containing the land mask.", & - ! fail_if_missing=.false.) - !filename = trim(CS%inputdir) // trim(land_mask_file) - !call log_param(param_file, mdl, "INPUTDIR/LAND_MASK_FILE", filename) - !G%mask2dCu(:,:) = 1 ; G%mask2dCv(:,:) = 1 ; G%mask2dT(:,:) = 1 - !call MOM_read_data(filename, 'land_mask', G%mask2dCu, G%domain) - !call MOM_read_data(filename, 'land_mask', G%mask2dCv, G%domain) - !call MOM_read_data(filename, 'land_mask', G%mask2dT, G%domain) - !call pass_vector(G%mask2dCu, G%mask2dCv, G%domain, To_All+Scalar_Pair, CGRID_NE) - !call pass_var(G%mask2dT,G%domain) - - ! Read in prescribed partial east face blockages from file (if overwriting -BDM) - !call get_param(param_file, mdl, "dy_Cu_FILE", dy_Cu_file, & - ! "The path to the file containing the east face blockages.", & - ! fail_if_missing=.false.) - !filename = trim(CS%inputdir) // trim(dy_Cu_file) - !call log_param(param_file, mdl, "INPUTDIR/dy_Cu_FILE", filename) - !G%dy_Cu(:,:) = 0.0 - !call MOM_read_data(filename, 'dy_Cu', G%dy_Cu, G%domain, scale=US%m_to_L) - - ! Read in prescribed partial north face blockages from file (if overwriting -BDM) - !call get_param(param_file, mdl, "dx_Cv_FILE", dx_Cv_file, & - ! "The path to the file containing the north face blockages.", & - ! fail_if_missing=.false.) - !filename = trim(CS%inputdir) // trim(dx_Cv_file) - !call log_param(param_file, mdl, "INPUTDIR/dx_Cv_FILE", filename) - !G%dx_Cv(:,:) = 0.0 - !call MOM_read_data(filename, 'dx_Cv', G%dx_Cv, G%domain, scale=US%m_to_L) - !call pass_vector(G%dy_Cu, G%dx_Cv, G%domain, To_All+Scalar_Pair, CGRID_NE) - ! 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') @@ -2604,7 +2572,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) Angle_size = (8.0*atan(1.0)) / (real(num_angle)) do a=1,num_angle ; angles(a) = (real(a) - 1) * Angle_size ; enddo - id_ang = diag_axis_init("angle", angles, "Radians", "N", "Angular Orienation of Fluxes") + id_ang = diag_axis_init("angle", angles, "Radians", "N", "Angular Orientation of Fluxes") call define_axes_group(diag, (/ diag%axesT1%handles(1), diag%axesT1%handles(2), id_ang /), & axes_ang, is_h_point=.true.) do fr=1,CS%nFreq ; write(freq_name(fr), '("freq",i1)') fr ; enddo @@ -2645,16 +2613,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 2-D period-averaged near-bottom horizonal velocity for each freq and mode + ! Register 2-D period-averaged near-bottom horizontal velocity for each freq and mode write(var_name, '("Itide_Ub_freq",i1,"_mode",i1)') fr, m - write(var_descript, '("Near-bottom horizonal velocity for frequency ",i1," mode ",i1)') fr, m + write(var_descript, '("Near-bottom horizontal velocity for frequency ",i1," mode ",i1)') fr, m CS%id_Ub_mode(fr,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) ! Register 2-D horizonal phase velocity for each freq and mode write(var_name, '("Itide_cp_freq",i1,"_mode",i1)') fr, m - write(var_descript, '("Horizonal phase velocity for frequency ",i1," mode ",i1)') fr, m + write(var_descript, '("Horizontal phase velocity for frequency ",i1," mode ",i1)') fr, m CS%id_cp_mode(fr,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) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index ff2180497b..9ec4c073f0 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -185,7 +185,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) !! smooth out the values in thin layers [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h2 !< Bottom topographic roughness [Z2 ~> m2]. type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy freqency at the + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & @@ -304,7 +304,8 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. - character(len=200) :: filename, tideamp_file, h2_file + character(len=200) :: filename, tideamp_file, h2_file ! Input file names or paths + character(len=80) :: tideamp_var, rough_var ! Input file variable names real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] real :: max_frac_rough ! The fraction relating the maximum topographic roughness @@ -386,7 +387,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', itide%tideamp, G%domain, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + call MOM_read_data(filename, tideamp_var, itide%tideamp, G%domain, scale=US%m_s_to_L_T) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -395,7 +399,10 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) fail_if_missing=.true.) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', itide%h2, G%domain, scale=US%m_to_Z**2) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + call MOM_read_data(filename, rough_var, itide%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& @@ -408,7 +415,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) default=.false.) if (CS%int_tide_source_test)then call get_param(param_file, mdl, "INTERNAL_TIDE_USE_GLOB_IJ", CS%int_tide_use_glob_ij, & - "Use global IJ for interal tide generation source test", default=.false.) + "Use global IJ for internal tide generation source test", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & "X Location of generation site for internal tide", default=1., & do_not_log=CS%int_tide_use_glob_ij) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 80be1ed12f..1d2bbbb048 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -77,7 +77,7 @@ module MOM_set_visc logical :: Channel_drag !< If true, the drag is exerted directly on each layer !! according to what fraction of the bottom they overlie. real :: Chan_drag_max_vol !< The maximum bottom boundary layer volume within which the - !! channel drag is applied, normalized by the the full cell area, + !! channel drag is applied, normalized by the full cell area, !! or a negative value to apply no maximum [H ~> m or kg m-2]. logical :: correct_BBL_bounds !< If true, uses the correct bounds on the BBL thickness and !! viscosity so that the bottom layer feels the intended drag. @@ -134,7 +134,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields - !! have NULL ptrs. + !! have NULL pointers. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. type(set_visc_CS), intent(inout) :: CS !< The control structure returned by a previous @@ -1192,7 +1192,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available !! thermodynamic fields. Absent fields have - !! NULL ptrs. + !! NULL pointers. type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. @@ -1236,7 +1236,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! viscous mixed layer. real :: Uh2 ! The squared magnitude of the difference between the velocity ! integrated through the mixed layer and the velocity of the - ! interior layer layer times the depth of the the mixed layer + ! interior layer layer times the depth of the mixed layer ! [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. real :: hwtot ! Sum of the thicknesses used to calculate @@ -1253,8 +1253,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) real :: S_lay ! The layer salinity at velocity points [S ~> ppt]. real :: Rlay ! The layer potential density at velocity points [R ~> kg m-3]. real :: Rlb ! The potential density of the layer below [R ~> kg m-3]. - real :: v_at_u ! The meridonal velocity at a zonal velocity point [L T-1 ~> m s-1]. - real :: u_at_v ! The zonal velocity at a meridonal velocity point [L T-1 ~> m s-1]. + real :: v_at_u ! The meridional velocity at a zonal velocity point [L T-1 ~> m s-1]. + real :: u_at_v ! The zonal velocity at a meridional velocity point [L T-1 ~> m s-1]. real :: gHprime ! The mixed-layer internal gravity wave speed squared, based ! on the mixed layer thickness and density difference across ! the base of the mixed layer [L2 T-2 ~> m2 s-2]. @@ -1863,7 +1863,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical !! viscosities and related fields. !! Allocated here. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables logical :: use_kappa_shear, KS_at_vertex logical :: adiabatic, useKPP, useEPBL @@ -1954,14 +1954,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS !! output. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and !! related fields. Allocated here. - type(set_visc_CS), intent(inout) :: CS !< Vertical viscosity control struct - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(set_visc_CS), intent(inout) :: CS !< Vertical viscosity control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure ! Local variables real :: Csmag_chan_dflt ! The default value for SMAG_CONST_CHANNEL [nondim] real :: smag_const1 ! The default value for the Smagorinsky Laplacian coefficient [nondim] - real :: TKE_decay_dflt ! The default value of a coeficient scaling the vertical decay + real :: TKE_decay_dflt ! The default value of a coefficient scaling the vertical decay ! rate of TKE [nondim] real :: bulk_Ri_ML_dflt ! The default bulk Richardson number for a bulk mixed layer [nondim] real :: Kv_background ! The background kinematic viscosity in the interior [m2 s-1] @@ -1989,7 +1989,8 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! isopycnal or stacked shallow water mode. logical :: use_temperature ! If true, temperature and salinity are used as state variables. logical :: use_EOS ! If true, density calculated from T & S using an equation of state. - character(len=200) :: filename, tideamp_file + character(len=200) :: filename, tideamp_file ! Input file names or paths + character(len=80) :: tideamp_var ! Input file variable names ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_visc" ! This module's name. @@ -2090,7 +2091,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then - call MOM_error(WARNING, "ML_USE_OMEGA is depricated; use ML_OMEGA_FRAC=1.0 instead.") + call MOM_error(WARNING, "ML_USE_OMEGA is deprecated; use ML_OMEGA_FRAC=1.0 instead.") omega_frac_dflt = 1.0 endif call get_param(param_file, mdl, "ML_OMEGA_FRAC", CS%omega_frac, & @@ -2130,6 +2131,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "TIDEAMP_FILE", tideamp_file, & "The path to the file containing the spatially varying "//& "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") else call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & "DRAG_BG_VEL is either the assumed bottom velocity (with "//& @@ -2223,7 +2227,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%BBL_thick_min = CS%BBL_thick_min * GV%m_to_H ! Rescale if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then - ! This is necessary for reproduciblity across restarts in non-symmetric mode. + ! This is necessary for reproducibility across restarts in non-symmetric mode. call pass_var(visc%Kv_shear_Bu, G%Domain, position=CORNER, complete=.true.) endif @@ -2257,7 +2261,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(CS%tideamp(isd:ied,jsd:jed), source=0.0) filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) call pass_var(CS%tideamp,G%domain) endif endif diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 645a6ef491..1528a644ec 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -48,7 +48,7 @@ module MOM_tidal_mixing real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] - real, allocatable :: N2_int(:,:,:) !< Bouyancy frequency squared at interfaces [T-2 ~> s-2] + real, allocatable :: N2_int(:,:,:) !< Buoyancy frequency squared at interfaces [T-2 ~> s-2] real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition [W m-3] real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme, in UNITS? real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, @@ -61,7 +61,7 @@ module MOM_tidal_mixing real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] real, allocatable :: Polzin_decay_scale_scaled(:,:) !< vertical scale of decay for tidal dissipation [Z ~> m] - real, allocatable :: Polzin_decay_scale(:,:) !< vertical decay scale for tidal diss with Polzin [Z ~> m] + real, allocatable :: Polzin_decay_scale(:,:) !< vertical decay scale for tidal dissipation with Polzin [Z ~> m] real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient end type @@ -154,7 +154,7 @@ module MOM_tidal_mixing real, allocatable :: TKE_Niku(:,:) !< Lee wave driven Turbulent Kinetic Energy input !! [R Z3 T-3 ~> W m-2] real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratfication [R Z3 T-2 ~> J m-2]. + !! by the bottom stratification [R Z3 T-2 ~> J m-2]. real, allocatable :: Nb(:,:) !< The near bottom buoyancy frequency [T-1 ~> s-1]. real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input real, allocatable :: h2(:,:) !< Squared bottom depth variance [Z2 ~> m2]. @@ -236,8 +236,9 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di ! forms of the same expressions. character(len=20) :: tmpstr, int_tide_profile_str character(len=20) :: CVMix_tidal_scheme_str, tidal_energy_type - character(len=200) :: filename, h2_file, Niku_TKE_input_file - character(len=200) :: tidal_energy_file, tideamp_file + character(len=200) :: filename, h2_file, Niku_TKE_input_file ! Input file names + character(len=200) :: tideamp_file ! Input file names or paths + character(len=80) :: tideamp_var, rough_var, TKE_input_var ! Input file variable names real :: utide, hamp, prandtl_tidal, max_frac_rough real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data integer :: i, j, is, ie, js, je @@ -496,7 +497,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call MOM_read_data(filename, 'tideamp', CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & + "The name of the tidal amplitude variable in the input file.", & + default="tideamp") + call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -505,7 +509,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di fail_if_missing=(.not.CS%use_CVMix_tidal)) filename = trim(CS%inputdir) // trim(h2_file) call log_param(param_file, mdl, "INPUTDIR/H2_FILE", filename) - call MOM_read_data(filename, 'h2', CS%h2, G%domain, scale=US%m_to_Z**2) + call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & + "The name in the input file of the squared sub-grid-scale "//& + "topographic roughness amplitude variable.", default="h2") + call MOM_read_data(filename, rough_var, CS%h2, G%domain, scale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& @@ -546,10 +553,13 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di units="nondim", default=1.0) filename = trim(CS%inputdir) // trim(Niku_TKE_input_file) - call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", & - filename) + call log_param(param_file, mdl, "INPUTDIR/NIKURASHIN_TKE_INPUT_FILE", filename) + call get_param(param_file, mdl, "TKE_INPUT_VAR", TKE_input_var, & + "The name in the input file of the turbulent kinetic energy input variable.", & + default="TKE_input") allocate(CS%TKE_Niku(is:ie,js:je), source=0.) - call MOM_read_data(filename, 'TKE_input', CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja + + call MOM_read_data(filename, TKE_input_var, CS%TKE_Niku, G%domain, timelevel=1, & ! ??? timelevel -aja scale=Niku_scale*US%W_m2_to_RZ3_T3) call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & @@ -557,8 +567,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di "locally with LEE_WAVE_DISSIPATION.", units="nondim", & default=0.3333) call get_param(param_file, mdl, "DECAY_SCALE_FACTOR_LEE",CS%Decay_scale_factor_lee, & - "Scaling for the vertical decay scaleof the local "//& - "dissipation of lee waves dissipation.", units="nondim", & + "Scaling for the vertical decay scale of the local "//& + "dissipation of lee wave dissipation.", units="nondim", & default=1.0) else CS%Decay_scale_factor_lee = -9.e99 ! This should never be used if CS%Lee_wave_dissipation = False @@ -576,10 +586,6 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di "Min allowable depth for dissipation for tidal-energy-constituent data. "//& "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & units="m", default=0.0, scale=US%m_to_Z) - call get_param(param_file, mdl, "TIDAL_ENERGY_FILE",tidal_energy_file, & - "The path to the file containing tidal energy "//& - "dissipation. Used with CVMix tidal mixing schemes.", & - fail_if_missing=.true.) call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, & do_not_log=.True.) call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & @@ -589,7 +595,6 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di do_not_log=.true.) call CVMix_put(CS%CVMix_glb_params,'Prandtl',prandtl_tidal) - tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & "The type of input tidal energy flux dataset. Valid values are"//& "\t Jayne\n"//& @@ -614,7 +619,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di local_mixing_frac = CS%Gamma_itides, & depth_cutoff = CS%min_zbot_itides*US%Z_to_m) - call read_tidal_energy(G, US, tidal_energy_type, tidal_energy_file, CS) + call read_tidal_energy(G, US, tidal_energy_type, param_file, CS) !call closeParameterBlock(param_file) @@ -1572,29 +1577,41 @@ end subroutine tidal_mixing_h_amp ! TODO: move this subroutine to MOM_internal_tide_input module (?) !> This subroutine read tidal energy inputs from a file. -subroutine read_tidal_energy(G, US, tidal_energy_type, tidal_energy_file, CS) +subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=20), intent(in) :: tidal_energy_type !< The type of tidal energy inputs to read - character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidalinputs + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module - ! local + + ! local variables + character(len=200) :: tidal_energy_file ! Input file names or paths + character(len=200) :: tidal_input_var ! Input file variable name + character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. integer :: i, j, isd, ied, jsd, jed real, allocatable, dimension(:,:) :: tidal_energy_flux_2d ! input tidal energy flux at T-grid points [W m-2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + call get_param(param_file, mdl, "TIDAL_ENERGY_FILE", tidal_energy_file, & + "The path to the file containing tidal energy dissipation. "//& + "Used with CVMix tidal mixing schemes.", fail_if_missing=.true.) + tidal_energy_file = trim(CS%inputdir) // trim(tidal_energy_file) + select case (uppercase(tidal_energy_type(1:4))) case ('JAYN') ! Jayne 2009 if (.not. allocated(CS%tidal_qe_2d)) allocate(CS%tidal_qe_2d(isd:ied,jsd:jed)) allocate(tidal_energy_flux_2d(isd:ied,jsd:jed)) - call MOM_read_data(tidal_energy_file,'wave_dissipation',tidal_energy_flux_2d, G%domain) + call get_param(param_file, mdl, "TIDAL_DISSIPATION_VAR", tidal_input_var, & + "The name in the input file of the tidal energy source for mixing.", & + default="wave_dissipation") + call MOM_read_data(tidal_energy_file, tidal_input_var, tidal_energy_flux_2d, G%domain) do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%tidal_qe_2d(i,j) = CS%Gamma_itides * tidal_energy_flux_2d(i,j) enddo ; enddo deallocate(tidal_energy_flux_2d) case ('ER03') ! Egbert & Ray 2003 - call read_tidal_constituents(G, US, tidal_energy_file, CS) + call read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) case default call MOM_error(FATAL, "read_tidal_energy: Unknown tidal energy file type.") end select @@ -1602,10 +1619,11 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, tidal_energy_file, CS) end subroutine read_tidal_energy !> This subroutine reads tidal input energy from a file by constituent. -subroutine read_tidal_constituents(G, US, tidal_energy_file, CS) +subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type character(len=200), intent(in) :: tidal_energy_file !< The file from which to read tidal energy inputs + type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module ! local variables From 530cd58a33e48aa0235635aff8ad21bd12979436 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Nov 2022 10:04:40 -0500 Subject: [PATCH 037/629] +Set more input file variable names at runtime Added calls to get_param to set 4 more input variable names in files via runtime, including U_IC_VAR, V_IC_VAR, OPEN_DY_CU_VAR and OPEN_DX_CV_VAR. Also added or amended comments describing internal variables to describe their units more consistently in MOM_shared_initialization. All answers are bitwise identical, but there may be new entries in some MOM_parameter_doc files. --- .../MOM_shared_initialization.F90 | 59 +++++++++++-------- .../MOM_state_initialization.F90 | 18 ++++-- 2 files changed, 48 insertions(+), 29 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index ff272e7fce..53bfe851b0 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -96,7 +96,7 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables integer :: i,j - real :: f1, f2 + real :: f1, f2 ! Average of adjacent Coriolis parameters [T-1 ~> s-1] if ((LBOUND(G%CoriolisBu,1) > G%isc-1) .or. & (LBOUND(G%CoriolisBu,2) > G%isc-1)) then @@ -121,8 +121,8 @@ end subroutine MOM_calculate_grad_Coriolis function diagnoseMaximumDepth(D, G) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: D !< Ocean bottom depth in m or Z - real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in m or Z + intent(in) :: D !< Ocean bottom depth in [m] or [Z ~> m] + real :: diagnoseMaximumDepth !< The global maximum ocean bottom depth in [m] or [Z ~> m] ! Local variables integer :: i,j diagnoseMaximumDepth = D(G%isc,G%jsc) @@ -292,7 +292,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth ! Local variables real :: min_depth ! The minimum depth [Z ~> m]. - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH [Z ~> m] real :: expdecay ! A decay scale of associated with the sloping boundaries [L ~> m] real :: Dedge ! The depth at the basin edge [Z ~> m] @@ -449,7 +449,7 @@ subroutine set_rotation_planetary(f, G, param_file, US) ! This subroutine sets up the Coriolis parameter for a sphere character(len=30) :: mdl = "set_rotation_planetary" ! This subroutine's name. integer :: I, J - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real :: omega ! The planetary rotation rate [T-1 ~> s-1] call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") @@ -480,10 +480,10 @@ subroutine set_rotation_beta_plane(f, G, param_file, US) integer :: I, J real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] - real :: beta_lat_ref ! The reference latitude for the beta plane [degrees/km/m/cm] + real :: beta_lat_ref ! The reference latitude for the beta plane [degrees_N] or [km] or [m] real :: Rad_Earth_L ! The radius of the planet in rescaled units [L ~> m] real :: y_scl ! A scaling factor from the units of latitude [L lat-1 ~> m lat-1] - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] character(len=40) :: mdl = "set_rotation_beta_plane" ! This subroutine's name. character(len=200) :: axis_units character(len=40) :: beta_lat_ref_units @@ -533,10 +533,12 @@ subroutine initialize_grid_rotation_angle(G, PF) type(param_file_type), intent(in) :: PF !< A structure indicating the open file !! to parse for model parameter values. - real :: angle, lon_scale - real :: len_lon ! The periodic range of longitudes, usually 360 degrees. - real :: pi_720deg ! One quarter the conversion factor from degrees to radians. - real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value. + real :: angle ! The clockwise angle of the grid relative to true north [degrees] + real :: lon_scale ! The trigonometric scaling factor converting changes in longitude + ! to equivalent distances in latitudes [nondim] + real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. + real :: pi_720deg ! One quarter the conversion factor from degrees to radians [radian degree-1] + real :: lonB(2,2) ! The longitude of a point, shifted to have about the same value [degrees_E]. character(len=40) :: mdl = "initialize_grid_rotation_angle" ! This subroutine's name. logical :: use_bugs integer :: i, j, m, n @@ -587,10 +589,10 @@ end subroutine initialize_grid_rotation_angle !> Return the modulo value of x in an interval [xc-(Lx/2) xc+(Lx/2)] !! If Lx<=0, then it returns x without applying modulo arithmetic. function modulo_around_point(x, xc, Lx) result(x_mod) - real, intent(in) :: x !< Value to which to apply modulo arithmetic - real, intent(in) :: xc !< Center of modulo range - real, intent(in) :: Lx !< Modulo range width - real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc. + real, intent(in) :: x !< Value to which to apply modulo arithmetic [A] + real, intent(in) :: xc !< Center of modulo range [A] + real, intent(in) :: Lx !< Modulo range width [A] + real :: x_mod !< x shifted by an integer multiple of Lx to be close to xc [A]. if (Lx > 0.0) then x_mod = modulo(x - (xc - 0.5*Lx), Lx) + (xc - 0.5*Lx) @@ -611,9 +613,9 @@ subroutine reset_face_lengths_named(G, param_file, name, US) ! Local variables character(len=256) :: mesg ! Message for error messages. - real :: dx_2 ! Half the local zonal grid spacing [degreesE] - real :: dy_2 ! Half the local meridional grid spacing [degreesN] - real :: pi_180 + real :: dx_2 ! Half the local zonal grid spacing [degrees_E] + real :: dy_2 ! Half the local meridional grid spacing [degrees_N] + real :: pi_180 ! Conversion factor from degrees to radians [nondim] integer :: option integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -738,7 +740,9 @@ subroutine reset_face_lengths_file(G, param_file, US) character(len=40) :: mdl = "reset_face_lengths_file" ! This subroutine's name. character(len=256) :: mesg ! Message for error messages. character(len=200) :: filename, chan_file, inputdir ! Strings for file/path + character(len=64) :: dxCv_open_var, dyCu_open_var ! Open face length names in files integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! These checks apply regardless of the chosen option. @@ -758,7 +762,14 @@ subroutine reset_face_lengths_file(G, param_file, US) trim(filename)) endif - call MOM_read_vector(filename, "dyCuo", "dxCvo", G%dy_Cu, G%dx_Cv, G%Domain, scale=US%m_to_L) + call get_param(param_file, mdl, "OPEN_DY_CU_VAR", dyCu_open_var, & + "The u-face open face length variable in CHANNEL_WIDTH_FILE.", & + default="dyCuo") + call get_param(param_file, mdl, "OPEN_DX_CV_VAR", dxCv_open_var, & + "The v-face open face length variable in CHANNEL_WIDTH_FILE.", & + default="dxCvo") + + call MOM_read_vector(filename, dyCu_open_var, dxCv_open_var, G%dy_Cu, G%dx_Cv, G%Domain, scale=US%m_to_L) call pass_vector(G%dy_Cu, G%dx_Cv, G%Domain, To_All+SCALAR_PAIR, CGRID_NE) do j=jsd,jed ; do I=IsdB,IedB @@ -806,7 +817,7 @@ subroutine reset_face_lengths_list(G, param_file, US) character(len=200) :: filename, chan_file, inputdir ! Strings for file/path character(len=40) :: mdl = "reset_face_lengths_list" ! This subroutine's name. real, allocatable, dimension(:,:) :: & - u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees] + u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees_N] or [degrees_E] real, allocatable, dimension(:) :: & u_width, v_width ! The open width of faces [m] integer, allocatable, dimension(:) :: & @@ -816,10 +827,10 @@ subroutine reset_face_lengths_list(G, param_file, US) Dmin_u, Dmax_u, Davg_u ! Porous barrier monomial fit params [m] real, allocatable, dimension(:) :: & Dmin_v, Dmax_v, Davg_v ! Porous barrier monomial fit params [m] - real :: lat, lon ! The latitude and longitude of a point. - real :: len_lon ! The periodic range of longitudes, usually 360 degrees. - real :: len_lat ! The range of latitudes, usually 180 degrees. - real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees. + real :: lat, lon ! The latitude and longitude of a point [degrees_N] and [degrees_E]. + real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. + real :: len_lat ! The range of latitudes, usually 180 degrees [degrees_N]. + real :: lon_p, lon_m ! The longitude of a point shifted by 360 degrees [degrees_E]. logical :: check_360 ! If true, check for longitudes that are shifted by ! +/- 360 degrees from the specified range of values. logical :: found_u, found_v diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0cd94d1e79..0f8beb4927 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1473,7 +1473,8 @@ subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read) !! parameters without changing u or v. ! Local variables character(len=40) :: mdl = "initialize_velocity_from_file" ! This subroutine's name. - character(len=200) :: filename,velocity_file,inputdir ! Strings for file/path + character(len=200) :: filename, velocity_file, inputdir ! Strings for file/path + character(len=64) :: u_IC_var, v_IC_var ! Velocity component names in files if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") @@ -1483,16 +1484,23 @@ subroutine initialize_velocity_from_file(u, v, G, GV, US, param_file, just_read) call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") inputdir = slasher(inputdir) - if (just_read) return ! All run-time parameters have been read, so return. - filename = trim(inputdir)//trim(velocity_file) - call log_param(param_file, mdl, "INPUTDIR/VELOCITY_FILE", filename) + if (.not.just_read) call log_param(param_file, mdl, "INPUTDIR/VELOCITY_FILE", filename) + + call get_param(param_file, mdl, "U_IC_VAR", u_IC_var, & + "The initial condition variable for zonal velocity in VELOCITY_FILE.", & + default="u") + call get_param(param_file, mdl, "V_IC_VAR", v_IC_var, & + "The initial condition variable for meridional velocity in VELOCITY_FILE.", & + default="v") + + if (just_read) return ! All run-time parameters have been read, so return. if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_velocity_from_file: Unable to open "//trim(filename)) ! Read the velocities from a netcdf file. - call MOM_read_vector(filename, "u", "v", u(:,:,:), v(:,:,:), G%Domain, scale=US%m_s_to_L_T) + call MOM_read_vector(filename, u_IC_var, v_IC_var, u(:,:,:), v(:,:,:), G%Domain, scale=US%m_s_to_L_T) call callTree_leave(trim(mdl)//'()') end subroutine initialize_velocity_from_file From 08c9aa1a9e744786165615ea8de34748cd4411da Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Nov 2022 05:46:45 -0500 Subject: [PATCH 038/629] *Fix bug with TIDAL_ENERGY_TYPE = "ER03" Corrected a bug in converting depths read from an input file from units of cm to m when the ER03 version of tidal mixing is used. This commit will change answers when INT_TIDE_DISSIPATION = True, USE_CVMix_TIDAL = True, and TIDAL_ENERGY_TYPE = "ER03". There are no such configurations in the MOM6-examples pipeline tests, and it is not clear whether or where such a configuration has ever been used. This bug was introduced into dev/gfdl on Nov. 19, 2018 as a part of PR #883 in commit https://github.com/NOAA-GFDL/MOM6/commit/967e470, which was supposed to be a refactoring of this portion of the code without changing answers, but introduced this bug. This commit should restore solutions with impacted configurations to what they would have been before that earlier commit. --- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 1528a644ec..75798ed466 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -1665,8 +1665,8 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain) call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain) ! Note the hard-coded assumption that z_t and z_w in the file are in centimeters. - call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=100.0*US%m_to_Z) - call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=100.0*US%m_to_Z) + call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=0.01*US%m_to_Z) + call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=0.01*US%m_to_Z) do j=js,je ; do i=is,ie if (abs(G%geoLatT(i,j)) < 30.0) then From 2ef7ba1c51cf1f3d3b7424dbd2eff94a693808b6 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Nov 2022 17:45:21 -0500 Subject: [PATCH 039/629] .testing: Use Fortran to generate tc inputs This patch removes the `build_{grid,data}.py` scripts from .testing's tc4, along with the setup of the Python infrastructure used in the .testing Makefile and GitHub Actions CI. The Python scripts have been replaced with equivalent Fortran programs which generate identical netCDF output. A new rule (`preproc`) has been added to the .testing top Makefile for generating the model input files. The netCDF compiler dependenices are configured with autoconf, currently duplicating the macros in `ac/configure.ac`. (NOTE: It may be possible to share these with a common macro in ac/m4. The configure script and Makefile are currently generated from `configure.ac` and `autoreconf`. In the future, we could simply pre-generate `configure` and add it to the repository. This patch was motivated by the inability to install recent netCDF-Python packages on systems with older gcc compilers, including our main production machine. We could have possibly resolved this by adding compiler configuration to pip, or perhaps reported the issue to the netCDF-python project for them to resolve. But the costs of relying on all this Python infrastructure is starting to exceed the benefits, and I would recommend we excise it from our test suite. --- .github/actions/testing-setup/action.yml | 12 -- .github/workflows/coupled-api.yml | 1 - .testing/Makefile | 91 ++++------- .testing/tc4/.gitignore | 13 +- .testing/tc4/Makefile | 8 - .testing/tc4/Makefile.in | 38 +++++ .testing/tc4/build_data.py | 80 ---------- .testing/tc4/build_grid.py | 76 --------- .testing/tc4/configure.ac | 71 +++++++++ .testing/tc4/gen_data.F90 | 189 +++++++++++++++++++++++ .testing/tc4/gen_grid.F90 | 108 +++++++++++++ 11 files changed, 448 insertions(+), 239 deletions(-) delete mode 100644 .testing/tc4/Makefile create mode 100644 .testing/tc4/Makefile.in delete mode 100644 .testing/tc4/build_data.py delete mode 100644 .testing/tc4/build_grid.py create mode 100644 .testing/tc4/configure.ac create mode 100644 .testing/tc4/gen_data.F90 create mode 100644 .testing/tc4/gen_grid.F90 diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml index 8a3264b140..6ba149d927 100644 --- a/.github/actions/testing-setup/action.yml +++ b/.github/actions/testing-setup/action.yml @@ -5,10 +5,6 @@ inputs: description: 'If true, will build the symmetric MOM6 executable' required: false default: 'true' - install_python: - description: 'If true, will install the local python env needed for .testing' - required: false - default: 'true' runs: using: 'composite' steps: @@ -54,14 +50,6 @@ runs: test ${{ inputs.build_symmetric }} == true && make build/symmetric/MOM6 -j echo "::endgroup::" - - name: Install local python venv for generating input data - shell: bash - run: | - echo "::group::Create local python env for input data generation" - cd .testing - test ${{ inputs.install_python }} == true && make work/local-env - echo "::endgroup::" - - name: Set flags shell: bash run: | diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 443755c7f4..2c9fa32720 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -20,7 +20,6 @@ jobs: - uses: ./.github/actions/testing-setup with: build_symmetric: 'false' - install_python: 'false' - name: Compile MOM6 for the GFDL coupled driver shell: bash diff --git a/.testing/Makefile b/.testing/Makefile index 530a552181..3e5c174239 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -11,7 +11,7 @@ # Delete the MOM6 test executables and dependency builds (FMS) # # make clean.build -# Delete only the MOM6 test executables +# Delete only the MOM6 test executables # # # Configuration: @@ -204,34 +204,11 @@ endif FMS_SOURCE = $(call SOURCE,deps/fms/src) -#--- -# Python preprocessing environment configuration - -HAS_NUMPY = $(shell python -c "import numpy" 2> /dev/null && echo "yes") -HAS_NETCDF4 = $(shell python -c "import netCDF4" 2> /dev/null && echo "yes") - -USE_VENV = -ifneq ($(HAS_NUMPY), yes) - USE_VENV = yes -endif -ifneq ($(HAS_NETCDF4), yes) - USE_VENV = yes -endif - -# When disabled, activation is a null operation (`true`) -VENV_PATH = -VENV_ACTIVATE = true -ifeq ($(USE_VENV), yes) - VENV_PATH = work/local-env - VENV_ACTIVATE = . $(VENV_PATH)/bin/activate -endif - - #--- # Rules .PHONY: all build.regressions build.prof -all: $(foreach b,$(BUILDS),build/$(b)) $(VENV_PATH) +all: $(foreach b,$(BUILDS),build/$(b)) build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) build.prof: $(foreach b,opt opt_target,build/$(b)/MOM6) @@ -382,8 +359,8 @@ deps/Makefile: ../ac/deps/Makefile # broken the ability to compile. This is not a means to build a complete # coupled executable. # TODO: -# - Avoid re-building FMS and MOM6 src by re-using existing object/mod files -# - Use autoconf rather than mkmf templates +# - Avoid re-building FMS and MOM6 src by re-using existing object/mod files +# - Use autoconf rather than mkmf templates MK_TEMPLATE ?= ../../deps/mkmf/templates/ncrc-gnu.mk # NUOPC driver @@ -402,21 +379,6 @@ build/mct/mom_ocean_model_mct.o: build/mct/Makefile check_mom6_api_mct: build/mct/mom_ocean_model_mct.o -#--- -# Python preprocessing - -# NOTE: Some less mature environments (e.g. Arm64 Ubuntu) require explicit -# installation of numpy before netCDF4, as well as wheel and cython support. -work/local-env: - python3 -m venv $@ - . $@/bin/activate \ - && python3 -m pip install --upgrade pip \ - && pip3 install wheel \ - && pip3 install cython \ - && pip3 install numpy \ - && pip3 install netCDF4 - - #--- # Testing @@ -555,6 +517,20 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) @echo -e "$(PASS): Diagnostics $*.regression.diag agree." +#--- +# Preprocessing +# NOTE: This only support tc4, but can be generalized over all tests. +.PHONY: preproc +preproc: tc4/Makefile + cd tc4 && make + +tc4/Makefile: tc4/configure tc4/Makefile.in + cd $(@D) && ./configure || (cat config.log && false) + +tc4/configure: tc4/configure.ac + cd $(@D) && autoreconf -if + + #--- # Test run output files @@ -567,17 +543,10 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # $(6): Number of MPI ranks define STAT_RULE -work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 $(VENV_PATH) +work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 | preproc @echo "Running test $$*.$(1)..." mkdir -p $$(@D) cp -RL $$*/* $$(@D) - if [ -f $$(@D)/Makefile ]; then \ - $$(VENV_ACTIVATE) \ - && cd $$(@D) \ - && $(MAKE); \ - else \ - cd $$(@D); \ - fi mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override rm -f results/$$*/std.$(1).{out,err} @@ -615,7 +584,7 @@ report.cov: run.cov codecov || { \ cat build/cov/codecov.err ; \ echo -e "${RED}Failed to upload report.${RESET}" ; \ - if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ + if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ } # Define $(,) as comma escape character @@ -643,17 +612,10 @@ $(eval $(call STAT_RULE,cov,cov,true,,,1)) # 2. Convert DAYMAX from TIMEUNIT to seconds # 3. Apply seconds to `ocean_solo_nml` inside input.nml. # NOTE: Assumes that runtime set by DAYMAX, will fail if set by input.nml -work/%/restart/ocean.stats: build/symmetric/MOM6 $(VENV_PATH) +work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc rm -rf $(@D) mkdir -p $(@D) cp -RL $*/* $(@D) - if [ -f $(@D)/Makefile ]; then \ - $(VENV_ACTIVATE) \ - && cd work/$*/restart \ - && $(MAKE); \ - else \ - cd work/$*/restart; \ - fi mkdir -p $(@D)/RESTART # Set the half-period cd $(@D) \ @@ -754,7 +716,7 @@ report.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov codecov || { \ cat build/unit/codecov.err ; \ echo -e "${RED}Failed to upload report.${RESET}" ; \ - if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ + if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ } @@ -833,6 +795,13 @@ clean.build: .PHONY: clean.stats -clean.stats: +clean.stats: clean.preproc @[ $$(basename $$(pwd)) = .testing ] rm -rf work results + + +.PHONY: clean.preproc +clean.preproc: + @if [ -f tc4/Makefile ] ; then \ + cd tc4 && make clean ; \ + fi diff --git a/.testing/tc4/.gitignore b/.testing/tc4/.gitignore index 29f62fb208..4f9cc2826f 100644 --- a/.testing/tc4/.gitignore +++ b/.testing/tc4/.gitignore @@ -1,4 +1,15 @@ +# Autoconf +aclocal.m4 +autom4te.cache/ +config.log +config.status +configure~ + +# Output +gen_grid ocean_hgrid.nc +topog.nc + +gen_data sponge.nc temp_salt_ic.nc -topog.nc diff --git a/.testing/tc4/Makefile b/.testing/tc4/Makefile deleted file mode 100644 index a9aa395b9c..0000000000 --- a/.testing/tc4/Makefile +++ /dev/null @@ -1,8 +0,0 @@ -OUT=ocean_hgrid.nc sponge.nc temp_salt_ic.nc topog.nc - -$(OUT): - python build_grid.py - python build_data.py - -clean: - rm -rf $(OUT) diff --git a/.testing/tc4/Makefile.in b/.testing/tc4/Makefile.in new file mode 100644 index 0000000000..249d86b0b6 --- /dev/null +++ b/.testing/tc4/Makefile.in @@ -0,0 +1,38 @@ +FC = @FC@ +LD = @LD@ +FCFLAGS = @FCFLAGS@ +LDFLAGS = @LDFLAGS@ +LIBS = @LIBS@ + +OUT = topog.nc ocean_hgrid.nc temp_salt_ic.nc sponge.nc + +all: $(OUT) + +ocean_hgrid.nc topog.nc: gen_grid + ./gen_grid + +temp_salt_ic.nc sponge.nc: gen_data + ./gen_data + +gen_grid: gen_grid.F90 + $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + +gen_data: gen_data.F90 + $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + +.PHONY: clean +clean: + rm -rf $(OUT) gen_grid gen_data + +.PHONY: distclean +distclean: clean + rm -f config.log + rm -f config.status + rm -f Makefile + +.PHONY: ac-clean +ac-clean: distclean + rm -f aclocal.m4 + rm -rf autom4te.cache + rm -f configure + rm -f configure~ diff --git a/.testing/tc4/build_data.py b/.testing/tc4/build_data.py deleted file mode 100644 index e060d05cb1..0000000000 --- a/.testing/tc4/build_data.py +++ /dev/null @@ -1,80 +0,0 @@ -import netCDF4 as nc -import numpy as np - -x = nc.Dataset('ocean_hgrid.nc').variables['x'][1::2, 1::2] -y = nc.Dataset('ocean_hgrid.nc').variables['y'][1::2, 1::2] -zbot = nc.Dataset('topog.nc').variables['depth'][:] -zbot0 = zbot.max() - - -def t_fc(x, y, z, radius=5.0, tmag=1.0): - """a radially symmetric anomaly in the center of the domain. - units are meters and degC. - """ - ny, nx = x.shape - nz = z.shape[0] - - x0 = x[int(ny/2), int(nx/2)] - y0 = y[int(ny/2), int(nx/2)] - - tl = np.zeros((nz, ny, nx)) - zb = z[-1] - if len(z) > 1: - zd = z / zb - else: - zd = [0.] - for k in np.arange(len(zd)): - r = np.sqrt((x - x0)**2 + (y - y0)**2) - tl[k, :] += (1.0 - np.minimum(r / radius, 1.0)) * tmag * (1.0 - zd[k]) - return tl - - -ny, nx = x.shape -nz = 3 -z = (np.arange(nz) * zbot0) / nz - -temp = t_fc(x, y, z) -salt = np.zeros(temp.shape)+35.0 -fl = nc.Dataset('temp_salt_ic.nc', 'w', format='NETCDF3_CLASSIC') -fl.createDimension('lon', nx) -fl.createDimension('lat', ny) -fl.createDimension('depth', nz) -fl.createDimension('Time', None) -zv = fl.createVariable('depth', 'f8', ('depth')) -lonv = fl.createVariable('lon', 'f8', ('lon')) -latv = fl.createVariable('lat', 'f8', ('lat')) -timev = fl.createVariable('Time', 'f8', ('Time')) -timev.calendar = 'noleap' -timev.units = 'days since 0001-01-01 00:00:00.0' -timev.modulo = ' ' -tv = fl.createVariable('ptemp', 'f8', ('Time', 'depth', 'lat', 'lon'), - fill_value=-1.e20) -sv = fl.createVariable('salt', 'f8', ('Time', 'depth', 'lat', 'lon'), - fill_value=-1.e20) -tv[:] = temp[np.newaxis, :] -sv[:] = salt[np.newaxis, :] -zv[:] = z -lonv[:] = x[0, :] -latv[:] = y[:, 0] -timev[0] = 0. -fl.sync() -fl.close() - - -# Make Sponge forcing file -dampTime = 20.0 # days -secDays = 8.64e4 -fl = nc.Dataset('sponge.nc', 'w', format='NETCDF3_CLASSIC') -fl.createDimension('lon', nx) -fl.createDimension('lat', ny) -lonv = fl.createVariable('lon', 'f8', ('lon')) -latv = fl.createVariable('lat', 'f8', ('lat')) -spv = fl.createVariable('Idamp', 'f8', ('lat', 'lon'), fill_value=-1.e20) -Idamp = np.zeros((ny, nx)) -if dampTime > 0.: - Idamp = 0.0 + 1.0 / (dampTime * secDays) -spv[:] = Idamp -lonv[:] = x[0, :] -latv[:] = y[:, 0] -fl.sync() -fl.close() diff --git a/.testing/tc4/build_grid.py b/.testing/tc4/build_grid.py deleted file mode 100644 index 7f1be74efd..0000000000 --- a/.testing/tc4/build_grid.py +++ /dev/null @@ -1,76 +0,0 @@ -import netCDF4 as nc -from netCDF4 import stringtochar -import numpy as np - -nx, ny = 14, 10 # Grid size -depth0 = 100. # Uniform depth -ds = 0.01 # grid resolution at the equator in degrees -Re = 6.378e6 # Radius of earth - -topo_ = np.zeros((ny, nx)) + depth0 -f_topo = nc.Dataset('topog.nc', 'w', format='NETCDF3_CLASSIC') -ny, nx = topo_.shape -f_topo.createDimension('ny', ny) -f_topo.createDimension('nx', nx) -f_topo.createDimension('ntiles', 1) -f_topo.createVariable('depth', 'f8', ('ny', 'nx')) -f_topo.createVariable('h2', 'f8', ('ny', 'nx')) -f_topo.variables['depth'][:] = topo_ -f_topo.sync() -f_topo.close() - -x_ = np.arange(0, 2*nx + 1) * ds # units are degrees E -y_ = np.arange(0, 2*ny + 1) * ds # units are degrees N -x, y = np.meshgrid(x_, y_) - -dx = np.zeros((2*ny + 1, 2*nx)) -dy = np.zeros((2*ny, 2*nx + 1)) -rad_deg = np.pi / 180. -dx[:] = (rad_deg * Re * (x[:, 1:] - x[:, 0:-1]) - * np.cos(0.5*rad_deg*(y[:, 0:-1] + y[:, 1:]))) -dy[:] = rad_deg * Re * (y[1:, :] - y[0:-1, :]) - -f_sg = nc.Dataset('ocean_hgrid.nc', 'w', format='NETCDF3_CLASSIC') -f_sg.createDimension('ny', 2*ny) -f_sg.createDimension('nx', 2*nx) -f_sg.createDimension('nyp', 2*ny + 1) -f_sg.createDimension('nxp', 2*nx + 1) -f_sg.createDimension('string', 5) -f_sg.createVariable('y', 'f8', ('nyp', 'nxp')) -f_sg.createVariable('x', 'f8', ('nyp', 'nxp')) -dyv = f_sg.createVariable('dy', 'f8', ('ny', 'nxp')) -dxv = f_sg.createVariable('dx', 'f8', ('nyp', 'nx')) -areav = f_sg.createVariable('area', 'f8', ('ny', 'nx')) -dxv.units = 'm' -dyv.units = 'm' -areav.units = 'm2' -f_sg.createVariable('angle_dx', 'f8', ('nyp', 'nxp')) -f_sg.createVariable('tile', 'S1', ('string')) -f_sg.variables['y'].units = 'degrees' -f_sg.variables['x'].units = 'degrees' -f_sg.variables['dy'].units = 'meters' -f_sg.variables['dx'].units = 'meters' -f_sg.variables['area'].units = 'm2' -f_sg.variables['angle_dx'].units = 'degrees' -f_sg.variables['y'][:] = y -f_sg.variables['x'][:] = x -f_sg.variables['dx'][:] = dx -f_sg.variables['dy'][:] = dy - -# Compute the area bounded by lines of constant -# latitude-longitud on a sphere in m2. -dlon = x_[1:] - x_[:-1] -dlon = np.tile(dlon[np.newaxis, :], (2*ny, 1)) -y1_ = y_[:-1] -y1_ = y1_[:, np.newaxis]*rad_deg -y2_ = y_[1:] -y2_ = y2_[:, np.newaxis]*rad_deg -y1_ = np.tile(y1_, (1, 2*nx)) -y2_ = np.tile(y2_, (1, 2*nx)) -area = rad_deg * Re * Re * (np.sin(y2_) - np.sin(y1_)) * dlon -f_sg.variables['area'][:] = area -f_sg.variables['angle_dx'][:] = 0. -str_ = stringtochar(np.array(['tile1'], dtype='S5')) -f_sg.variables['tile'][:] = str_ -f_sg.sync() -f_sg.close() diff --git a/.testing/tc4/configure.ac b/.testing/tc4/configure.ac new file mode 100644 index 0000000000..c431ad65ef --- /dev/null +++ b/.testing/tc4/configure.ac @@ -0,0 +1,71 @@ +# tc4 preprocessor configuration +AC_PREREQ([2.63]) +AC_INIT([], []) + +# Validate srdcir and configure input +AC_CONFIG_SRCDIR([gen_grid.F90]) +AC_CONFIG_MACRO_DIR([../../ac/m4]) + + +# Explicitly assume free-form Fortran +AC_LANG([Fortran]) +AC_FC_SRCEXT([f90]) + +# We do not need MPI, but we want to emulate the executable used in MOM6 +AX_MPI([], [AC_MSG_ERROR([Could not find MPI launcher.])]) +AC_SUBST([FC], [$MPIFC]) +AC_SUBST([LD], [$MPILD]) + + +# netCDF configuration + +# Search for the Fortran netCDF module. +AX_FC_CHECK_MODULE([netcdf], [], [ + AS_UNSET([ax_fc_cv_mod_netcdf]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([FCFLAGS], ["$FCFLAGS -I$($NF_CONFIG --includedir)"]) + ], [AC_MSG_ERROR([Could not find nf-config.])] + ) + AX_FC_CHECK_MODULE([netcdf], [], [ + AC_MSG_ERROR([Could not find netcdf module.]) + ]) +]) + +# Confirm that the Fortran compiler can link the netCDF C library +AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AS_UNSET([ax_fc_cv_c_lib_netcdf_nc_create]) + AC_PATH_PROG([NC_CONFIG], [nc-config]) + AS_IF([test -n "$NC_CONFIG"], [ + AC_SUBST([LDFLAGS], ["$LDFLAGS -L$($NC_CONFIG --libdir)"]) + ], [ + AC_MSG_ERROR([Could not find nc-config.]) + ]) + AX_FC_CHECK_C_LIB([netcdf], [nc_create], [], [ + AC_MSG_ERROR([Could not find netCDF C library.]) + ]) +]) + +# Confirm that the Fortran compiler can link to the netCDF Fortran library. +# NOTE: +# - We test nf_create, rather than nf90_create, since AX_FC_CHECK_LIB can +# not currently probe the Fortran 90 interfaces. +# - nf-config does not have --libdir, so we parse the --flibs output. +AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [ + AS_UNSET([ax_fc_cv_lib_netcdff_nf_create]) + AC_PATH_PROG([NF_CONFIG], [nf-config]) + AS_IF([test -n "$NF_CONFIG"], [ + AC_SUBST([LDFLAGS], + ["$LDFLAGS $($NF_CONFIG --flibs | xargs -n1 | grep "^-L" | sort -u | xargs)"] + ) + ], [ + AC_MSG_ERROR([Could not find nf-config.]) + ]) + AX_FC_CHECK_LIB([netcdff], [nf_create], [], [], [ + AC_MSG_ERROR([Could not find netCDF Fortran library.]) + ]) +]) + + +AC_CONFIG_FILES([Makefile]) +AC_OUTPUT diff --git a/.testing/tc4/gen_data.F90 b/.testing/tc4/gen_data.F90 new file mode 100644 index 0000000000..8f44aa1465 --- /dev/null +++ b/.testing/tc4/gen_data.F90 @@ -0,0 +1,189 @@ +use netcdf +implicit none + +integer, parameter :: dp = selected_real_kind(10, 100) + !! Double precision (8-byte) + +integer, parameter :: nz = 3 + !! Number of vertical layers +real(kind=dp), parameter :: salt0 = 35._dp + !! Background salinity +real(kind=dp), parameter :: dampTime = 20._dp + !! Sponge damping timescale [days] +real(kind=dp), parameter :: secs_per_day = 86400._dp + !! Seconds per calendar day + +integer :: ncid + +integer :: x_id, y_id +integer :: lon_dimid, lat_dimid, depth_dimid, time_dimid +integer :: lon_id, lat_id, depth_id, time_id, temp_id, salt_id, idamp_id +integer :: field_dimids(2) +integer :: nx, ny + +integer :: i, rc + +real(kind=dp), allocatable :: x(:,:), y(:,:), z(:) + !! Temperature grid positions +real(kind=dp), allocatable :: zbot(:,:) + !! Bottom topography +real(kind=dp) :: zbot0 + !! Maximum topographic depth +real(kind=dp), allocatable :: temp(:,:,:), salt(:,:,:) + !! Initial temperature and salinity fields +real(kind=dp), allocatable :: Idamp(:,:) + !! Sponge dampening rate + +! Read the domain grid +rc = nf90_open('ocean_hgrid.nc', NF90_NOWRITE, ncid) + +rc = nf90_inq_varid(ncid, 'x', x_id) +rc = nf90_inq_varid(ncid, 'y', y_id) + +rc = nf90_inquire_variable(ncid, x_id, dimids=field_dimids) +rc = nf90_inquire_dimension(ncid, field_dimids(1), len=nx) +rc = nf90_inquire_dimension(ncid, field_dimids(2), len=ny) + +! Extract center ("T") points of supergrid +nx = nx / 2 +ny = ny / 2 +allocate(x(nx, ny), y(nx, ny)) +rc = nf90_get_var(ncid, x_id, x, start=[2,2], stride=[2,2]) +rc = nf90_get_var(ncid, y_id, y, start=[2,2], stride=[2,2]) + +rc = nf90_close(ncid) + + +! Read the topographic domain +rc = nf90_open('topog.nc', NF90_NOWRITE, ncid) + +rc = nf90_inq_varid(ncid, 'depth', depth_id) +rc = nf90_inquire_variable(ncid, depth_id, dimids=field_dimids) +rc = nf90_inquire_dimension(ncid, field_dimids(1), len=nx) +rc = nf90_inquire_dimension(ncid, field_dimids(2), len=ny) + +allocate(zbot(nx, ny)) +rc = nf90_get_var(ncid, depth_id, zbot) +rc = nf90_close(ncid) + + +! Construct the vertical axis +allocate(z(nz)) +z = [(i, i=0,nz-1)] * maxval(zbot) / nz + +allocate(temp(nx, ny, nz), salt(nx, ny, nz)) +call t_fc(x, y, z, temp) +salt(:,:,:) = salt0 + + +! Write T/S initial state +rc = nf90_create('temp_salt_ic.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'lon', nx, lon_dimid) +rc = nf90_def_dim(ncid, 'lat', ny, lat_dimid) +rc = nf90_def_dim(ncid, 'depth', nz, depth_dimid) +rc = nf90_def_dim(ncid, 'Time', NF90_UNLIMITED, time_dimid) + +rc = nf90_def_var(ncid, 'depth', NF90_DOUBLE, [depth_dimid], depth_id) +rc = nf90_def_var(ncid, 'lon', NF90_DOUBLE, [lon_dimid], lon_id) +rc = nf90_def_var(ncid, 'lat', NF90_DOUBLE, [lat_dimid], lat_id) +rc = nf90_def_var(ncid, 'Time', NF90_DOUBLE, [time_dimid], time_id) + +rc = nf90_put_att(ncid, time_id, 'calendar', 'noleap') +rc = nf90_put_att(ncid, time_id, 'units', 'days since 0001-01-01 00:00:00.0') +! NOTE: nf90_put_att() truncates empty strings, so use nf90_put_att_any() +rc = nf90_put_att_any(ncid, time_id, 'modulo', NF90_CHAR, 1, ' ') + +rc = nf90_def_var(ncid, 'ptemp', NF90_DOUBLE, & + [lon_dimid, lat_dimid, depth_dimid, time_dimid], temp_id) +rc = nf90_def_var_fill(ncid, temp_id, 0, -1e20_dp) + +rc = nf90_def_var(ncid, 'salt', NF90_DOUBLE, & + [lon_dimid, lat_dimid, depth_dimid, time_dimid], salt_id) +rc = nf90_def_var_fill(ncid, salt_id, 0, -1e20_dp) + +rc = nf90_enddef(ncid) + +rc = nf90_put_var(ncid, lon_id, x(:,1)) +rc = nf90_put_var(ncid, lat_id, y(1,:)) +rc = nf90_put_var(ncid, depth_id, z) +rc = nf90_put_var(ncid, time_id, 0.) +rc = nf90_put_var(ncid, temp_id, temp) +rc = nf90_put_var(ncid, salt_id, salt) + +rc = nf90_close(ncid) + + +! Sponge file +rc = nf90_create('sponge.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'lon', nx, lon_dimid) +rc = nf90_def_dim(ncid, 'lat', ny, lat_dimid) + +rc = nf90_def_var(ncid, 'lon', NF90_DOUBLE, lon_id) +rc = nf90_def_var(ncid, 'lat', NF90_DOUBLE, lat_id) +rc = nf90_def_var(ncid, 'Idamp', NF90_DOUBLE, [lon_dimid, lat_dimid], Idamp_id) +rc = nf90_def_var_fill(ncid, Idamp_id, 0, -1e20_dp) + +rc = nf90_enddef(ncid) + +allocate(Idamp(nx, ny)) +Idamp = 0. +if (dampTime > 0.) & + Idamp(:,:) = 1. / (dampTime * secs_per_day) + +rc = nf90_put_var(ncid, Idamp_id, Idamp) +rc = nf90_put_var(ncid, lon_id, x(:,1)) +rc = nf90_put_var(ncid, lat_id, y(1,:)) + +rc = nf90_close(ncid) + +contains + +subroutine t_fc(x, y, z, tl, radius, tmag) + real(kind=dp), intent(in) :: x(:,:), y(:,:), z(:) + !! Grid positions + real(kind=dp), intent(inout) :: tl(:,:,:) + !! Temperature field on the model grid + real(kind=dp), intent(in), optional :: radius + !! Temperature anomaly radius + real(kind=dp), intent(in), optional :: tmag + !! Temperature anomaly maximum + + real(kind=dp) :: t_rad, t_max + !! Temperature field parameters (radius, max value) + real(kind=dp) :: x0, y0 + !! Center of anomaly (currently midpoint of domain) + real(kind=dp), allocatable :: r(:,:), zd(:) + !! Radial and vertical extent of anomaly + integer :: k, nz + !! Vertical level indexing + + t_rad = 5._dp + if (present(radius)) t_rad = radius + + t_max = 1._dp + if (present(tmag)) t_max = tmag + + ! Reduce supergrid size to T/S grid + allocate(zd, source=z) + + x0 = x(1 + size(x, 1)/2, 1 + size(x, 2)/2) + y0 = y(1 + size(y, 1)/2, 1 + size(y, 2)/2) + + tl(:,:,:) = 0. + nz = size(z) + if (nz > 1) then + zd(:) = z(:) / z(nz) + else + zd(:) = 0. + endif + + allocate(r, source=x) + r(:,:) = hypot(x(:,:) - x0, y(:,:) - y0) + do k = 1, nz + tl(:,:,k) = (1. - min(r(:,:) / t_rad, 1.)) * t_max * (1. - zd(k)) + enddo +end subroutine t_fc + +end diff --git a/.testing/tc4/gen_grid.F90 b/.testing/tc4/gen_grid.F90 new file mode 100644 index 0000000000..e76a681924 --- /dev/null +++ b/.testing/tc4/gen_grid.F90 @@ -0,0 +1,108 @@ +use netcdf + +implicit none + +integer, parameter :: dp = selected_real_kind(10, 100) + !! Double precision (8-byte) + +integer, parameter :: nx = 14, ny = 10 + !! Grid size +real(kind=dp), parameter :: depth0 = 100._dp + !! Uniform depth +real(kind=dp), parameter :: ds = 0.01_dp + !! Grid resolution at the equator in degrees +real(kind=dp), parameter :: Re = 6.378e6_dp + !! Radius of earth +real(kind=dp), parameter :: rad_per_deg = (4. * atan(1._dp)) / 180._dp + !! Degress to radians (= pi/180.) + +integer :: ncid +integer :: nx_id, ny_id, nxp_id, nyp_id, ntile_id, string_id +integer :: depth_id, h2_id +integer :: x_id, y_id, dx_id, dy_id, area_id, angle_id, tile_id + +! Fields on model grid +real(kind=dp) :: depth(nx, ny) + +! Grid fields (defined on supergrid) +real(kind=dp) :: xg(0:2*nx), yg(0:2*ny) +real(kind=dp) :: x(0:2*nx, 0:2*ny), y(0:2*nx, 0:2*ny) +real(kind=dp) :: dx(0:2*nx-1, 0:2*ny) +real(kind=dp) :: dy(0:2*nx, 0:2*ny-1) +real(kind=dp) :: area(0:2*nx-1, 0:2*ny-1) +real(kind=dp) :: angle_dx(0:2*nx, 0:2*ny) + +integer :: i, j, rc + + +! Topography +rc = nf90_create('topog.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'ny', ny, ny_id) +rc = nf90_def_dim(ncid, 'nx', nx, nx_id) +rc = nf90_def_dim(ncid, 'ntiles', 1, ntile_id) + +rc = nf90_def_var(ncid, 'depth', NF90_DOUBLE, [nx_id, ny_id], depth_id) +rc = nf90_def_var(ncid, 'h2', NF90_DOUBLE, [nx_id, ny_id], h2_id) + +rc = nf90_enddef(ncid) + +depth(:,:) = depth0 +rc = nf90_put_var(ncid, depth_id, depth) + +rc = nf90_close(ncid) + + +! Horizontal grid +rc = nf90_create('ocean_hgrid.nc', NF90_CLOBBER, ncid) + +rc = nf90_def_dim(ncid, 'ny', 2*ny, ny_id) +rc = nf90_def_dim(ncid, 'nx', 2*nx, nx_id) +rc = nf90_def_dim(ncid, 'nyp', 2*ny+1, nyp_id) +rc = nf90_def_dim(ncid, 'nxp', 2*nx+1, nxp_id) +rc = nf90_def_dim(ncid, 'string', 5, string_id) + +rc = nf90_def_var(ncid, 'y', NF90_DOUBLE, [nxp_id, nyp_id], y_id) +rc = nf90_def_var(ncid, 'x', NF90_DOUBLE, [nxp_id, nyp_id], x_id) +rc = nf90_def_var(ncid, 'dy', NF90_DOUBLE, [nxp_id, ny_id], dy_id) +rc = nf90_def_var(ncid, 'dx', NF90_DOUBLE, [nx_id, nyp_id], dx_id) +rc = nf90_def_var(ncid, 'area', NF90_DOUBLE, [nx_id, ny_id], area_id) +rc = nf90_def_var(ncid, 'angle_dx', NF90_DOUBLE, [nxp_id, nyp_id], angle_id) +rc = nf90_def_var(ncid, 'tile', NF90_CHAR, string_id, tile_id) + +rc = nf90_put_att(ncid, y_id, 'units', 'degrees') +rc = nf90_put_att(ncid, x_id, 'units', 'degrees') +rc = nf90_put_att(ncid, dy_id, 'units', 'meters') +rc = nf90_put_att(ncid, dx_id, 'units', 'meters') +rc = nf90_put_att(ncid, area_id, 'units', 'm2') +rc = nf90_put_att(ncid, angle_id, 'units', 'degrees') + +rc = nf90_enddef(ncid) + +xg = ds * [(i, i=0, 2*nx)] +yg = ds * [(j, j=0, 2*ny)] + +! NOTE: sin() and cos() are compiler-dependent + +x(:,:) = spread(xg(:), 2, 2*ny+1) +y(:,:) = spread(yg(:), 1, 2*nx+1) +dx(:,:) = rad_per_deg * Re * (x(1:,:) - x(:2*nx-1,:)) & + * cos(0.5 * rad_per_deg * (y(1:,:) + y(:2*nx-1,:))) +dy(:,:) = rad_per_deg * Re * (y(:,1:) - y(:,:2*ny-1)) + +area(:,:) = rad_per_deg * Re * Re & + * spread(sin(rad_per_deg * yg(1:)) - sin(rad_per_deg * yg(:2*ny-1)), 1, 2*nx) & + * spread(xg(1:) - xg(:2*nx-1), 2, 2*ny) + +angle_dx(:,:) = 0. + +rc = nf90_put_var(ncid, x_id, x) +rc = nf90_put_var(ncid, y_id, y) +rc = nf90_put_var(ncid, dx_id, dx) +rc = nf90_put_var(ncid, dy_id, dy) +rc = nf90_put_var(ncid, area_id, area) +rc = nf90_put_var(ncid, angle_id, angle_dx) +rc = nf90_put_var(ncid, tile_id, 'tile1') + +rc = nf90_close(ncid) +end From 56cf1252a8d868a561326cbba8cc44cc613dbf77 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 21 Nov 2022 14:39:41 -0500 Subject: [PATCH 040/629] Remove Python venv setup from GitLab-CI rules GitLab CI includes the internal testing suite (.testing) and included an explicit setup of the Python environment (`make work/local-env`). The rule has since been removed, and the command now fails. This patch removes those steps, since we no longer use Python in the tests. It also slightly reworks the reporting of test output. Instead of re-running `make test`, it uses the `make test.summary` rule to report the final result. --- .gitlab-ci.yml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6a622f55cc..fbc2854b33 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -26,7 +26,7 @@ p:merge: # Setup the persistent JOB_DIR for all subsequent stages # -# This basically setups up a complete tree much as a user would in their workflow +# This basically setups up a complete tree much as a user would in their workflow p:clone: stage: setup tags: @@ -181,11 +181,11 @@ actions:gnu: - 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 - - make work/local-env - make -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" 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 && make test || ( cat log.$CI_JOB_ID ; exit 911 ) + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" 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 test.summary actions:intel: stage: tests @@ -200,11 +200,11 @@ actions:intel: - 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 - - make work/local-env - make -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - - (echo '#!/bin/bash';echo '. ./work/local-env/bin/activate';echo 'make MPIRUN="srun -mblock --exclusive" 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 && make test || ( cat log.$CI_JOB_ID ; exit 911 ) + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" 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 test.summary # Tests # From b918b2ad5907a866ec27ea7888db606b1ff79774 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 25 Oct 2022 12:17:27 -0400 Subject: [PATCH 041/629] +Add mask_edges argument to interpolate_column Added a new logical argument to interpolate_column to specify whether the interpolated interface values outside of massless layers should be masked to zero. Also refactored the code in interpolate_column to separate out the determination of the interface position from the interpolation and the masking to facilitate the extension of this code to use higher order interpolation in planned subsequent changes. All answers are bitwise identical, although there is a new mandatory argument for a public interface. --- src/ALE/MOM_ALE.F90 | 2 +- src/ALE/MOM_remapping.F90 | 86 +++++++++++++++----------------- src/framework/MOM_diag_remap.F90 | 6 +-- 3 files changed, 44 insertions(+), 50 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index ec71e15bbd..9f8b2336f9 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -554,7 +554,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) if (check_column_integrals(nk, h_src, nk, h_dest)) then call MOM_error(FATAL, "ALE_offline_inputs: Kd interpolation columns do not match") endif - call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), Kd(i,j,:)) + call interpolate_column(nk, h(i,j,:), Kd(i,j,:), nk, h_new(i,j,:), Kd(i,j,:), .true.) endif enddo ; enddo diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index bfd74b435c..e9d9a53612 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -840,78 +840,72 @@ subroutine remap_via_sub_cells( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, h1, meth end subroutine remap_via_sub_cells !> Linearly interpolate interface data, u_src, from grid h_src to a grid h_dest -subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest) +subroutine interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, mask_edges) integer, intent(in) :: nsrc !< Number of source cells real, dimension(nsrc), intent(in) :: h_src !< Thickness of source cells [H] real, dimension(nsrc+1), intent(in) :: u_src !< Values at source cell interfaces [A] integer, intent(in) :: ndest !< Number of destination cells real, dimension(ndest), intent(in) :: h_dest !< Thickness of destination cells [H] real, dimension(ndest+1), intent(inout) :: u_dest !< Interpolated value at destination cell interfaces [A] + logical, intent(in) :: mask_edges !< If true, mask the values outside of massless + !! layers at the top and bottom of the column. ! Local variables - real :: x_dest ! Relative position of target interface [H] - real :: dh ! Source cell thickness [H] - real :: u1, u2 ! Values to interpolate between [A] - real :: weight_a, weight_b ! Weights for interpolation [nondim] - integer :: k_src, k_dest ! Index of cell in src and dest columns - logical :: still_vanished ! Used for figuring out what to mask as missing - - ! Initial values for the loop - still_vanished = .true. + real :: x_dest ! Relative position of target interface [H] + real :: dh ! Source cell thickness [H] + real :: frac_pos(ndest+1) ! Fractional position of the destination interface + ! within the source layer [nondim], 0 <= frac_pos <= 1. + integer :: k_src(ndest+1) ! Source grid layer index of destination interface, 1 <= k_src <= ndest. + integer :: ks, k_dest ! Index of cell in src and dest columns ! The following forces the "do while" loop to do one cycle that will set u1, u2, dh. - k_src = 0 + ks = 0 dh = 0. x_dest = 0. - do k_dest=1, ndest+1 - do while (dh<=x_dest .and. k_src0.) then - weight_b = max(0., min(1., x_dest / dh)) ! Weight of u2 + frac_pos(k_dest) = max(0., min(1., x_dest / dh)) ! Weight of u2 else ! For a vanished source layer we need to do something reasonable... - weight_b = 0.5 + frac_pos(k_dest) = 0.5 endif - weight_a = 1.0 - weight_b ! Weight of u1 - ! Linear interpolation between u1 and u2 - u_dest(k_dest) = weight_a * u1 + weight_b * u2 - ! Mask vanished layers at the surface which would be under an ice-shelf. - ! TODO: Need to figure out what to do for an isopycnal coordinate diagnostic that could - ! also have vanished layers at the surface. - if (k_dest<=ndest) then + if (k_dest <= ndest) then x_dest = x_dest + h_dest(k_dest) ! Position of interface k_dest+1 - if (still_vanished .and. h_dest(k_dest)==0.) then - ! When the layer k_dest is vanished and all layers above are also vanished, the k_dest - ! interface value should be missing. - u_dest(k_dest) = 0.0 - else - still_vanished = .false. - endif endif + enddo + do k_dest=1,ndest+1 + ! Linear interpolation between surrounding edge values. + ks = k_src(k_dest) + u_dest(k_dest) = (1.0 - frac_pos(k_dest)) * u_src(ks) + frac_pos(k_dest) * u_src(ks+1) enddo - ! Mask vanished layers on topography - still_vanished = .true. - do k_dest=ndest, 1, -1 - if (still_vanished .and. h_dest(k_dest)==0.) then - ! When the layer k_dest is vanished and all layers below are also vanished, the k_dest+1 - ! interface value should be missing. + if (mask_edges) then + ! Mask vanished layers at the surface which would be under an ice-shelf. + ! When the layer k_dest is vanished and all layers above are also vanished, + ! the k_dest interface value should be missing. + do k_dest=1,ndest + if (h_dest(k_dest) > 0.) exit + u_dest(k_dest) = 0.0 + enddo + + ! Mask interfaces below vanished layers at the bottom + do k_dest=ndest,1,-1 + if (h_dest(k_dest) > 0.) exit u_dest(k_dest+1) = 0.0 - else - exit - endif - enddo + enddo + endif end subroutine interpolate_column @@ -1717,7 +1711,7 @@ logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_ real :: error ! Interpolate from src to dest - call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest) + call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) test_interp = .false. do k=1,ndest+1 diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 05bd8aeed0..cd5682d2d9 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -608,7 +608,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) call interpolate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, interpolated_field(I1,j,:)) + nz_dest, h_dest, interpolated_field(I1,j,:), .true.) enddo enddo elseif (staggered_in_y .and. .not. staggered_in_x) then @@ -623,7 +623,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) call interpolate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, interpolated_field(i,J1,:)) + nz_dest, h_dest, interpolated_field(i,J1,:), .true.) enddo enddo elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then @@ -636,7 +636,7 @@ subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, sta h_src(:) = h(i,j,:) h_dest(:) = remap_cs%h(i,j,:) call interpolate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, interpolated_field(i,j,:)) + nz_dest, h_dest, interpolated_field(i,j,:), .true.) enddo enddo else From 14f94821845b54fee9bc8f5c1012ac2a89f4ee32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 26 Oct 2022 15:56:02 -0400 Subject: [PATCH 042/629] +Add ALE_remap_interface_vals and ALE_remap_vertex_vals Added ALE_remap_interface_vals and ALE_remap_vertex_vals to handle the interpolation of variables that are at the interfaces atop tracer cells or above the corners of the tracers cells from one grid to another. Because these are not yet used (but have been tested in calls that will be added with the next commit) all answers are bitwise identical, but there are two new publicly visible routines. --- src/ALE/MOM_ALE.F90 | 93 +++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 89 insertions(+), 4 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 9f8b2336f9..2a9ebc09c8 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -129,6 +129,8 @@ module MOM_ALE public ALE_remap_scalar public ALE_remap_tracers public ALE_remap_velocities +public ALE_remap_interface_vals +public ALE_remap_vertex_vals public ALE_PLM_edge_values public TS_PLM_edge_values public TS_PPM_edge_values @@ -289,10 +291,10 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call set_regrid_params(CS%regridCS, depth_of_time_filter_shallow=filter_shallow_depth, & depth_of_time_filter_deep=filter_deep_depth) call get_param(param_file, mdl, "REGRID_USE_OLD_DIRECTION", local_logical, & - "If true, the regridding ntegrates upwards from the bottom for "//& + "If true, the regridding integrates upwards from the bottom for "//& "interface positions, much as the main model does. If false "//& - "regridding integrates downward, consistant with the remapping "//& - "code.", default=.true., do_not_log=.true.) + "regridding integrates downward, consistent with the remapping code.", & + default=.true., do_not_log=.true.) call set_regrid_params(CS%regridCS, integrate_downward_for_e=.not.local_logical) call get_param(param_file, mdl, "REMAP_VEL_MASK_BBL_THICK", CS%BBL_h_vel_mask, & @@ -549,7 +551,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) endif enddo ; enddo - do j = jsc,jec ; do i=isc,iec + do j=jsc,jec ; do i=isc,iec if (G%mask2dT(i,j)>0.) then if (check_column_integrals(nk, h_src, nk, h_dest)) then call MOM_error(FATAL, "ALE_offline_inputs: Kd interpolation columns do not match") @@ -974,6 +976,89 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, end subroutine ALE_remap_velocities +!> Interpolate to find an updated array of values at interfaces after remapping. +subroutine ALE_remap_interface_vals(CS, G, GV, h_old, h_new, int_val) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + intent(inout) :: int_val !< The interface values to interpolate [A] + + real :: val_src(GV%ke+1) ! A column of interface values on the source grid [A] + real :: val_tgt(GV%ke+1) ! A column of interface values on the target grid [A] + real :: h_src(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h_tgt(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + integer :: i, j, k, nz + + nz = GV%ke + + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (G%mask2dT(i,j)>0.) then + do k=1,nz + h_src(k) = h_old(i,j,k) + h_tgt(k) = h_new(i,j,k) + enddo + + do K=1,nz+1 + val_src(K) = int_val(i,j,K) + enddo + + call interpolate_column(nz, h_src, val_src, nz, h_tgt, val_tgt, .false.) + + do K=1,nz+1 + int_val(i,j,K) = val_tgt(K) + enddo + endif ; enddo ; enddo + +end subroutine ALE_remap_interface_vals + +!> Interpolate to find an updated array of values at vertices of tracer cells after remapping. +subroutine ALE_remap_vertex_vals(CS, G, GV, h_old, h_new, vert_val) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid + !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid + !! [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & + intent(inout) :: vert_val !< The interface values to interpolate [A] + + real :: val_src(GV%ke+1) ! A column of interface values on the source grid [A] + real :: val_tgt(GV%ke+1) ! A column of interface values on the target grid [A] + real :: h_src(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h_tgt(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: I_mask_sum ! The inverse of the tracer point masks surrounding a corner [nondim] + integer :: i, j, k, nz + + nz = GV%ke + + do J=G%JscB,G%JecB ; do I=G%IscB,G%IecB + if ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) > 0.0 ) then + I_mask_sum = 1.0 / ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1))) + + do k=1,nz + h_src(k) = ((G%mask2dT(i,j) * h_old(i,j,k) + G%mask2dT(i+1,j+1) * h_old(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h_old(i+1,j,k) + G%mask2dT(i,j+1) * h_old(i,j+1,k)) ) * I_mask_sum + h_tgt(k) = ((G%mask2dT(i,j) * h_new(i,j,k) + G%mask2dT(i+1,j+1) * h_new(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h_new(i+1,j,k) + G%mask2dT(i,j+1) * h_new(i,j+1,k)) ) * I_mask_sum + enddo + + do K=1,nz+1 + val_src(K) = vert_val(I,J,K) + enddo + + call interpolate_column(nz, h_src, val_src, nz, h_tgt, val_tgt, .false.) + + do K=1,nz+1 + vert_val(I,J,K) = val_tgt(K) + enddo + endif ; enddo ; enddo + +end subroutine ALE_remap_vertex_vals !> Mask out thicknesses to 0 when their running sum exceeds a specified value. subroutine apply_partial_cell_mask(h1, h_mask) From aa44c32efe15b19c01caeafd73cf9800a11e1169 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 18 Nov 2022 05:51:14 -0500 Subject: [PATCH 043/629] +Add REMAP_AUXILIARY_VARS to remap accelerations Added REMAP_AUXILIARY_VARS to control whether to remap the accelerations that are used in the predictor step of the split RK2 time stepping scheme. Also added the new routines remap_dyn_split_rk2_aux_vars, remap_OBC_fields and remap_vertvisc_aux_vars to do the remapping, and code to call these routines when REMAP_AUXILIARY_VARS is true. By default, REMAP_AUXILIARY_VARS is false, and all answers are bitwise identical, but the entire MOM6-examples regression suite has been run with this set to true, and they do appear to give physically plausible answers in all cases, partially addressing the issue noted at github.com/NOAA-GFDL/MOM6/issues/203. New entries are added to the MOM_parameter_doc files, and there are three new publicly visible routines, but by default answers do not change. --- src/core/MOM.F90 | 31 ++- src/core/MOM_dynamics_split_RK2.F90 | 39 +++- src/core/MOM_open_boundary.F90 | 179 ++++++++++++++++++ .../vertical/MOM_set_viscosity.F90 | 72 +++++-- 4 files changed, 293 insertions(+), 28 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index fef71ab4d5..b20940aeba 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -74,7 +74,7 @@ module MOM use MOM_dynamics_unsplit, only : MOM_dyn_unsplit_CS use MOM_dynamics_split_RK2, only : step_MOM_dyn_split_RK2, register_restarts_dyn_split_RK2 use MOM_dynamics_split_RK2, only : initialize_dyn_split_RK2, end_dyn_split_RK2 -use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS +use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS, remap_dyn_split_rk2_aux_vars use MOM_dynamics_unsplit_RK2, only : step_MOM_dyn_unsplit_RK2, register_restarts_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS @@ -103,14 +103,13 @@ module MOM use MOM_mixed_layer_restrat, only : mixedlayer_restrat_register_restarts use MOM_obsolete_diagnostics, only : register_obsolete_diagnostics use MOM_open_boundary, only : ocean_OBC_type, OBC_registry_type -use MOM_open_boundary, only : register_temp_salt_segments -use MOM_open_boundary, only : open_boundary_register_restarts -use MOM_open_boundary, only : update_segment_tracer_reservoirs +use MOM_open_boundary, only : register_temp_salt_segments, update_segment_tracer_reservoirs +use MOM_open_boundary, only : open_boundary_register_restarts, remap_OBC_fields use MOM_open_boundary, only : rotate_OBC_config, rotate_OBC_init use MOM_porous_barriers, only : porous_widths_layer, porous_widths_interface, porous_barriers_init use MOM_porous_barriers, only : porous_barrier_CS -use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML -use MOM_set_visc, only : set_visc_register_restarts, set_visc_CS +use MOM_set_visc, only : set_viscous_BBL, set_viscous_ML, set_visc_CS +use MOM_set_visc, only : set_visc_register_restarts, remap_vertvisc_aux_vars use MOM_set_visc, only : set_visc_init, set_visc_end use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS @@ -250,6 +249,10 @@ module MOM logical :: use_ALE_algorithm !< If true, use the ALE algorithm rather than layered !! isopycnal/stacked shallow water mode. This logical is set by calling the !! function useRegridding() from the MOM_regridding module. + logical :: remap_aux_vars !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + type(MOM_stoch_eos_CS) :: stoch_eos_CS !< structure containing random pattern for stoch EOS logical :: alternate_first_direction !< If true, alternate whether the x- or y-direction !! updates occur first in directionally split parts of the calculation. @@ -1547,6 +1550,16 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) call ALE_remap_velocities(CS%ALE_CSp, G, GV, h, h_new, u, v, CS%OBC, dzRegrid, showCallTree, dtdia) + if (CS%remap_aux_vars) then + if (CS%split) & + call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) + + if (associated(CS%OBC)) & + call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + + call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) + endif + ! Replace the old grid with new one. All remapping must be done by this point in the code. !$OMP parallel do default(shared) do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -2072,6 +2085,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, "MOM", "REMAP_AUXILIARY_VARS", CS%remap_aux_vars, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., & + do_not_log=.not.CS%use_ALE_algorithm) call get_param(param_file, "MOM", "BULKMIXEDLAYER", bulkmixedlayer, & "If true, use a Kraus-Turner-like bulk mixed layer "//& "with transitional buffer layers. Layers 1 through "//& diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 68f8c97669..f438c14a05 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -36,7 +36,7 @@ module MOM_dynamics_split_RK2 use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) -use MOM_ALE, only : ALE_CS +use MOM_ALE, only : ALE_CS, ALE_remap_velocities use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS use MOM_barotropic, only : barotropic_end @@ -160,6 +160,9 @@ module MOM_dynamics_split_RK2 !! predictor step. This is used to accomodate various generations !! of restart files. logical :: use_tides !< If true, tidal forcing is enabled. + logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. real :: be !< A nondimensional number from 0.5 to 1 that controls !! the backward weighting of the time stepping scheme [nondim] @@ -256,6 +259,7 @@ module MOM_dynamics_split_RK2 public step_MOM_dyn_split_RK2 public register_restarts_dyn_split_RK2 public initialize_dyn_split_RK2 +public remap_dyn_split_RK2_aux_vars public end_dyn_split_RK2 !>@{ CPU time clock IDs @@ -1160,6 +1164,32 @@ subroutine register_restarts_dyn_split_RK2(HI, GV, US, param_file, CS, restart_C end subroutine register_restarts_dyn_split_RK2 +!> This subroutine does remapping for the auxiliary restart variables that are used +!! with the split RK2 time stepping scheme. +subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old, h_new, ALE_CSp, OBC, dzRegrid) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + type(ocean_OBC_type), pointer :: OBC !< OBC control structure to use when remapping + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & + optional, intent(in) :: dzRegrid !< Change in interface position [H ~> m or kg m-2] + + if (.not.CS%remap_aux) return + + if (CS%store_CAu) then + call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%u_av, CS%v_av, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%CAu_pred, CS%CAv_pred, OBC, dzRegrid) + endif + + call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%diffu, CS%diffv, OBC, dzRegrid) + +end subroutine remap_dyn_split_RK2_aux_vars + !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & @@ -1276,6 +1306,13 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param "If true, calculate the Coriolis accelerations at the end of each "//& "timestep for use in the predictor step of the next split RK2 timestep.", & default=.true.) + call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., do_not_log=.true.) + if (CS%remap_aux .and. .not.CS%store_CAu) call MOM_error(FATAL, & + "REMAP_AUXILIARY_VARS requires that STORE_CORIOLIS_ACCEL = True.") call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7d89d97c0f..abe63a950a 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -65,6 +65,7 @@ module MOM_open_boundary public open_boundary_register_restarts public update_segment_tracer_reservoirs public update_OBC_ramp +public remap_OBC_fields public rotate_OBC_config public rotate_OBC_init public initialize_segment_data @@ -5408,6 +5409,184 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) end subroutine update_segment_tracer_reservoirs +!> Vertically remap the OBC tracer reservoirs and radiation rates that are filtered in time. +subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: PCM_cell !< Use PCM remapping in cells where true + + ! Local variables + type(OBC_segment_type), pointer :: segment => NULL() ! A pointer to the various segments, used just for shorthand. + + real :: tr_column(GV%ke) ! A column of updated tracer concentrations [CU ~> Conc] + real :: r_norm_col(GV%ke) ! A column of updated radiation rates, in grid points per timestep [nondim] + real :: rxy_col(GV%ke) ! A column of updated radiation rates for oblique OBCs [L2 T-2 ~> m2 s-2] + real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] + real :: h2(GV%ke) ! A column of target grid layer thicknesses [H ~> m or kg m-2] + real :: I_scale ! The inverse of the scaling factor for the tracers. + ! For salinity the units would be [ppt S-1 ~> 1]. + real :: h_neglect ! Tiny thickness used in remapping [H ~> m or kg m-2] + logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + integer :: i, j, k, m, n, ntr, nz + + if (.not.associated(OBC)) return + + nz = GV%ke + ntr = OBC%ntr + h_neglect = GV%H_subroundoff + + if (.not.present(PCM_cell)) PCM(:) = .false. + + if (associated(OBC)) then ; if (OBC%OBC_pe) then ; do n=1,OBC%number_of_segments + segment => OBC%segment(n) + if (.not.associated(segment%tr_Reg)) cycle + + if (segment%is_E_or_W) then + I = segment%HI%IsdB + do j=segment%HI%jsd,segment%HI%jed + + ! Store a column of the start and final grids + if (segment%direction == OBC_DIRECTION_W) then + if (G%mask2dT(i+1,j) == 0.0) cycle + h1(:) = h_old(i+1,j,:) + h2(:) = h_new(i+1,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i+1,j,:) ; endif + else + if (G%mask2dT(i,j) == 0.0) cycle + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j,:) ; endif + endif + + ! Vertically remap the reservoir tracer concentrations + do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & + h_neglect, h_neglect, PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(I,j,:), nz, h2, tr_column, & + h_neglect, h_neglect) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%tr_Reg%Tr(m)%tres(I,j,:) = tr_column(:) + if (allocated(OBC%tres_x)) then ; do k=1,nz + OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) + enddo ; endif + + endif ; enddo + + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_rad(I,j,:), nz, h2, r_norm_col, & + h_neglect, h_neglect, PCM_cell=PCM) + + do k=1,nz + segment%rx_norm_rad(I,j,k) = r_norm_col(k) + OBC%rx_normal(I,j,k) = segment%rx_norm_rad(I,j,k) + enddo + endif + + if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(I,j,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%rx_norm_obl(I,j,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(I,j,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%ry_norm_obl(I,j,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(I,j,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%cff_normal(I,j,:) = rxy_col(:) + + do k=1,nz + OBC%rx_oblique_u(I,j,k) = segment%rx_norm_obl(I,j,k) + OBC%ry_oblique_u(I,j,k) = segment%ry_norm_obl(I,j,k) + OBC%cff_normal_u(I,j,k) = segment%cff_normal(I,j,k) + enddo + endif + + enddo + elseif (segment%is_N_or_S) then + J = segment%HI%JsdB + do i=segment%HI%isd,segment%HI%ied + + ! Store a column of the start and final grids + if (segment%direction == OBC_DIRECTION_S) then + if (G%mask2dT(i,j+1) == 0.0) cycle + h1(:) = h_old(i,j+1,:) + h2(:) = h_new(i,j+1,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j+1,:) ; endif + else + if (G%mask2dT(i,j) == 0.0) cycle + h1(:) = h_old(i,j,:) + h2(:) = h_new(i,j,:) + if (present(PCM_cell)) then ; PCM(:) = PCM_cell(i,j,:) ; endif + endif + + ! Vertically remap the reservoir tracer concentrations + do m=1,ntr ; if (allocated(segment%tr_Reg%Tr(m)%tres)) then + I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale + + if (present(PCM_cell)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & + h_neglect, h_neglect, PCM_cell=PCM) + else + call remapping_core_h(OBC%remap_CS, nz, h1, segment%tr_Reg%Tr(m)%tres(i,J,:), nz, h2, tr_column, & + h_neglect, h_neglect) + endif + + ! Possibly underflow any very tiny tracer concentrations to 0? + + ! Update tracer concentrations + segment%tr_Reg%Tr(m)%tres(i,J,:) = tr_column(:) + if (allocated(OBC%tres_y)) then ; do k=1,nz + OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) + enddo ; endif + + endif ; enddo + + if (segment%radiation .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_rad(i,J,:), nz, h2, r_norm_col, & + h_neglect, h_neglect, PCM_cell=PCM) + + do k=1,nz + segment%ry_norm_rad(i,J,k) = r_norm_col(k) + OBC%ry_normal(i,J,k) = segment%ry_norm_rad(i,J,k) + enddo + endif + + if (segment%oblique .and. (OBC%gamma_uv < 1.0)) then + call remapping_core_h(OBC%remap_CS, nz, h1, segment%rx_norm_obl(i,J,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%rx_norm_obl(i,J,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%ry_norm_obl(i,J,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%ry_norm_obl(i,J,:) = rxy_col(:) + call remapping_core_h(OBC%remap_CS, nz, h1, segment%cff_normal(i,J,:), nz, h2, rxy_col, & + h_neglect, h_neglect, PCM_cell=PCM) + segment%cff_normal(i,J,:) = rxy_col(:) + + do k=1,nz + OBC%rx_oblique_v(i,J,k) = segment%rx_norm_obl(i,J,k) + OBC%ry_oblique_v(i,J,k) = segment%ry_norm_obl(i,J,k) + OBC%cff_normal_v(i,J,k) = segment%cff_normal(i,J,k) + enddo + endif + + enddo + endif + enddo ; endif ; endif + +end subroutine remap_OBC_fields + + !> Adjust interface heights to fit the bathymetry and diagnose layer thickness. !! !! If the bottom most interface is below the topography then the bottom-most diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 1d2bbbb048..e9497d0e92 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -4,37 +4,39 @@ module MOM_set_visc ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : uvchksum, hchksum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_ALE, only : ALE_CS, ALE_remap_velocities, ALE_remap_interface_vals, ALE_remap_vertex_vals +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : uvchksum, hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_domains, only : pass_var, CORNER +use MOM_domains, only : pass_var, CORNER use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : slasher, MOM_read_data -use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex -use MOM_cvmix_shear, only : cvmix_shear_is_used -use MOM_cvmix_conv, only : cvmix_conv_is_used -use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used -use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_restart, only : register_restart_field_as_obsolete -use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing, mech_forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : slasher, MOM_read_data +use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex +use MOM_cvmix_shear, only : cvmix_shear_is_used +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS +use MOM_restart, only : register_restart_field_as_obsolete +use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density, calculate_density_derivs use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_open_boundary, only : OBC_segment_type + implicit none ; private #include public set_viscous_BBL, set_viscous_ML, set_visc_init, set_visc_end -public set_visc_register_restarts +public set_visc_register_restarts, remap_vertvisc_aux_vars ! 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 @@ -1942,6 +1944,34 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) end subroutine set_visc_register_restarts +!> This subroutine does remapping for the auxiliary restart variables in a vertvisc_type +!! that are used across timesteps +subroutine remap_vertvisc_aux_vars(G, GV, visc, h_old, h_new, ALE_CSp, OBC) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical + !! viscosities and related fields. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + if (associated(visc%Kd_shear)) then + call ALE_remap_interface_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kd_shear) + endif + + if (associated(visc%Kv_shear)) then + call ALE_remap_interface_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kv_shear) + endif + + if (associated(visc%Kv_shear_Bu)) then + call ALE_remap_vertex_vals(ALE_CSp, G, GV, h_old, h_new, visc%Kv_shear_Bu) + endif + +end subroutine remap_vertvisc_aux_vars + !> Initializes the MOM_set_visc control structure subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS, OBC) type(time_type), target, intent(in) :: Time !< The current model time. @@ -1953,7 +1983,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. type(vertvisc_type), intent(inout) :: visc !< A structure containing vertical viscosities and - !! related fields. Allocated here. + !! related fields. type(set_visc_CS), intent(inout) :: CS !< Vertical viscosity control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure From f162e6f262a3abc04c132401fb0ca420b9fb3b7b Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Thu, 10 Nov 2022 19:47:26 -0700 Subject: [PATCH 044/629] Option to read horizontally varying KHTH from file * Adds the option to set the diffusivity KHTH as horizontally varying * Can be enabled via READ_KHTH = True, filename is provided by user via KHTH_FILE * Will return error if user sets both READ_KHTH = True and KHTH > 0 --- .../lateral/MOM_thickness_diffuse.F90 | 60 +++++++++++++++---- 1 file changed, 49 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index c7310e1560..56578bfe2b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -13,6 +13,7 @@ module MOM_thickness_diffuse use MOM_EOS, only : calculate_density_second_derivs use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data use MOM_interface_heights, only : find_eta use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_lateral_mixing_coeffs, only : VarMix_CS @@ -84,6 +85,8 @@ module MOM_thickness_diffuse real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean !! temperature gradient in the deterministic part of the Stanley parameterization. !! Negative values disable the scheme. [nondim] + logical :: read_khth !< If true, read a file containing the spatially varying horizontal + !! thickness diffusivity logical :: use_stanley_gm !< If true, also use the Stanley parameterization in MOM_thickness_diffuse type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics @@ -94,8 +97,9 @@ module MOM_thickness_diffuse real, allocatable :: Kh_eta_u(:,:) !< Interface height diffusivities at u points [L2 T-1 ~> m2 s-1] real, allocatable :: Kh_eta_v(:,:) !< Interface height diffusivities in v points [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:) :: khth2d !< 2D thickness diffusivity at h-points [L2 T-1 ~> m2 s-1] !>@{ !! Diagnostic identifier @@ -171,7 +175,8 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp "Module must be initialized before it is used.") if ((.not.CS%thickness_diffuse) & - .or. .not. (CS%Khth > 0.0 .or. VarMix%use_variable_mixing)) return + .or. .not. (CS%Khth > 0.0 .or. CS%read_khth & + .or. VarMix%use_variable_mixing)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff @@ -214,10 +219,17 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp ! Set the diffusivities. !$OMP parallel default(shared) - !$OMP do - do j=js,je ; do I=is-1,ie - Khth_loc_u(I,j) = CS%Khth - enddo ; enddo + if (.not. CS%read_khth) then + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = CS%Khth + enddo ; enddo + else ! use 2d KHTH that was read in from file + !$OMP do + do j=js,je ; do I=is-1,ie + Khth_loc_u(I,j) = 0.5 * (CS%khth2d(i,j) + CS%khth2d(i+1,j)) + enddo ; enddo + endif if (use_VarMix) then if (use_Visbeck) then @@ -302,10 +314,17 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo ; enddo ; enddo endif - !$OMP do - do J=js-1,je ; do i=is,ie - Khth_loc_v(i,J) = CS%Khth - enddo ; enddo + if (.not. CS%read_khth) then + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = CS%Khth + enddo ; enddo + else ! read KHTH from file + !$OMP do + do J=js-1,je ; do i=is,ie + Khth_loc_v(i,J) = 0.5 * (CS%khth2d(i,j) + CS%khth2d(i,j+1)) + enddo ; enddo + endif if (use_VarMix) then if (use_Visbeck) then @@ -1944,6 +1963,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. + character(len=200) :: khth_file ! file containing 2d KHTH ! This include declares and sets the variable "version". # include "version_variable.h" real :: grid_sp ! The local grid spacing [L ~> m] @@ -1969,6 +1989,22 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KHTH", CS%Khth, & "The background horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "READ_KHTH", CS%read_khth, & + "If true, read a file (given by KHTH_FILE) containing the "//& + "spatially varying horizontal thickness diffusivity.", default=.false.) + if (CS%read_khth) then + if (CS%Khth > 0) then + call MOM_error(FATAL, "thickness_diffuse_init: KHTH > 0 is not "// & + "compatible with READ_KHTH = TRUE. ") + endif + call get_param(param_file, mdl, "KHTH_FILE", khth_file, & + "The file containing the spatially varying horizontal "//& + "thickness diffusivity.", default="INPUT/khth.nc") + + allocate(CS%khth2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) + call MOM_read_data(khth_file, 'khth', CS%khth2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call pass_var(CS%khth2d, G%domain) + endif call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", & @@ -2219,6 +2255,8 @@ subroutine thickness_diffuse_end(CS, CDp) deallocate(CS%KH_u_GME) deallocate(CS%KH_v_GME) endif + + if (allocated(CS%khth2d)) deallocate(CS%khth2d) end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse From ca4469231dc7736c8dafa8a4d6b746a018b5122d Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Mon, 14 Nov 2022 11:39:53 -0700 Subject: [PATCH 045/629] Allow KHTH_FILE directory to be set independently * full file path is now set as INPUTDIR/KHTH_FILE, where both INPUTDIR and KHTH_FILE are runtime parameters --- .../lateral/MOM_thickness_diffuse.F90 | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 56578bfe2b..11d0a328ae 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -13,7 +13,7 @@ module MOM_thickness_diffuse use MOM_EOS, only : calculate_density_second_derivs use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : MOM_read_data +use MOM_io, only : MOM_read_data, slasher use MOM_interface_heights, only : find_eta use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_lateral_mixing_coeffs, only : VarMix_CS @@ -1963,7 +1963,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. - character(len=200) :: khth_file ! file containing 2d KHTH + character(len=200) :: khth_file, inputdir ! This include declares and sets the variable "version". # include "version_variable.h" real :: grid_sp ! The local grid spacing [L ~> m] @@ -1997,9 +1997,14 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call MOM_error(FATAL, "thickness_diffuse_init: KHTH > 0 is not "// & "compatible with READ_KHTH = TRUE. ") endif + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) call get_param(param_file, mdl, "KHTH_FILE", khth_file, & "The file containing the spatially varying horizontal "//& - "thickness diffusivity.", default="INPUT/khth.nc") + "thickness diffusivity.", default="khth.nc") + khth_file = trim(inputdir) // trim(khth_file) allocate(CS%khth2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) call MOM_read_data(khth_file, 'khth', CS%khth2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) From ca7207ec5e7217c3b5c9d67a12d2b28a171a0ff0 Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Mon, 14 Nov 2022 11:49:38 -0700 Subject: [PATCH 046/629] Add parameter that specifies name of khth variable in file --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 11d0a328ae..6a57c60d41 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1963,7 +1963,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. - character(len=200) :: khth_file, inputdir + character(len=200) :: khth_file, inputdir, khth_varname ! This include declares and sets the variable "version". # include "version_variable.h" real :: grid_sp ! The local grid spacing [L ~> m] @@ -2004,10 +2004,14 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KHTH_FILE", khth_file, & "The file containing the spatially varying horizontal "//& "thickness diffusivity.", default="khth.nc") + call get_param(param_file, mdl, "KHTH_VARIABLE", khth_varname, & + "The name of the interface height diffusivity variable to read "//& + "from KHTH_FILE.", & + default="khth") khth_file = trim(inputdir) // trim(khth_file) allocate(CS%khth2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) - call MOM_read_data(khth_file, 'khth', CS%khth2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call MOM_read_data(khth_file, khth_varname, CS%khth2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) call pass_var(CS%khth2d, G%domain) endif call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & From 20701750f1f585a68cb37f9002f5c8f44685feba Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Mon, 14 Nov 2022 11:57:17 -0700 Subject: [PATCH 047/629] Change terminology in comments thickness diffusivity --> isopycnal height diffusivity --- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 6a57c60d41..b30d24eeaf 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -99,7 +99,7 @@ module MOM_thickness_diffuse real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] - real, allocatable, dimension(:,:) :: khth2d !< 2D thickness diffusivity at h-points [L2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:) :: khth2d !< 2D isopycnal height diffusivity at h-points [L2 T-1 ~> m2 s-1] !>@{ !! Diagnostic identifier @@ -1991,7 +1991,8 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) call get_param(param_file, mdl, "READ_KHTH", CS%read_khth, & "If true, read a file (given by KHTH_FILE) containing the "//& - "spatially varying horizontal thickness diffusivity.", default=.false.) + "spatially varying horizontal isopycnal height diffusivity.", & + default=.false.) if (CS%read_khth) then if (CS%Khth > 0) then call MOM_error(FATAL, "thickness_diffuse_init: KHTH > 0 is not "// & @@ -2003,9 +2004,9 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) inputdir = slasher(inputdir) call get_param(param_file, mdl, "KHTH_FILE", khth_file, & "The file containing the spatially varying horizontal "//& - "thickness diffusivity.", default="khth.nc") + "isopycnal height diffusivity.", default="khth.nc") call get_param(param_file, mdl, "KHTH_VARIABLE", khth_varname, & - "The name of the interface height diffusivity variable to read "//& + "The name of the isopycnal height diffusivity variable to read "//& "from KHTH_FILE.", & default="khth") khth_file = trim(inputdir) // trim(khth_file) From 6eab2b603886aaf1694753300d4f24533a0ec884 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Nov 2022 18:55:15 -0500 Subject: [PATCH 048/629] +Correct reported units for 4 diagnostics Corrected the units written to the output files for 4 diagnostics (CAu_Stokes, CAv_Stokes, area_shelf_h and sfc_mass_flux) and added missing units arguments to the get_param calls for some (mostly unlogged) parameters. The logged calls where units are added include those for EKE_MAX, NDIFF_DRHO_TOL, NDIFF_X_TOL, and IMPULSE_SOURCE_TIME, while some unnecessary carriage returns were removed in the descriptions of some of these and closely related parameters. Also added units to the comment describing the AGlen argument to initialize_ice_AGlen. All answers are bitwise identical, but there can be minor changes in the metadata of some files, and some MOM_parameter_doc and available_diags files might exhibit minor changes. --- src/core/MOM_CoriolisAdv.F90 | 8 +++--- src/ice_shelf/MOM_ice_shelf.F90 | 7 +++-- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 18 +++++------- .../MOM_fixed_initialization.F90 | 2 +- .../MOM_state_initialization.F90 | 6 ++-- src/parameterizations/lateral/MOM_MEKE.F90 | 3 +- src/tracer/MOM_neutral_diffusion.F90 | 28 +++++++++---------- src/tracer/boundary_impulse_tracer.F90 | 2 +- 8 files changed, 37 insertions(+), 37 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 3289786fd0..3ee203210c 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -1212,11 +1212,11 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) 'Zonal Acceleration from Relative Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_CAuS = register_diag_field('ocean_model', 'CAu_Stokes', diag%axesCuL, Time, & - 'Zonal Acceleration from Stokes Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Zonal Acceleration from Stokes Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) ! add to AD CS%id_CAvS = register_diag_field('ocean_model', 'CAv_Stokes', diag%axesCvL, Time, & - 'Meridional Acceleration from Stokes Vorticity', 'm-1 s-2', conversion=US%L_T2_to_m_s2) + 'Meridional Acceleration from Stokes Vorticity', 'm s-2', conversion=US%L_T2_to_m_s2) ! add to AD !CS%id_hf_gKEu = register_diag_field('ocean_model', 'hf_gKEu', diag%axesCuL, Time, & @@ -1249,14 +1249,14 @@ subroutine CoriolisAdv_init(Time, G, GV, US, param_file, diag, AD, CS) !CS%id_hf_rvxu = register_diag_field('ocean_model', 'hf_rvxu', diag%axesCvL, Time, & ! 'Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & - ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) CS%id_hf_rvxu_2d = register_diag_field('ocean_model', 'hf_rvxu_2d', diag%axesCv1, Time, & 'Depth-sum Fractional Thickness-weighted Meridional Acceleration from Relative Vorticity', & 'm s-2', conversion=US%L_T2_to_m_s2) !CS%id_hf_rvxv = register_diag_field('ocean_model', 'hf_rvxv', diag%axesCuL, Time, & ! 'Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & - ! 'm-1 s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) CS%id_hf_rvxv_2d = register_diag_field('ocean_model', 'hf_rvxv_2d', diag%axesCu1, Time, & 'Depth-sum Fractional Thickness-weighted Zonal Acceleration from Relative Vorticity', & 'm s-2', conversion=US%L_T2_to_m_s2) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 1a29ef45e6..ab73675bb1 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1694,7 +1694,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, !GMM - I think we do not need to save ustar_shelf and iceshelf_melt in the restart file !if (.not. CS%solo_ice_sheet) then ! call register_restart_field(fluxes%ustar_shelf, "ustar_shelf", .false., CS%restart_CSp, & - ! "Friction velocity under ice shelves", "m s-1", conversion=###) + ! "Friction velocity under ice shelves", "m s-1", conversion=US%Z_to_m*US%s_to_T) !endif CS%restart_output_dir = dirs%restart_output_dir @@ -1797,7 +1797,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, endif CS%id_area_shelf_h = register_diag_field('ice_shelf_model', 'area_shelf_h', CS%diag%axesT1, CS%Time, & - 'Ice Shelf Area in cell', 'meter-2', conversion=US%L_to_m**2) + 'Ice Shelf Area in cell', 'meter2', conversion=US%L_to_m**2) CS%id_shelf_mass = register_diag_field('ice_shelf_model', 'shelf_mass', CS%diag%axesT1, CS%Time, & 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ice_shelf_model', 'h_shelf', CS%diag%axesT1, CS%Time, & @@ -1839,7 +1839,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%id_h_mask = register_diag_field('ice_shelf_model', 'h_mask', CS%diag%axesT1, CS%Time, & 'ice shelf thickness mask', 'none') CS%id_shelf_sfc_mass_flux = register_diag_field('ice_shelf_model', 'sfc_mass_flux', CS%diag%axesT1, CS%Time, & - 'ice shelf surface mass flux deposition from atmosphere', 'none', conversion=US%RZ_T_to_kg_m2s) + 'ice shelf surface mass flux deposition from atmosphere', & + 'kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) endif call MOM_IS_diag_mediator_close_registration(CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 2de064e93e..e49fb03aaf 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -318,13 +318,10 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b real :: input_vel ! The input ice velocity per [L Z T-1 ~> m s-1] real :: lenlat, len_stress, westlon, lenlon, southlat ! The input positions of the channel boundarises - call get_param(PF, mdl, "LENLAT", lenlat, fail_if_missing=.true.) - - call get_param(PF, mdl, "LENLON", lenlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "WESTLON", westlon, fail_if_missing=.true.) - - call get_param(PF, mdl, "SOUTHLAT", southlat, fail_if_missing=.true.) + lenlat = G%len_lat + lenlon = G%len_lon + westlon = G%west_lon + southlat = G%south_lat call get_param(PF, mdl, "INPUT_VEL_ICE_SHELF", input_vel, & "inflow ice velocity at upstream boundary", & @@ -619,12 +616,11 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) subroutine initialize_ice_AGlen(AGlen, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen + intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen, often in [Pa-3 s-1] type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters -! integer :: i, j - real :: A_Glen + real :: A_Glen ! Ice-stiffness parameter, often in [Pa-3 s-1] character(len=40) :: mdl = "initialize_ice_stiffness" ! This subroutine's name. character(len=200) :: config character(len=200) :: varname @@ -657,7 +653,7 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_stiffness_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(varname),AGlen,G%Domain) + call MOM_read_data(filename,trim(varname), AGlen, G%Domain) endif end subroutine diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 88c6377abc..16702b6901 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -220,7 +220,7 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) " \t dense - Denmark Strait-like dense water formation and overflow.\n"//& " \t USER - call a user modified routine.", & fail_if_missing=.true.) - max_depth = -1.e9*US%m_to_Z ; call read_param(PF, "MAXIMUM_DEPTH", max_depth, scale=US%m_to_Z) + call get_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.) select case ( trim(config) ) case ("file"); call initialize_topography_from_file(D, G, PF, US) case ("flat"); call initialize_topography_named(D, G, PF, config, max_depth, US) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0f8beb4927..d3e8a2b18a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -496,7 +496,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & "an initial grid that is consistent with the initial conditions.", & default=1, do_not_log=just_read) - call get_param(PF, mdl, "DT", dt, "Timestep", fail_if_missing=.true., scale=US%s_to_T) + 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) @@ -2678,7 +2679,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "all layers are initialized based on the depths of their target densities.", & default=.false., do_not_log=just_read.or.(GV%nkml==0)) if (GV%nkml == 0) separate_mixed_layer = .false. - call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, default=0.0) + call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, & + units="m", default=0.0, scale=1.0) call get_param(PF, mdl, "Z_INIT_HMIX_DEPTH", Hmix_depth, & "The mixed layer depth in the initial conditions when Z_INIT_SEPARATE_MIXED_LAYER "//& "is set to true.", default=Hmix_default, units="m", scale=US%m_to_Z, & diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index ead6086346..e25a333c7a 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1522,7 +1522,8 @@ subroutine ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) call get_param(param_file, mdl, "EKE_MODEL", model_filename, & "Filename of the a saved pyTorch model to use", fail_if_missing = .true.) call get_param(param_file, mdl, "EKE_MAX", CS%eke_max, & - "Maximum value of EKE allowed when inferring EKE", default=2., scale=US%L_T_to_m_s**2) + "Maximum value of EKE allowed when inferring EKE", & + units="m2 s-2", default=2., scale=US%L_T_to_m_s**2) ! Set the machine learning model if (dbcomms_CS%colocated) then diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 9ef59821e3..cd29e9a536 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -48,7 +48,7 @@ module MOM_neutral_diffusion logical :: hard_fail_heff !< Bring down the model if a problem with heff is detected integer :: max_iter !< Maximum number of iterations if refine_position is defined real :: drho_tol !< Convergence criterion representing density difference from true neutrality [R ~> kg m-3] - real :: x_tol !< Convergence criterion for how small an update of the position can be + real :: x_tol !< Convergence criterion for how small an update of the position can be [nondim] real :: ref_pres !< Reference pressure, negative if using locally referenced neutral !! density [R L2 T-2 ~> Pa] logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. @@ -56,15 +56,15 @@ module MOM_neutral_diffusion logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. ! Positions of neutral surfaces in both the u, v directions - real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point - real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point + real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] + real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point [nondim] integer, allocatable, dimension(:,:,:) :: uKoL !< Index of left interface corresponding to neutral surface, !! at a u-point integer, allocatable, dimension(:,:,:) :: uKoR !< Index of right interface corresponding to neutral surface, !! at a u-point real, allocatable, dimension(:,:,:) :: uHeff !< Effective thickness at u-point [H ~> m or kg m-2] - real, allocatable, dimension(:,:,:) :: vPoL !< Non-dimensional position with left layer uKoL-1, v-point - real, allocatable, dimension(:,:,:) :: vPoR !< Non-dimensional position with right layer uKoR-1, v-point + real, allocatable, dimension(:,:,:) :: vPoL !< Non-dimensional position with left layer uKoL-1, v-point [nondim] + real, allocatable, dimension(:,:,:) :: vPoR !< Non-dimensional position with right layer uKoR-1, v-point [nondim] integer, allocatable, dimension(:,:,:) :: vKoL !< Index of left interface corresponding to neutral surface, !! at a v-point integer, allocatable, dimension(:,:,:) :: vKoR !< Index of right interface corresponding to neutral surface, @@ -229,16 +229,16 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, " pressure dependence", & default="mid_pressure") if (CS%neutral_pos_method > 1) then - call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & - "Sets the convergence criterion for finding the neutral\n"// & - "position within a layer in kg m-3.", & - default=1.e-10, scale=US%kg_m3_to_R) - call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & - "Sets the convergence criterion for a change in nondim\n"// & - "position within a layer.", & - default=0.) + call get_param(param_file, mdl, "NDIFF_DRHO_TOL", CS%drho_tol, & + "Sets the convergence criterion for finding the neutral "// & + "position within a layer in kg m-3.", & + units="kg m-3", default=1.e-10, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "NDIFF_X_TOL", CS%x_tol, & + "Sets the convergence criterion for a change in nondimensional "// & + "position within a layer.", & + units="nondim", default=0.) call get_param(param_file, mdl, "NDIFF_MAX_ITER", CS%max_iter, & - "The maximum number of iterations to be done before \n"// & + "The maximum number of iterations to be done before "// & "exiting the iterative loop to find the neutral surface", & default=10) endif diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index a7066c1ab8..2a3727bdca 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -98,7 +98,7 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re "Length of time for the boundary tracer to be injected "//& "into the mixed layer. After this time has elapsed, the "//& "surface becomes a sink for the boundary impulse tracer.", & - default=31536000.0, scale=US%s_to_T) + units="s", default=31536000.0, scale=US%s_to_T) call get_param(param_file, mdl, "TRACERS_MAY_REINIT", CS%tracers_may_reinit, & "If true, tracers may go through the initialization code "//& "if they are not found in the restart files. Otherwise "//& From 6765e27e0c4d0961f5e8b3bdfc5d849b4007e3dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Nov 2022 19:56:45 -0500 Subject: [PATCH 049/629] (*)Rescale DENSE_WATER_EAST_SPONGE_SALT Added a missing scale factor in the DENSE_WATER_EAST_SPONGE_SALT get_param call in dense_water_initialize_sponges, and added comments describing the local variables (and their units) throughout the dense_water_initialization module. The variable set by DENSE_WATER_SILL_HEIGHT was unused and it probably was always intended to be DENSE_WATER_SILL_DEPTH, which it now is. Units arguments were also added to two of the unlogged get_param calls in this module. Without this change, this test case would not reproduce with dimensional rescaling due to a scale factor that was omitted when salinity was being rescaled on May 3, 2022, which became a part of PR #122 to dev/gfdl, but answers should not change when dimensional rescaling of salinities is not used. All answers and output in the MOM6-examples test suite are bitwise identical. --- src/user/dense_water_initialization.F90 | 68 +++++++++++++++---------- 1 file changed, 41 insertions(+), 27 deletions(-) diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index a81c400256..5e0cb65007 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -40,10 +40,13 @@ subroutine dense_water_initialize_topography(D, G, param_file, max_depth) real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units ! Local variables - real, dimension(5) :: domain_params ! nondimensional widths of all domain sections - real :: sill_frac, shelf_frac + real, dimension(5) :: domain_params ! nondimensional widths of all domain sections [nondim] + real :: sill_frac ! Depth of the sill separating downslope from upslope, as a fraction of + ! the basin depth [nondim] + real :: shelf_frac ! Depth of the shelf region accumulating dense water for overflow, + ! as a fraction the basin depth [nondim] + real :: x ! Horizontal position normalized by the domain width [nondim] integer :: i, j - real :: x call get_param(param_file, mdl, "DENSE_WATER_DOMAIN_PARAMS", domain_params, & "Fractional widths of all the domain sections for the dense water experiment.\n"//& @@ -106,8 +109,10 @@ subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. ! Local variables - real :: mld, S_ref, S_range, T_ref - real :: zi, zmid + real :: mld ! The initial mixed layer depth as a fraction of the maximum depth [nondim] + real :: S_ref, S_range ! The reference salinity and its range in the initial conditions [S ~> ppt] + real :: T_ref ! The reference temperature [C ~> degC] + real :: zi, zmid ! Depths from the surface nondimensionalized by the maximum depth [nondim] integer :: i, j, k, nz nz = GV%ke @@ -160,43 +165,52 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, logical, intent(in) :: use_ALE !< ALE flag type(sponge_CS), pointer :: CSp !< Layered sponge control structure pointer type(ALE_sponge_CS), pointer :: ACSp !< ALE sponge control structure pointer + ! Local variables real :: west_sponge_time_scale, east_sponge_time_scale ! Sponge timescales [T ~> s] - real :: west_sponge_width, east_sponge_width + real :: west_sponge_width ! The fraction of the domain in which the western (outflow) sponge is active [nondim] + 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)) :: 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] - + real :: x ! Horizontal position normalized by the domain width [nondim] + real :: zi, zmid ! Depths from the surface nondimensionalized by the maximum depth [nondim] + real :: dist ! Distance from the edge of a sponge normalized by the width of that sponge [nondim] + real :: mld ! The initial mixed layer depth as a fraction of the maximum depth [nondim] + real :: S_ref, S_range ! The reference salinity and its range in the initial conditions [S ~> ppt] + real :: S_dense ! The salinity of the dense water being formed on the shelf [S ~> ppt] + real :: T_ref ! The reference temperature [C ~> degC] + real :: sill_frac ! Fractional depths of the sill, relative to the maximum depth [nondim] integer :: i, j, k, nz - real :: x, zi, zmid, dist - real :: mld, S_ref, S_range, S_dense, T_ref, sill_height nz = GV%ke call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_TIME_SCALE", west_sponge_time_scale, & - "The time scale on the west (outflow) of the domain for restoring. If zero, the sponge is disabled.", & - units="s", default=0., scale=US%s_to_T) + "The time scale on the west (outflow) of the domain for restoring. "//& + "If zero, the sponge is disabled.", units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DENSE_WATER_WEST_SPONGE_WIDTH", west_sponge_width, & - "The fraction of the domain in which the western (outflow) sponge is active.", & - units="nondim", default=0.1) + "The fraction of the domain in which the western (outflow) sponge is active.", & + units="nondim", default=0.1) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_TIME_SCALE", east_sponge_time_scale, & - "The time scale on the east (outflow) of the domain for restoring. If zero, the sponge is disabled.", & - units="s", default=0., scale=US%s_to_T) + "The time scale on the east (outflow) of the domain for restoring. "//& + "If zero, the sponge is disabled.", units="s", default=0., scale=US%s_to_T) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_WIDTH", east_sponge_width, & - "The fraction of the domain in which the eastern (outflow) sponge is active.", & - units="nondim", default=0.1) - + "The fraction of the domain in which the eastern (outflow) sponge is active.", & + units="nondim", default=0.1) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_SALT", S_dense, & - "Salt anomaly of the dense water being formed in the overflow region.", & - units="1e-3", default=4.0) + "Salt anomaly of the dense water being formed in the overflow region.", & + units="1e-3", default=4.0, scale=US%ppt_to_S) - call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, default=default_mld, do_not_log=.true.) - call get_param(param_file, mdl, "DENSE_WATER_SILL_HEIGHT", sill_height, default=default_sill, do_not_log=.true.) + call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, & + units="nondim", default=default_mld, do_not_log=.true.) + call get_param(param_file, mdl, "DENSE_WATER_SILL_DEPTH", sill_frac, & + units="nondim", default=default_sill, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "S_RANGE", S_range, & units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "T_REF", T_ref, & @@ -266,12 +280,12 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, zmid = zi + 0.5 * h(i,j,k) / (GV%Z_to_H * G%max_depth) if (x > (1. - east_sponge_width)) then - !if (zmid >= 0.9 * sill_height) & - S(i,j,k) = S_ref + S_dense + !if (zmid >= 0.9 * sill_frac) & + S(i,j,k) = S_ref + S_dense else ! linear between bottom of mixed layer and bottom if (zmid >= mld) & - S(i,j,k) = S_ref + S_range * (zmid - mld) / (1.0 - mld) + 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) @@ -300,7 +314,7 @@ end module dense_water_initialization !! The nondimensional widths of the 5 regions are controlled by the !! DENSE_WATER_DOMAIN_PARAMS, and the heights of the sill and shelf !! as a fraction of the total domain depth are controlled by -!! DENSE_WATER_SILL_HEIGHT and DENSE_WATER_SHELF_HEIGHT. +!! DENSE_WATER_SILL_DEPTH and DENSE_WATER_SHELF_DEPTH. !! !! The density in the domain is governed by a linear equation of state, and !! is set up with a mixed layer of non-dimensional depth DENSE_WATER_MLD From 321e0eb0af7cf988c1b7e96785a4ed6f93a713ad Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Nov 2022 09:25:59 -0500 Subject: [PATCH 050/629] +Removed 31 meaningless get_param units Removed meaningless units arguments from 31 get_param calls for integer, character, or logical parameters. All answers are bitwise identical, but some entries in the various parameter_doc files are changed. --- .../drivers/solo_driver/MOM_surface_forcing.F90 | 2 +- src/core/MOM_barotropic.F90 | 2 +- src/framework/MOM_unit_scaling.F90 | 14 +++++++------- src/parameterizations/lateral/MOM_MEKE.F90 | 2 +- src/parameterizations/lateral/MOM_hor_visc.F90 | 2 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 4 ++-- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 6 +++--- .../vertical/MOM_energetic_PBL.F90 | 5 ++--- src/parameterizations/vertical/MOM_kappa_shear.F90 | 4 ++-- src/user/MOM_wave_interface.F90 | 12 ++++++------ src/user/dumbbell_initialization.F90 | 10 +++++----- src/user/dumbbell_surface_forcing.F90 | 2 +- 12 files changed, 32 insertions(+), 33 deletions(-) diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index c1e125be83..7fab9e5c8c 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1728,7 +1728,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "USTAR_FORCING_VAR", CS%ustar_var, & "The name of the friction velocity variable in WIND_FILE "//& "or blank to get ustar from the wind stresses plus the "//& - "gustiness.", default=" ", units="nondim") + "gustiness.", default=" ") CS%wind_file = trim(CS%inputdir) // trim(CS%wind_file) endif if (trim(CS%wind_config) == "gyres") then diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 0949d203ae..44711e6526 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4432,7 +4432,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If NONLINEAR_BT_CONTINUITY is true, this is the number "//& "of barotropic time steps between updates to the face "//& "areas, or 0 to update only before the barotropic stepping.", & - units="nondim", default=1, do_not_log=.not.CS%Nonlinear_continuity) + default=1, do_not_log=.not.CS%Nonlinear_continuity) call get_param(param_file, mdl, "BT_PROJECT_VELOCITY", CS%BT_project_velocity,& "If true, step the barotropic velocity first and project "//& diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index 6defa492a8..caf73ae8e1 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -89,31 +89,31 @@ subroutine unit_scaling_init( param_file, US ) call get_param(param_file, mdl, "Z_RESCALE_POWER", Z_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of depths and heights. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "L_RESCALE_POWER", L_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of lateral distances. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "T_RESCALE_POWER", T_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of time. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "R_RESCALE_POWER", R_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of density. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "Q_RESCALE_POWER", Q_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of heat content. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "C_RESCALE_POWER", C_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of temperature. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) call get_param(param_file, mdl, "S_RESCALE_POWER", S_power, & "An integer power of 2 that is used to rescale the model's "//& "internal units of salinity. Valid values range from -300 to 300.", & - units="nondim", default=0, debuggingParam=.true.) + default=0, debuggingParam=.true.) if (abs(Z_power) > 300) call MOM_error(FATAL, "unit_scaling_init: "//& "Z_RESCALE_POWER is outside of the valid range of -300 to 300.") diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index e25a333c7a..18c156e1f1 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1267,7 +1267,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, call get_param(param_file, mdl, "MEKE_RD_MAX_SCALE", CS%Rd_as_max_scale, & "If true, the length scale used by MEKE is the minimum of "//& "the deformation radius or grid-spacing. Only used if "//& - "MEKE_OLD_LSCALE=True", units="nondim", default=.false.) + "MEKE_OLD_LSCALE=True", default=.false.) call get_param(param_file, mdl, "MEKE_VISCOSITY_COEFF_KU", CS%viscosity_coeff_Ku, & "If non-zero, is the scaling coefficient in the expression for"//& "viscosity used to parameterize harmonic lateral momentum mixing by"//& diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 825ca412d1..d118f625bf 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1995,7 +1995,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (CS%use_GME) then call get_param(param_file, mdl, "GME_NUM_SMOOTHINGS", CS%num_smooth_gme, & "Number of smoothing passes for the GME fluxes.", & - units="nondim", default=1) + default=1) call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 87562a9c83..50ddd224ed 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1350,7 +1350,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "positive integer may be used, although even integers "//& "are more efficient to calculate. Setting this greater "//& "than 100 results in a step-function being used.", & - units="nondim", default=2) + default=2) call get_param(param_file, mdl, "VISC_RES_SCALE_COEF", CS%Res_coef_visc, & "A coefficient that determines how Kh is scaled away if "//& "RESOLN_SCALED_... is true, as "//& @@ -1363,7 +1363,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "are more efficient to calculate. Setting this greater "//& "than 100 results in a step-function being used. "//& "This function affects lateral viscosity, Kh, and not KhTh.", & - units="nondim", default=CS%Res_fn_power_khth) + default=CS%Res_fn_power_khth) call get_param(param_file, mdl, "INTERPOLATE_RES_FN", CS%interpolate_Res_fn, & "If true, interpolate the resolution function to the "//& "velocity points from the thickness points; otherwise "//& diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index c68da61abf..1e068509b1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -388,10 +388,10 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) !/ 1. Options related to enhancing the mixing coefficient call get_param(paramFile, mdl, "USE_KPP_LT_K", CS%LT_K_Enhancement, & 'Flag for Langmuir turbulence enhancement of turbulent'//& - 'mixing coefficient.', units="", Default=.false.) + 'mixing coefficient.', Default=.false.) call get_param(paramFile, mdl, "STOKES_MIXING", CS%Stokes_Mixing, & 'Flag for Langmuir turbulence enhancement of turbulent'//& - 'mixing coefficient.', units="", Default=.false.) + 'mixing coefficient.', Default=.false.) if (CS%LT_K_Enhancement) then call get_param(paramFile, mdl, 'KPP_LT_K_SHAPE', string, & 'Vertical dependence of LT enhancement of mixing. '// & @@ -438,7 +438,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) !/ 2. Options related to enhancing the unresolved Vt2/entrainment in Rib call get_param(paramFile, mdl, "USE_KPP_LT_VT2", CS%LT_Vt2_Enhancement, & 'Flag for Langmuir turbulence enhancement of Vt2'//& - 'in Bulk Richardson Number.', units="", Default=.false.) + 'in Bulk Richardson Number.', Default=.false.) if (CS%LT_Vt2_Enhancement) then call get_param(paramFile, mdl, "KPP_LT_VT2_METHOD",string , & 'Method to enhance Vt2 in KPP. '// & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 862f775225..852ff4cee1 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2222,14 +2222,13 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Options related to Langmuir turbulence call get_param(param_file, mdl, "USE_LA_LI2016", use_LA_Windsea, & "A logical to use the Li et al. 2016 (submitted) formula to "//& - "determine the Langmuir number.", units="nondim", default=.false.) + "determine the Langmuir number.", default=.false.) ! Note this can be activated in other ways, but this preserves the old method. if (use_LA_windsea) then CS%use_LT = .true. else call get_param(param_file, mdl, "EPBL_LT", CS%use_LT, & - "A logical to use a LT parameterization.", & - units="nondim", default=.false.) + "A logical to use a LT parameterization.", default=.false.) endif if (CS%use_LT) then call get_param(param_file, mdl, "EPBL_LANGMUIR_SCHEME", tmpstr, & diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 118ec9a1a1..c088eea5bb 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1775,7 +1775,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "MAX_RINO_IT", CS%max_RiNo_it, & "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & - units="nondim", default=50, do_not_log=just_read) + default=50, do_not_log=just_read) call get_param(param_file, mdl, "KD", KD_normal, default=0.0, do_not_log=.true.) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & "The background diffusivity that is used to smooth the "//& @@ -1831,7 +1831,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) default=.true., do_not_log=just_read) call get_param(param_file, mdl, "MAX_KAPPA_SHEAR_IT", CS%max_KS_it, & "The maximum number of iterations that may be used to "//& - "estimate the time-averaged diffusivity.", units="nondim", & + "estimate the time-averaged diffusivity.", & default=13, do_not_log=just_read) call get_param(param_file, mdl, "PRANDTL_TURB", CS%Prandtl_turb, & "The turbulent Prandtl number applied to shear instability.", & diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a423ddc8b8..6676addc56 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -317,22 +317,22 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar endif call get_param(param_file, mdl, "STOKES_VF", CS%Stokes_VF, & - "Flag to use Stokes vortex force", units="", & + "Flag to use Stokes vortex force", & Default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_VF", CS%Passive_Stokes_VF, & - "Flag to make Stokes vortex force diagnostic only.", units="", & + "Flag to make Stokes vortex force diagnostic only.", & Default=.false.) call get_param(param_file, mdl, "STOKES_PGF", CS%Stokes_PGF, & - "Flag to use Stokes-induced pressure gradient anomaly", units="", & + "Flag to use Stokes-induced pressure gradient anomaly", & Default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_PGF", CS%Passive_Stokes_PGF, & - "Flag to make Stokes-induced pressure gradient anomaly diagnostic only.", units="", & + "Flag to make Stokes-induced pressure gradient anomaly diagnostic only.", & Default=.false.) call get_param(param_file, mdl, "STOKES_DDT", CS%Stokes_DDT, & - "Flag to use Stokes d/dt", units="", & + "Flag to use Stokes d/dt", & Default=.false.) call get_param(param_file, mdl, "PASSIVE_STOKES_DDT", CS%Passive_Stokes_DDT, & - "Flag to make Stokes d/dt diagnostic only", units="", & + "Flag to make Stokes d/dt diagnostic only", & Default=.false.) ! Get Wave Method and write to integer WaveMethod diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 762477b6c4..90d745004b 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -58,7 +58,7 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) units='nondim', default=0.5, do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.', & - units='nondim', default=.false., do_not_log=.false.) + default=.false., do_not_log=.false.) if (G%x_axis_units == 'm') then dblen=dblen*1.e3 @@ -150,7 +150,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_LAYER) ! Initial thicknesses for isopycnal coordinates call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.', & - units='nondim', default=.false., do_not_log=just_read) + default=.false., do_not_log=just_read) do j=js,je do i=is,ie ! Compute normalized zonal coordinates (x,y=0 at center of domain) @@ -293,7 +293,7 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ units='km', default=600., do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.', & - units='nondim', default=.false., do_not_log=just_read) + default=.false., do_not_log=just_read) if (G%x_axis_units == 'm') then dblen = dblen*1.e3 @@ -361,7 +361,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil units='km', default=600., do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.', & - units='nondim', default=.false., do_not_log=.true.) + default=.false., do_not_log=.true.) if (G%x_axis_units == 'm') then dblen=dblen*1.e3 @@ -470,4 +470,4 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil end subroutine dumbbell_initialize_sponges -end module dumbbell_initialization \ No newline at end of file +end module dumbbell_initialization diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index a672a4378b..685ffc4bee 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -216,7 +216,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) units="days", default=1.0) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.',& - units='nondim', default=.false., do_not_log=.true.) + default=.false., do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & "Initial surface salinity", & units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) From 7a962e58962723aa238688711c2332f772168440 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 23 Nov 2022 17:40:54 -0500 Subject: [PATCH 051/629] .testing: Fix concurrency errors in tc4 rules This patch fixes two issues in the preprocessing of tc4. * ocean_hgrid.nc is marked as a dependency of gen_data * Multiple ouputs are handled more safely in the Makefile Expanding on the second point: We were directing one rule to produce two output files, which resulted in the rule being run twice when invoked in parallel (make -j). This has been replaced with the recommended solution for handling concurrent outputs: use one to generate both, and connect the second to the first with a separate rule. I have also generalized the `make` command in the .testing Makefile. This should address (and hopefully fix) some intermittent errors in the .testing build on Gaea. --- .testing/Makefile | 2 +- .testing/tc4/Makefile.in | 33 +++++++++++++++++++++++++++------ 2 files changed, 28 insertions(+), 7 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 3e5c174239..73a97229d4 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -522,7 +522,7 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # NOTE: This only support tc4, but can be generalized over all tests. .PHONY: preproc preproc: tc4/Makefile - cd tc4 && make + cd tc4 && $(MAKE) LAUNCHER="$(MPIRUN)" tc4/Makefile: tc4/configure tc4/Makefile.in cd $(@D) && ./configure || (cat config.log && false) diff --git a/.testing/tc4/Makefile.in b/.testing/tc4/Makefile.in index 249d86b0b6..5a0e441482 100644 --- a/.testing/tc4/Makefile.in +++ b/.testing/tc4/Makefile.in @@ -4,15 +4,33 @@ FCFLAGS = @FCFLAGS@ LDFLAGS = @LDFLAGS@ LIBS = @LIBS@ -OUT = topog.nc ocean_hgrid.nc temp_salt_ic.nc sponge.nc +LAUNCHER ?= -all: $(OUT) +OUT = ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc -ocean_hgrid.nc topog.nc: gen_grid - ./gen_grid +# Since each program generates two outputs, we can only use one to track the +# creation. The second rule is used to indirectly re-invoke the first rule. +# +# Reference: +# https://www.gnu.org/software/automake/manual/html_node/Multiple-Outputs.html -temp_salt_ic.nc sponge.nc: gen_data - ./gen_data +# Program output +all: ocean_hgrid.nc temp_salt_ic.nc + +ocean_hgrid.nc: gen_grid + $(LAUNCHER) ./gen_grid +topog.nc: ocean_hgrid.nc + @test -f $@ || rm -f $^ + @test -f $@ || $(MAKE) $^ + +temp_salt_ic.nc: gen_data ocean_hgrid.nc + $(LAUNCHER) ./gen_data +sponge.nc: temp_salt_ic.nc + @test -f $@ || rm -f $^ + @test -f $@ || $(MAKE) $^ + + +# Programs gen_grid: gen_grid.F90 $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) @@ -20,6 +38,9 @@ gen_grid: gen_grid.F90 gen_data: gen_data.F90 $(FC) $(FCFLAGS) $(LDFLAGS) -o $@ $^ $(LIBS) + +# Support + .PHONY: clean clean: rm -rf $(OUT) gen_grid gen_data From 6bf43d66042ee95ab4914496e2fa253c95bf79f5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Nov 2022 13:46:26 -0500 Subject: [PATCH 052/629] Better document parameter units in 4 user modules Add units arguments to 30 unlogged get_param calls in 4 user modules (DOME2d_initialization, ISOMIP_initialization, Kelvin_initialization and seamount_initialization) to help detect inconsistent units and scaling factors. Also added comments describing many internal real variables and their units in the DOME2d_initialization module and seamount_initialize_temperature_salinity. All answers and output are bitwise identical. --- src/user/DOME2d_initialization.F90 | 80 ++++++++++++++++------------ src/user/ISOMIP_initialization.F90 | 16 +++--- src/user/Kelvin_initialization.F90 | 12 ++--- src/user/seamount_initialization.F90 | 34 ++++++++---- 4 files changed, 85 insertions(+), 57 deletions(-) diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index a997cde26b..1c2b71334f 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -45,9 +45,13 @@ subroutine DOME2d_initialize_topography( D, G, param_file, max_depth ) real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units ! Local variables + real :: bay_depth ! Depth of shelf, as fraction of basin depth [nondim] + real :: l1, l2 ! Fractional horizontal positions where the slope changes [nondim] + real :: x ! Fractional horizontal positions [nondim] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] integer :: i, j - real :: x, bay_depth, l1, l2 - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay ! This include declares and sets the variable "version". # include "version_variable.h" @@ -106,28 +110,30 @@ subroutine DOME2d_initialize_thickness ( h, depth_tot, G, GV, US, param_file, ju real :: e0(SZK_(GV)) ! The resting interface heights, in depth units [Z ~> m], usually ! 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]. - integer :: i, j, k, is, ie, js, je, nz - real :: x - real :: min_thickness - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay + ! positive upward, in depth units [Z ~> m] + real :: x ! Fractional horizontal positions [nondim] + real :: min_thickness ! Minimum layer thicknesses [Z ~> m] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.just_read) & call MOM_mesg("MOM_initialization.F90, DOME2d_initialize_thickness: setting thickness") - call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness, & + call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & default=1.e-3, units="m", do_not_log=.true., scale=US%m_to_Z) call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & - default=0.1, do_not_log=.true.) + units="nondim", default=0.1, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & - default=0.3, do_not_log=.true.) + units="nondim", default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & - default=0.2, do_not_log=.true.) + units="nondim", default=0.2, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -229,28 +235,30 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. - integer :: i, j, k, is, ie, js, je, nz - real :: x - integer :: index_bay_z - real :: delta_S - real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer - real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical - real :: xi0, xi1 + real :: x ! Fractional horizontal positions [nondim] + real :: delta_S ! Change in salinity between layers [S ~> ppt] + real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer + real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: xi0, xi1 ! Fractional vertical positions [nondim] + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] character(len=40) :: verticalCoordinate - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay + integer :: index_bay_z + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & - default=0.1, do_not_log=.true.) + units="nondim", default=0.1, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & - default=0.3, do_not_log=.true.) + units="nondim", default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & - default=0.2, do_not_log=.true.) + units="nondim", default=0.2, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_RANGE", S_range,' Initial salinity range', & @@ -370,10 +378,16 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: d_eta(SZK_(GV)) ! The layer thickness in a column [Z ~> m]. - real :: dome2d_width_bay, dome2d_width_bottom, dome2d_depth_bay + real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] + real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] + real :: dome2d_depth_bay ! Depth of shelf, as fraction of basin depth [nondim] real :: dome2d_west_sponge_time_scale, dome2d_east_sponge_time_scale ! Sponge timescales [T ~> s] - real :: dome2d_west_sponge_width, dome2d_east_sponge_width - real :: dummy1, x, z + real :: dome2d_west_sponge_width ! The fraction of the domain in which the western sponge for + ! restoring T/S is active [nondim] + real :: dome2d_east_sponge_width ! The fraction of the domain in which the eastern sponge for + ! restoring T/S is active [nondim] + real :: dummy1, x ! Nondimensional local variables indicating horizontal positions [nondim] + real :: z ! Vertical positions [Z ~> m] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -405,15 +419,15 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A "DOME2d_initialize_sponges called with an associated ALE-sponge control structure.") call get_param(param_file, mdl, "DOME2D_SHELF_WIDTH", dome2d_width_bay, & - default=0.1, do_not_log=.true.) + units="nondim", default=0.1, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_BASIN_WIDTH", dome2d_width_bottom, & - default=0.3, do_not_log=.true.) + units="nondim", default=0.3, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & - default=0.2, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, scale=US%ppt_to_S) - call get_param(param_file, mdl, "T_REF", T_ref, scale=US%degC_to_C, fail_if_missing=.false.) - call get_param(param_file, mdl, "S_RANGE", S_range, default=2.0, scale=US%ppt_to_S) - call get_param(param_file, mdl, "T_RANGE", T_range, default=0.0, scale=US%degC_to_C) + units="nondim", default=0.2, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, units="ppt", default=35.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "T_REF", T_ref, units="degC", scale=US%degC_to_C, fail_if_missing=.false.) + call get_param(param_file, mdl, "S_RANGE", S_range, units="ppt", default=2.0, scale=US%ppt_to_S) + call get_param(param_file, mdl, "T_RANGE", T_range, units="degC", default=0.0, scale=US%degC_to_C) ! Set the sponge damping rate as a function of position diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index aaededaa8c..ac586a02f6 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -478,22 +478,22 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, call get_param(PF, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE) - call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers (days)", & - default=0.0, scale=86400.0*US%s_to_T) + call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers", & + units="days", default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", default=10.0, & - do_not_log=.true.) + call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", & + units="degC", default=10.0, scale=1.0, do_not_log=.true.) - call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", default=35.0, & - do_not_log=.true.) + call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", & + units="ppt", default=35.0, scale=1.0, do_not_log=.true.) call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & "Surface salinity in sponge layer.", & - units="ppt", default=s_ref, scale=US%ppt_to_S) ! units="ppt") + units="ppt", default=s_ref, scale=US%ppt_to_S) call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & "Bottom salinity in sponge layer.", & - units="ppt", default=s_ref, scale=US%ppt_to_S) ! units="ppt") + units="ppt", default=s_ref, scale=US%ppt_to_S) call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & "Surface temperature in sponge layer.", & diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 595736540e..1684f88a89 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -92,11 +92,11 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) endif if (CS%mode /= 0) then call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & - default=2.0, do_not_log=.true., scale=US%kg_m3_to_R) + units="kg m-3", default=2.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "RHO_0", CS%rho_0, & - default=1035.0, do_not_log=.true., scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "MAXIMUM_DEPTH", CS%H0, & - default=1000.0, do_not_log=.true., scale=US%m_to_Z) + units="m", default=1000.0, scale=US%m_to_Z, do_not_log=.true.) endif ! Register the Kelvin open boundary. @@ -135,11 +135,11 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_1", coast_offset1, & - default=100.0, do_not_log=.true.) + units="km", default=100.0, do_not_log=.true.) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", coast_offset2, & - default=10.0, do_not_log=.true.) + units="km", default=10.0, do_not_log=.true.) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", coast_angle, & - default=11.3, do_not_log=.true.) + units="degrees", default=11.3, do_not_log=.true.) coast_angle = coast_angle * (atan(1.0)/45.) ! Convert to radians right_angle = 2 * atan(1.0) diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index 5b62993551..dd2e50fcae 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -128,7 +128,8 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=1.0, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & units="ppt", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & @@ -205,9 +206,19 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi !! only read parameters without changing T & S. ! Local variables + real :: xi0, xi1 ! Fractional positions within the depth range [nondim] + real :: r ! A nondimensional sharpness parameter with an exponetial profile [nondim] + real :: S_Ref ! Default salinity range parameters [ppt]. + real :: T_Ref ! Default temperature range parameters [degC]. + real :: S_Light, S_Dense, S_surf, S_range ! Salinity range parameters [S ~> ppt]. + real :: T_Light, T_Dense, T_surf, T_range ! Temperature range parameters [C ~> degC]. + real :: res_rat ! The ratio of density space resolution in the denser part + ! of the range to that in the lighter part of the range. + ! Setting this greater than 1 increases the resolution for + ! the denser water [nondim]. + real :: a1, frac_dense, k_frac ! Nondimensional temporary variables [nondim] integer :: i, j, k, is, ie, js, je, nz, k_light - real :: xi0, xi1, r, S_surf, T_surf, S_range, T_range - real :: T_ref, T_Light, T_Dense, S_ref, S_Light, S_Dense, a1, frac_dense, k_frac, res_rat + character(len=20) :: verticalCoordinate, density_profile is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -233,17 +244,20 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER ) ! Initial thicknesses for layer isopycnal coordinates ! These parameters are used in MOM_fixed_initialization.F90 when CONFIG_COORD="ts_range" - call get_param(param_file, mdl, "T_REF", T_ref, default=10.0, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, & + units="degC", default=10.0, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_light, & - default=T_Ref, scale=US%degC_to_C, do_not_log=.true.) + units="degC", default=T_Ref, scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_dense, & - default=T_Ref, scale=US%degC_to_C, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) + units="degC", default=T_Ref, scale=US%degC_to_C, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units="1e-3", default=35.0, scale=1.0, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & - default = S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="1e-3", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & - default = S_Ref, scale=US%ppt_to_S, do_not_log=.true.) - call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, default=1.0, do_not_log=.true.) + units="1e-3", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & + units="nondim", default=1.0, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. ! Emulate the T,S used in the "ts_range" coordinate configuration code From 2fa9f3a5db02b0bc3f4fbc3a07bfea868c40dbc8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 16 Nov 2022 04:54:55 -0500 Subject: [PATCH 053/629] (*)Update remap_answer_date set in uninitialized types Updated the default values of remap_answer_date as declared during the specification of the wave_speed_CS, remapping_CS and regridding_CS to 99991231 (to use the very latest version of the algorithms) if these control structures are used without further initialization via optional arguments to their various initialization routines (wave_speed_init(), initialize_remapping() and initialize_regridding() or set_regrid_params()). In testing both via the TC tests and the MOM6-examples regression suite, all answers are bitwise identical, because every instance where these are used either does have an appropriate call to the initialization routine, or because (as is the case for remapping diagnostics) they are hard-coded to use the PLM remapping scheme, which is not impacted by this answer_date. It is conceivable, if unlikely, however, that there could be cases outside of the standard MOM6 code that are using this remapping capability without proper initialization of this flag, in which case answers could change. In addition, a comment was updated in the interp_CS_type indicating the cases that would be altered by changing the hard coded default answer_date there, but the default in that case was not changed. All answers and output are identical in the MOM6-examples and TC test suites. --- src/ALE/MOM_regridding.F90 | 2 +- src/ALE/MOM_remapping.F90 | 2 +- src/ALE/regrid_interp.F90 | 3 ++- src/diagnostics/MOM_wave_speed.F90 | 9 ++++----- 4 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index de287af98a..27dd1ab4d5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -120,7 +120,7 @@ module MOM_regridding !> The vintage of the order of arithmetic and expressions to use for remapping. !! Values below 20190101 recover the remapping answers from 2018. !! Higher values use more robust forms of the same remapping expressions. - integer :: remap_answer_date = 20181231 !### Change to 99991231? + integer :: remap_answer_date = 99991231 logical :: use_hybgen_unmix = .false. !< If true, use the hybgen unmixing code before remapping diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index e9d9a53612..9ebc0601d2 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -35,7 +35,7 @@ module MOM_remapping logical :: force_bounds_in_subcell = .false. !> The vintage of the expressions to use for remapping. Values below 20190101 result !! in the use of older, less accurate expressions. - integer :: answer_date = 20181231 !### Change to 99991231? + integer :: answer_date = 99991231 end type ! The following routines are visible to the outside world diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index dbe364c969..4d09daf6f3 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -32,7 +32,8 @@ module regrid_interp logical :: boundary_extrapolation !> The vintage of the expressions to use for remapping - integer :: answer_date = 20181231 !### Change to 99991231? + 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. end type interp_CS_type diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 85f27d4249..36dc884679 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -46,11 +46,10 @@ module MOM_wave_speed !! speeds [nondim] type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. - integer :: remap_answer_date = 20181231 !< The vintage of the order of arithmetic and expressions to use + integer :: remap_answer_date = 99991231 !< The vintage of the order of arithmetic and expressions to use !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. - !### Change to 99991231? type(diag_ctrl), pointer :: diag !< Diagnostics control structure end type wave_speed_CS @@ -1204,10 +1203,10 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de call log_version(mdl, version) call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & - better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol) - !### Uncomment this? remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date) + better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol, & + remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date) - !### The remap_answers_2018 argument is irrelevant, because remapping is hard-coded to use PLM. + ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & answer_date=CS%remap_answer_date) From 54316820f81ee1c9ce674289d2838ec01287cd7f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 18 Nov 2022 07:22:10 -0500 Subject: [PATCH 054/629] +Rossby_front_2d_init and BFB_init cleanup Completed the dimensional rescaling of internal variables in the Rossby_front_initialization and BFB_initialization modules, including the addition of comments describing numerous internal variables and their units. The BFB module was more extensively modified to place logging of the module name and version before the get_param calls for this module, following the MOM6 pattern, to correct spelling errors in get_param descriptions, and to use the grid mask in the grid file rather than a reexamination of the minimum depth to determine the land-mask. The internal subroutine write_BFB_log is no longer needed and has been folded into BFB_set_coord. All answers are bitwise identical, but there are minor changes in the MOM_parameter_doc files for the buoy_forced_basin test case. --- src/user/BFB_initialization.F90 | 68 +++++++----------- src/user/BFB_surface_forcing.F90 | 4 +- src/user/Rossby_front_2d_initialization.F90 | 80 ++++++++++++--------- 3 files changed, 72 insertions(+), 80 deletions(-) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 68a6b6530b..3efc908ffb 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -24,10 +24,6 @@ module BFB_initialization ! 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. -!> Unsafe model variable -!! \todo Remove this module variable -logical :: first_call = .true. - contains !> This subroutine specifies the vertical coordinate in terms of temperature at the surface and at the bottom. @@ -42,17 +38,22 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - real :: drho_dt, SST_s, T_bot, rho_top, rho_bot - integer :: k, nz - character(len=40) :: mdl = "BFB_set_coord" ! This subroutine's name. + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: SST_s, T_bot ! Temperatures at the surface and seafloor [C ~> degC] + real :: rho_top, rho_bot ! Densities at the surface and seafloor [R ~> kg m-3] + integer :: k, nz + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "BFB_initialization" ! This module's name. + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "DRHO_DT", drho_dt, & "Rate of change of density with temperature.", & - units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R) + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) call get_param(param_file, mdl, "SST_S", SST_s, & - "SST at the suothern edge of the domain.", units="C", default=20.0) + "SST at the southern edge of the domain.", units="degC", default=20.0, scale=US%degC_to_C) call get_param(param_file, mdl, "T_BOT", T_bot, & - "Bottom Temp", units="C", default=5.0) + "Bottom temperature", units="degC", default=5.0, scale=US%degC_to_C) rho_top = GV%Rho0 + drho_dt*SST_s rho_bot = GV%Rho0 + drho_dt*T_bot nz = GV%ke @@ -64,15 +65,11 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) else g_prime(k) = GV%g_Earth endif - !Rlay(:) = 0.0 - !g_prime(:) = 0.0 enddo - if (first_call) call write_BFB_log(param_file) - end subroutine BFB_set_coord -!> This subroutine sets up the sponges for the southern bouundary of the domain. Maximum damping occurs +!> This subroutine sets up the sponges for the southern boundary of the domain. Maximum damping occurs !! within 2 degrees lat of the boundary. The damping linearly decreases northward over the next 2 degrees. subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, depth_tot, param_file, CSp, h) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -92,29 +89,27 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for eta, in depth units [Z ~> m]. real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: H0(SZK_(GV)) ! Resting layer thicknesses in depth units [Z ~> m]. - real :: min_depth ! The minimum ocean depth in depth units [Z ~> m]. real :: slat ! The southern latitude of the domain [degrees_N] real :: wlon ! The western longitude of the domain [degrees_E] real :: lenlat ! The latitudinal length of the domain [degrees_N] real :: lenlon ! The longitudinal length of the domain [degrees_E] real :: nlat ! The northern latitude of the domain [degrees_N] real :: max_damping ! The maximum damping rate [T-1 ~> s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "BFB_initialize_sponges_southonly" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 - ! Here the inverse damping time [T-1 ~> s-1], is set. Set Idamp to 0 ! wherever there is no sponge, and the subroutines that are called ! will automatically set up the sponges only where Idamp is positive ! and mask2dT is 1. -! Set up sponges for DOME configuration - call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & - "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) + ! Set up sponges for this configuration + ! call log_version(param_file, mdl, version) slat = G%south_lat lenlat = G%len_lat @@ -124,12 +119,14 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz) ; enddo ! Use for meridional thickness profile initialization -! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo + ! do k=1,nz ; H0(k) = -G%max_depth * real(k-1) / real(nz-1) ; enddo max_damping = 1.0 / (86400.0*US%s_to_T) + eta(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 + do j=js,je ; do i=is,ie - if (depth_tot(i,j) <= min_depth) then ; Idamp(i,j) = 0.0 + if (G%mask2dT(i,j) <= 0.0) then ; Idamp(i,j) = 0.0 elseif (G%geoLatT(i,j) < slat+2.0) then ; Idamp(i,j) = max_damping elseif (G%geoLatT(i,j) < slat+4.0) then Idamp(i,j) = max_damping * (slat+4.0-G%geoLatT(i,j))/2.0 @@ -140,16 +137,16 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept ! depth space for Boussinesq or non-Boussinesq models. ! This section is used for uniform thickness initialization - do k = 1,nz; eta(i,j,k) = H0(k); enddo + do k=1,nz ; eta(i,j,k) = H0(k) ; enddo - ! The below section is used for meridional temperature profile thickness initiation - ! do k = 1,nz; eta(i,j,k) = H0(k); enddo + ! The below section is used for meridional temperature profile thickness initialization + ! do k=1,nz ; eta(i,j,k) = H0(k) ; enddo ! if (G%geoLatT(i,j) > 40.0) then ! do k = 1,nz ! eta(i,j,k) = -G%Angstrom_Z*(k-1) ! enddo ! elseif (G%geoLatT(i,j) > 20.0) then - ! do k = 1,nz + ! do k=1,nz ! eta(i,j,k) = min(H0(k) + (G%geoLatT(i,j) - 20.0)*(G%max_depth - nz*G%Angstrom_Z)/20.0, & ! -(k-1)*G%Angstrom_Z) ! enddo @@ -166,23 +163,6 @@ subroutine BFB_initialize_sponges_southonly(G, GV, US, use_temperature, tv, dept ! By default, momentum is advected vertically within the sponge, but ! ! momentum is typically not damped within the sponge. ! - if (first_call) call write_BFB_log(param_file) - end subroutine BFB_initialize_sponges_southonly -!> Write output about the parameter values being used. -subroutine write_BFB_log(param_file) - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - -! This include declares and sets the variable "version". -#include "version_variable.h" - character(len=40) :: mdl = "BFB_initialization" ! This module's name. - - call log_version(param_file, mdl, version) - first_call = .false. - -end subroutine write_BFB_log - end module BFB_initialization diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 6f16bdd6f0..38361ab070 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -212,10 +212,10 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) units="degrees", default=40.0) call get_param(param_file, mdl, "SST_S", CS%SST_s, & "SST at the southern edge of the linear forcing ramp.", & - units="C", default=20.0, scale=US%degC_to_C) + units="degC", default=20.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SST_N", CS%SST_n, & "SST at the northern edge of the linear forcing ramp.", & - units="C", default=10.0, scale=US%degC_to_C) + units="degC", default=10.0, scale=US%degC_to_C) call get_param(param_file, mdl, "DRHO_DT", CS%drho_dt, & "The rate of change of density with temperature.", & units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 2d0dcb85e5..d3d1ad2368 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -47,9 +47,13 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read !! parameters without changing h. integer :: i, j, k, is, ie, js, je, nz - real :: Tz, Dml, eta, stretch, h0 - real :: min_thickness, T_range - real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] + real :: Tz ! Vertical temperature gradient [C Z-1 ~> degC m-1] + real :: Dml ! Mixed layer depth [Z ~> m] + real :: eta ! An interface height depth [Z ~> m] + real :: stretch ! A nondimensional stretching factor [nondim] + real :: h0 ! The stretched thickness per layer [Z ~> m] + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -59,13 +63,12 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read if (.not.just_read) call log_version(param_file, mdl, version, "") ! Read parameters needed to set 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) call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, scale=US%kg_m3_to_R, do_not_log=.true.) + units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -76,7 +79,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read case (REGRIDDING_LAYER, REGRIDDING_RHO) do j = G%jsc,G%jec ; do i = G%isc,G%iec Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz @@ -87,7 +90,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) do j = G%jsc,G%jec ; do i = G%isc,G%iec Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_DT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) stretch = ( ( G%max_depth + eta ) / G%max_depth ) h0 = ( G%max_depth / real(nz) ) * stretch do k = 1, nz @@ -118,15 +121,18 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & !! only read parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz - real :: T_ref, S_ref ! Reference salinity and temerature within surface layer - real :: T_range ! Range of salinities and temperatures over the vertical - real :: zc, zi, dTdz + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + 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 :: dTdz ! Vertical temperature gradient [C Z-1 ~> degC m-1] character(len=40) :: verticalCoordinate is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & - default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) + default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', & @@ -169,12 +175,13 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just logical, intent(in) :: just_read !< If present and true, this call will only !! read parameters without setting u & v. - real :: T_range ! Range of salinities and temperatures over the vertical - real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 degC-1 ~> m s-1 degC-1] - real :: dRho_dT ! The partial derivative of density with temperature [R degC-1 ~> kg m-3 degC-1] - real :: Dml, zi, zc, zm ! Depths [Z ~> m]. + real :: T_range ! Range of temperatures over the vertical [C ~> degC] + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 C-1 ~> m s-1 degC-1] + real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: Dml ! Mixed layer depth [Z ~> m] + real :: zi, zc, zm ! Depths [Z ~> m]. real :: f ! The local Coriolis parameter [T-1 ~> s-1] - real :: Ty ! The meridional temperature gradient [degC L-1 ~> degC m-1] + real :: Ty ! The meridional temperature gradient [C L-1 ~> degC m-1] real :: hAtU ! Interpolated layer thickness [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz character(len=40) :: verticalCoordinate @@ -184,8 +191,9 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, do_not_log=just_read) - call get_param(param_file, mdl, "DRHO_DT", dRho_dT, default=-0.2, scale=US%kg_m3_to_R, do_not_log=.true.) + units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + units='kg m-3 degC-1', default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -197,7 +205,7 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just dUdT = 0.0 ; if (abs(f) > 0.0) & dUdT = ( GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) Dml = Hml( G, G%geoLatT(i,j) ) - Ty = US%L_to_m*dTdy( G, T_range, G%geoLatT(i,j) ) + Ty = dTdy( G, T_range, G%geoLatT(i,j), US ) zi = 0. do k = 1, nz hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) * GV%H_to_Z @@ -212,12 +220,12 @@ end subroutine Rossby_front_initialize_velocity !> Pseudo coordinate across domain used by Hml() and dTdy() !! returns a coordinate from -PI/2 .. PI/2 squashed towards the -!! center of the domain. +!! center of the domain [radians]. real function yPseudo( G, lat ) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, intent(in) :: lat !< Latitude + real, intent(in) :: lat !< Latitude in arbitrary units, often [km] ! Local - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] PI = 4.0 * atan(1.0) yPseudo = ( ( lat - G%south_lat ) / G%len_lat ) - 0.5 ! -1/2 .. 1/.2 @@ -226,12 +234,12 @@ end function yPseudo !> Analytic prescription of mixed layer depth in 2d Rossby front test, -!! in the same units as G%max_depth +!! in the same units as G%max_depth (usually [Z ~> m]) real function Hml( G, lat ) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, intent(in) :: lat !< Latitude + real, intent(in) :: lat !< Latitude in arbitrary units, often [km] ! Local - real :: dHML, HMLmean + real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth HMLmean = 0.5 * ( HMLmin + HMLmax ) * G%max_depth @@ -239,18 +247,22 @@ real function Hml( G, lat ) end function Hml -!> Analytic prescription of mixed layer temperature gradient in 2d Rossby front test -real function dTdy( G, dT, lat ) +!> Analytic prescription of mixed layer temperature gradient in [C L-1 ~> degC m-1] in 2d Rossby front test +real function dTdy( G, dT, lat, US ) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, intent(in) :: dT !< Top to bottom temperature difference - real, intent(in) :: lat !< Latitude + real, intent(in) :: dT !< Top to bottom temperature difference [C ~> degC] + real, intent(in) :: lat !< Latitude in [km] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local - real :: PI, dHML, dHdy - real :: km = 1.e3 ! AXIS_UNITS = 'k' (1000 m) + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: dHML ! The range of the mixed layer depths [Z ~> m] + real :: dHdy ! The mixed layer depth gradient [Z L-1 ~> m m-1] + real :: km_to_L ! Horizontal axis unit conversion factor when AXIS_UNITS = 'k' (1000 m) [L km-1] PI = 4.0 * atan(1.0) + km_to_L = 1.0e3*US%m_to_L dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth - dHdy = dHML * ( PI / ( frontFractionalWidth * G%len_lat * km ) ) * cos( yPseudo(G, lat) ) + dHdy = dHML * ( PI / ( frontFractionalWidth * G%len_lat * km_to_L ) ) * cos( yPseudo(G, lat) ) dTdy = -( dT / G%max_depth ) * dHdy end function dTdy From 798ba7a1750476c4747c0197897f97d6191fe37e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 25 Nov 2022 14:09:15 -0500 Subject: [PATCH 055/629] GitLab: Fix nolib build directories The Gaea GitLab test configuration includes two no-library compilation tests for ocean-only and ice-ocean configurations. They are currently configured to run in the same directory. Recently, several unusual I/O errors suggest problems due to concurrent testing of the builds. In order to rule out this possibility, this patch moves the ice-ocean test to a separate directory. --- .gitlab/pipeline-ci-tool.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh index e23d64523d..8334bd3950 100755 --- a/.gitlab/pipeline-ci-tool.sh +++ b/.gitlab/pipeline-ci-tool.sh @@ -151,8 +151,8 @@ nolibs-ocean-ice-compile () { section-start nolibs-ocean-ice-compile-$1 "Compiling ocean-ice $1 executable" if [ ! $DRYRUN ] ; then cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR - mkdir -p build-ocean-only-nolibs-$1 - cd build-ocean-only-nolibs-$1 + mkdir -p build-ocean-ice-nolibs-$1 + cd build-ocean-ice-nolibs-$1 make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. -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 From 7055b7cf2c46f2e30c9e13e9d0d7fadfe7235a8d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 23 Nov 2022 08:22:48 -0500 Subject: [PATCH 056/629] Document units in 9 vertical param modules Documented numerous internal variables and their units in 9 vertical parameterization modules (MOM_bkgnd_mixing, MOM_bulk_mixed_layer, MOM_diabatic_aux, MOM_diabatic_driver, MOM_entrain_diffusive, MOM_kappa_shear, MOM_regularize_layers, MOM_set_diffusivity and MOM_set_viscosity). This commit includes the addition of units arguments in 9 unlogged get_param calls while 4 of these calls are now being scaled into the units used in MOM6 and then unscaled when used as the default for other parameters. A number of spelling errors were also corrected in comments. All answers and output are bitwise identical. --- .../vertical/MOM_bkgnd_mixing.F90 | 20 +- .../vertical/MOM_bulk_mixed_layer.F90 | 200 ++++++++++-------- .../vertical/MOM_diabatic_aux.F90 | 68 +++--- .../vertical/MOM_diabatic_driver.F90 | 67 +++--- .../vertical/MOM_entrain_diffusive.F90 | 143 +++++++------ .../vertical/MOM_kappa_shear.F90 | 85 ++++---- .../vertical/MOM_regularize_layers.F90 | 24 ++- .../vertical/MOM_set_diffusivity.F90 | 71 +++---- .../vertical/MOM_set_viscosity.F90 | 47 ++-- 9 files changed, 400 insertions(+), 325 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index ba47f281e8..5a39f83c5d 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -57,11 +57,11 @@ module MOM_bkgnd_mixing real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: N0_2Omega !< ratio of the typical Buoyancy frequency to !! twice the Earth's rotation period, used with the - !! Henyey scaling from the mixing + !! Henyey scaling from the mixing [nondim] real :: prandtl_bkgnd !< Turbulent Prandtl number used to convert - !! vertical background diffusivity into viscosity + !! vertical background diffusivity into viscosity [nondim] real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of - !! diffusivities with Kd_tanh_lat_fn. Valid values + !! diffusivities with Kd_tanh_lat_fn [nondim]. Valid values !! are in the range of -2 to 2; 0.4 reproduces CM2M. real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [Z2 T-1 ~> m2 s-1] !! when no other physically based mixed layer turbulence @@ -151,10 +151,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL CS%physical_OBL_scheme = physical_OBL_scheme if (CS%physical_OBL_scheme) then ! Check that Kdml is not set when using bulk mixed layer - call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, default=-1., do_not_log=.true.) + call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & + units="m2 s-1", default=-1., scale=US%m2_s_to_Z2_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KDML is a depricated parameter that should not be used.") - call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, default=-1., do_not_log=.true.) + call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & + units="m2 s-1", default=-1., scale=US%m2_s_to_Z2_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KD_ML_TOT cannot be set when using a physically based ocean "//& "boundary layer mixing parameterization.") @@ -338,8 +340,8 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real :: I_2Omega !< 1/(2 Omega) [T ~> s] real :: N_2Omega ! The ratio of the stratification to the Earth's rotation rate [nondim] real :: N02_N2 ! The ratio a reference stratification to the actual stratification [nondim] - real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) - real :: deg_to_rad !< factor converting degrees to radians, pi/180. + real :: I_x30 !< 2/acos(2) = 1/(sin(30 deg) * acosh(1/sin(30 deg))) [nondim] + real :: deg_to_rad !< factor converting degrees to radians [radians degree-1], pi/180. real :: abs_sinlat !< absolute value of sine of latitude [nondim] real :: min_sinlat ! The minimum value of the sine of latitude [nondim] real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [Z2 T-1 ~> m2 s-1] @@ -455,7 +457,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, enddo endif - ! Now set background diffusivies based on these surface values, possibly with vertical structure. + ! Now set background diffusivities based on these surface values, possibly with vertical structure. if ((.not.CS%physical_OBL_scheme) .and. (CS%Kd /= CS%Kd_tot_ml)) then ! This is a crude way to put in a diffusive boundary layer without an explicit boundary ! layer turbulence scheme. It should not be used for any realistic ocean models. @@ -527,7 +529,7 @@ subroutine check_bkgnd_scheme(CS, str) end subroutine -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory subroutine bkgnd_mixing_end(CS) type(bkgnd_mixing_cs), pointer :: CS !< Control structure for this module that !! will be deallocated in this subroutine diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 49d62bbde4..2f8e03480e 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -35,7 +35,7 @@ module MOM_bulk_mixed_layer integer :: nkbl !< The number of buffer layers. integer :: nsw !< The number of bands of penetrating shortwave radiation. real :: mstar !< The ratio of the friction velocity cubed to the - !! TKE input to the mixed layer, nondimensional. + !! TKE input to the mixed layer [nondim]. real :: nstar !< The fraction of the TKE input to the mixed layer !! available to drive entrainment [nondim]. real :: nstar2 !< The fraction of potential energy released by @@ -43,7 +43,7 @@ module MOM_bulk_mixed_layer logical :: absorb_all_SW !< If true, all shortwave radiation is absorbed by the !! ocean, instead of passing through to the bottom mud. real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE - !! decay scale, nondimensional. + !! decay scale [nondim]. real :: bulk_Ri_ML !< The efficiency with which mean kinetic energy !! released by mechanically forced entrainment of !! the mixed layer is converted to TKE [nondim]. @@ -84,9 +84,9 @@ module MOM_bulk_mixed_layer integer :: ML_presort_nz_conv_adj !< If ML_resort is true, do convective !! adjustment on this many layers (starting from the !! top) before sorting the remaining layers. - real :: omega_frac !< When setting the decay scale for turbulence, use - !! this fraction of the absolute rotation rate blended - !! with the local value of f, as sqrt((1-of)*f^2 + of*4*omega^2). + real :: omega_frac !< When setting the decay scale for turbulence, use this fraction + !! of the absolute rotation rate blended with the local value of f, + !! as sqrt((1-of)*f^2 + of*4*omega^2) [nondim]. logical :: correct_absorption !< If true, the depth at which penetrating !! shortwave radiation is absorbed is corrected by !! moving some of the heating upward in the water @@ -105,9 +105,8 @@ module MOM_bulk_mixed_layer !! points of the surface region (mixed & buffer !! layer) thickness [nondim]. 0.5 by default. real :: lim_det_dH_bathy !< The fraction of the total depth by which the - !! thickness of the surface region (mixed & buffer - !! layer) is allowed to change between grid points. - !! Nondimensional, 0.2 by default. + !! thickness of the surface region (mixed & buffer layers) is allowed + !! to change between grid points [nondim]. 0.2 by default. logical :: use_river_heat_content !< If true, use the fluxes%runoff_Hflx field !! to set the heat carried by runoff, instead of !! using SST for temperature of liq_runoff @@ -118,21 +117,21 @@ module MOM_bulk_mixed_layer type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the !! timing of diagnostic output. real :: Allowed_T_chg !< The amount by which temperature is allowed - !! to exceed previous values during detrainment, K. + !! to exceed previous values during detrainment [C ~> degC] real :: Allowed_S_chg !< The amount by which salinity is allowed !! to exceed previous values during detrainment [S ~> ppt] ! These are terms in the mixed layer TKE budget, all in [Z L2 T-3 ~> m3 s-3] except as noted. real, allocatable, dimension(:,:) :: & ML_depth, & !< The mixed layer depth [H ~> m or kg m-2]. - diag_TKE_wind, & !< The wind source of TKE. - diag_TKE_RiBulk, & !< The resolved KE source of TKE. - diag_TKE_conv, & !< The convective source of TKE. - diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating. - diag_TKE_mech_decay, & !< The decay of mechanical TKE. - diag_TKE_conv_decay, & !< The decay of convective TKE. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer. - diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2. + diag_TKE_wind, & !< The wind source of TKE [Z L2 T-3 ~> m3 s-3]. + diag_TKE_RiBulk, & !< The resolved KE source of TKE [Z L2 T-3 ~> m3 s-3]. + diag_TKE_conv, & !< The convective source of TKE [Z L2 T-3 ~> m3 s-3]. + diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [Z L2 T-3 ~> m3 s-3]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [Z L2 T-3 ~> m3 s-3]. + diag_TKE_conv_decay, & !< The decay of convective TKE [Z L2 T-3 ~> m3 s-3]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [Z L2 T-3 ~> m3 s-3]. + diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [Z L2 T-3 ~> m3 s-3]. diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer !! detrainment [R Z L2 T-3 ~> W m-2]. diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only @@ -171,10 +170,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C !! [L T-1 ~> m s-1]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent - !! fields have NULL ptrs. + !! fields have NULL pointers. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a @@ -184,7 +183,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C intent(inout) :: eb !< The amount of fluid moved upward into a !! layer; this should be increased due to !! mixed layer entrainment [H ~> m or kg m-2]. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure type(optics_type), pointer :: optics !< The structure that can be queried for the !! inverse of the vertical absorption decay !! scale for penetrating shortwave radiation. @@ -195,7 +194,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C !! being applied separately. real, optional, intent(in) :: dt_diag !< The diagnostic time step, !! which may be less than dt if there are - !! two callse to mixedlayer [T ~> s]. + !! two calls to mixedlayer [T ~> s]. logical, optional, intent(in) :: last_call !< if true, this is the last call !! to mixedlayer in the current time step, so !! diagnostics will be written. The default is @@ -247,8 +246,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! entrained [C H ~> degC m or degC kg m-2]. Stot, & ! The integrated salt of layers which are fully entrained ! [H S ~> m ppt or ppt kg m-2]. - uhtot, & ! The depth integrated zonal and meridional velocities in the - vhtot, & ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + uhtot, & ! The depth integrated zonal velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + vhtot, & ! The depth integrated meridional velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] netMassInOut, & ! The net mass flux (if non-Boussinsq) or volume flux (if ! Boussinesq - i.e. the fresh water flux (P+R-E)) into the @@ -278,7 +277,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C Pen_SW_bnd ! The penetrating fraction of the shortwave heating integrated ! over a time step in each band [C H ~> degC m or degC kg m-2]. real, dimension(max(CS%nsw,1),SZI_(G),SZK_(GV)) :: & - opacity_band ! The opacity in each band [H-1 ~> m-1 or m2 kg-1]. The indicies are band, i, k. + opacity_band ! The opacity in each band [H-1 ~> m-1 or m2 kg-1]. The indices are band, i, k. real :: cMKE(2,SZI_(G)) ! Coefficients of HpE and HpE^2 used in calculating the ! denominator of MKE_rate; the two elements have differing @@ -318,7 +317,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z T-1 ~> m s-1]. real :: kU_star ! Ustar times the Von Karman constant [Z T-1 ~> m s-1]. - real :: dt__diag ! A recaled copy of dt_diag (if present) or dt [T ~> s]. + real :: dt__diag ! A rescaled copy of dt_diag (if present) or dt [T ~> s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -585,9 +584,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C enddo ; endif endif -! Move water left in the former mixed layer into the buffer layer and -! from the buffer layer into the interior. These steps might best be -! treated in conjuction. + ! Move water left in the former mixed layer into the buffer layer and + ! from the buffer layer into the interior. These steps might best be + ! treated in conjunction. if (CS%nkbl == 1) then call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & @@ -777,7 +776,7 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! [Z L2 T-2 ~> m3 s-2]. integer, intent(in) :: j !< The j-index to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure integer, optional, intent(in) :: nz_conv !< If present, the number of layers !! over which to do convective adjustment !! (perhaps CS%nkml). @@ -952,13 +951,13 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & integer, dimension(SZI_(G),SZK_(GV)), & intent(in) :: ksort !< The density-sorted k-indices. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent - !! fields have NULL ptrs. + !! fields have NULL pointers. type(forcing), intent(inout) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are @@ -1261,7 +1260,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, !! adjustment [H ~> m or kg m-2]. type(forcing), intent(in) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields - !! have NULL ptrs. + !! have NULL pointers. real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source !! due to free convection [Z L2 T-2 ~> m3 s-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in @@ -1290,8 +1289,8 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, !! time interval [T-1 ~> s-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure ! This subroutine determines the TKE available at the depth of free ! convection to drive mechanical entrainment. @@ -1500,14 +1499,14 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE !< The vertical TKE decay rate [H-1 ~> m-1 or m2 kg-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & - intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure ! This subroutine calculates mechanically driven entrainment. ! Local variables real :: SW_trans ! The fraction of shortwave radiation that is not - ! absorbed in a layer, nondimensional. + ! absorbed in a layer [nondim]. real :: Pen_absorbed ! The amount of penetrative shortwave radiation ! that is absorbed in a layer [C H ~> degC m or degC kg m-2]. real :: h_avail ! The thickness in a layer available for entrainment [H ~> m or kg m-2]. @@ -1517,7 +1516,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! h_ent between iterations [H ~> m or kg m-2]. real :: MKE_rate ! The fraction of the energy in resolved shears ! within the mixed layer that will be eliminated - ! within a timestep, nondim, 0 to 1. + ! within a timestep [nondim], 0 to 1. real :: HpE ! The current thickness plus entrainment [H ~> m or kg m-2]. real :: g_H_2Rho0 ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density, @@ -1541,17 +1540,17 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: dEF4_dh ! The partial derivative of EF4 with h [H-2 ~> m-2 or m4 kg-2]. - real :: Pen_En1 ! A nondimensional temporary variable. - real :: kh, exp_kh ! Nondimensional temporary variables related to the - real :: f1_kh ! fractional decay of TKE across a layer. - real :: x1, e_x1 ! Nondimensional temporary variables related to - real :: f1_x1, f2_x1 ! the relative decay of TKE and SW radiation across - real :: f3_x1 ! a layer, and exponential-related functions of x1. + real :: Pen_En1 ! A nondimensional temporary variable [nondim]. + real :: kh, exp_kh, f1_kh ! Nondimensional temporary variables related to the + ! fractional decay of TKE across a layer [nondim]. + real :: x1, e_x1 ! Nondimensional temporary variables related to the relative decay + ! of TKE and SW radiation across a layer [nondim] + real :: f1_x1, f2_x1, f3_x1 ! Exponential-related functions of x1 [nondim]. real :: E_HxHpE ! Entrainment divided by the product of the new and old ! thicknesses [H-1 ~> m-1 or m2 kg-1]. real :: Hmix_min ! The minimum mixed layer depth [H ~> m or kg m-2]. - real :: opacity - real :: C1_3, C1_6, C1_24 ! 1/3, 1/6, and 1/24. + real :: opacity ! The opacity of a layer in a band of shortwave radiation [H-1 ~> m-1 or m2 kg-1] + real :: C1_3, C1_6, C1_24 ! 1/3, 1/6, and 1/24. [nondim] integer :: is, ie, nz, i, k, ks, itt, n C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 ; C1_24 = 1.0/24.0 @@ -1784,12 +1783,12 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) !! the layers [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must !! remain in each layer [H ~> m or kg m-2]. - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure integer, dimension(SZI_(G),SZK_(GV)), intent(out) :: ksort !< The k-index to use in the sort. ! Local variables - real :: R0sort(SZI_(G),SZK_(GV)) - integer :: nsort(SZI_(G)) + real :: R0sort(SZI_(G),SZK_(GV)) ! The sorted potential density [R ~> kg m-3] + integer :: nsort(SZI_(G)) ! The number of layers left to sort logical :: done_sorting(SZI_(G)) integer :: i, k, ks, is, ie, nz, nkmb @@ -1852,14 +1851,14 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS !! layer in the entrainment from !! below [H ~> m or kg m-2]. Positive values go !! with mass gain by a layer. - integer, dimension(SZI_(G),SZK_(GV)), intent(in) :: ksort !< The density-sorted k-indicies. - type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control struct + integer, dimension(SZI_(G),SZK_(GV)), intent(in) :: ksort !< The density-sorted k-indices. + type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced !! to the surface with potential !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of - !! cpotential density referenced + !! potential density referenced !! to the surface with salinity, !! [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of @@ -1880,21 +1879,38 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! and the coordinate density (sigma-2)) between the newly forming mixed layer ! and a residual buffer- or mixed layer, and the number of massive layers above ! the deepest massive buffer or mixed layer is greater than nkbl, then split -! those buffer layers into peices that match the target density of the two +! those buffer layers into pieces that match the target density of the two ! nearest interior layers. ! Otherwise, if there are more than nkbl+1 remaining massive layers ! Local variables - real :: h_move, h_tgt_old, I_hnew - real :: dT_dS_wt2, dT_dR, dS_dR, I_denom - real :: Rcv_int - real :: T_up, S_up, R0_up, I_hup, h_to_up - real :: T_dn, S_dn, R0_dn, I_hdn, h_to_dn - real :: wt_dn - real :: dR1, dR2 - real :: dPE, hmin, min_dPE, min_hmin - real, dimension(SZK_(GV)) :: & - h_tmp, R0_tmp, T_tmp, S_tmp, Rcv_tmp + real :: h_move ! The thickness of water being moved between layers [H ~> m or kg m-2] + real :: h_tgt_old ! The previous thickness of the recipient layer [H ~> m or kg m-2] + real :: I_hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m3 kg-1] + real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes + ! when extraploating to match a target density [C2 S-2 ~> degC2 ppt-2] + real :: dT_dR ! The ratio of temperature changes to density changes when + ! extrapolating [C R-1 ~> degC m3 kg-1] + real :: dS_dR ! The ratio of salinity changes to density changes when + ! extrapolating [S R-1 ~> ppt m3 kg-1] + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2]. + real :: Rcv_int ! The target coordinate density of an interior layer [R ~> kg m-3] + real :: T_up, T_dn ! Temperatures projected to match the target densities of two layers [C ~> degC] + real :: S_up, S_dn ! Salinities projected to match the target densities of two layers [S ~> ppt] + real :: R0_up, R0_dn ! Potential densities projected to match the target coordinate + ! densities of two layers [R ~> kg m-3] + real :: I_hup, I_hdn ! Inverse of the new thicknesses of the two layers [H-1 ~> m-1 or m2 kg-1] + real :: h_to_up, h_to_dn ! Thickness transferred to two layers [H ~> m or kg m-2] + real :: wt_dn ! Fraction of the thickness transferred to the deeper layer [nondim] + real :: dR1, dR2 ! Density difference with the target densities of two layers [R ~> kg m-3] + real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging + ! of a pair of layers [R H2 ~> kg m-1 or kg3 m-6] + real :: hmin, min_hmin ! The thickness of the thinnest layer [H ~> m or kg m-2] + real :: h_tmp(SZK_(GV)) ! A copy of the original layer thicknesses [H ~> m or kg m-2] + real :: R0_tmp(SZK_(GV)) ! A copy of the original layer potential densities [R ~> kg m-3] + real :: T_tmp(SZK_(GV)) ! A copy of the original layer temperatures [C ~> degC] + real :: S_tmp(SZK_(GV)) ! A copy of the original layer salinities [S ~> ppt] + real :: Rcv_tmp(SZK_(GV)) ! A copy of the original layer coordinate densities [R ~> kg m-3] integer :: ks_min logical :: sorted, leave_in_layer integer :: ks_deep(SZI_(G)), k_count(SZI_(G)), ks2_reverse(SZI_(G), SZK_(GV)) @@ -2168,13 +2184,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, !! goes with layer thickness increases. integer, intent(in) :: j !< The meridional row to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of !! potential density referenced to the !! surface with potential temperature, !! [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of - !! cpotential density referenced to the + !! potential density referenced to the !! surface with salinity !! [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of @@ -2224,10 +2240,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [R H-1 ~> kg m-4 or m-1] -! real :: dT_2dz, dS_2dz ! Half the vertical gradients of T and S, in degC H-1, and ppt H-1. +! real :: dT_2dz ! Half the vertical gradient of T [C H-1 ~> degC m-1 or degC m2 kg-1] +! real :: dS_2dz ! Half the vertical gradient of S [S H-1 ~> ppt m-1 or ppt m2 kg-1] real :: scale_slope ! A nondimensional number < 1 used to scale down ! the slope within the upper buffer layer when - ! water MUST be detrained to the lower layer. + ! water MUST be detrained to the lower layer [nondim]. real :: dPE_extrap ! The potential energy change due to dispersive ! advection or mixing layers, divided by @@ -2264,9 +2281,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: dPE_ratio ! Multiplier of dPE_det at which merging is ! permitted - here (detrainment_per_day/dt)*30 - ! days? + ! days? [nondim] real :: num_events ! The number of detrainment events over which - ! to prefer merging the buffer layers. + ! to prefer merging the buffer layers [nondim]. real :: dPE_time_ratio ! Larger of 1 and the detrainment timescale over dt [nondim]. real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and ! salinity changes in defining spiciness, in @@ -2287,14 +2304,16 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: s1, s2, bh0 ! Work variables [H ~> m or kg m-2]. real :: s3sq ! A work variable [H2 ~> m2 or kg2 m-4]. real :: I_ya, b1 ! Nondimensional work variables [nondim] - real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables, - real :: Ihk0, Ihk1, Ih12 ! all in [H-1 ~> m-1 or m2 kg-1]. - real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables, - real :: dR0, dR21, dRcv ! all in [R ~> kg m-3]. + real :: Ih, Ihdet, Ih1f, Ih2f ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] + real :: Ihk0, Ihk1, Ih12 ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] + real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables [R ~> kg m-3] + real :: dR0, dR21, dRcv ! Assorted density difference work variables [R ~> kg m-3] real :: dRcv_stays, dRcv_det, dRcv_lim ! Assorted densities [R ~> kg m-3] - real :: Angstrom ! The minumum layer thickness [H ~> m or kg m-2]. + real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. - real :: h2_to_k1_lim, T_new, S_new, T_max, T_min, S_max, S_min + real :: h2_to_k1_lim ! A limit on the thickness that can be detrained to layer k1 [H ~> m or kg m-2] + real :: T_new, T_max, T_min ! Temperature of the detrained water and limits on it [C ~> degC] + real :: S_new, S_max, S_min ! Salinity of the detrained water and limits on it [S ~> ppt] integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke @@ -2352,7 +2371,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! (3) The lower buffer layer density extrapolated to its base with a ! linear fit between the two layers must exceed the density of the ! next denser interior layer. - ! (4) The average extroplated coordinate density that is moved into the + ! (4) The average extrapolated coordinate density that is moved into the ! isopycnal interior matches the target value for that layer. ! (5) The potential energy change is calculated and might be used later ! to allow the upper buffer layer to mix more into the lower buffer @@ -3062,7 +3081,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e !! a layer. integer, intent(in) :: j !< The meridional row to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature @@ -3081,9 +3100,17 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e real :: max_det_rem(SZI_(G)) ! Remaining permitted detrainment [H ~> m or kg m-2]. real :: detrain(SZI_(G)) ! The thickness of fluid to detrain ! from the mixed layer [H ~> m or kg m-2]. - real :: dT_dR, dS_dR, dRml, dR0_dRcv, dT_dS_wt2 + real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes + ! when extraploating to match a target density [C2 S-2 ~> degC2 ppt-2] + real :: dT_dR ! The ratio of temperature changes to density changes when + ! extrapolating [C R-1 ~> degC m3 kg-1] + real :: dS_dR ! The ratio of salinity changes to density changes when + ! extrapolating [S R-1 ~> ppt m3 kg-1] + real :: dRml ! The density range within the extent of the mixed layers [R ~> kg m-3] + real :: dR0_dRcv ! The relative changes in the potential density and the coordinate density [nondim] real :: I_denom ! A work variable [S2 R-2 ~> ppt2 m6 kg-2]. - real :: Sdown, Tdown ! A salinity [S ~> ppt] and a temperature [C ~> degC] + real :: Sdown ! The salinity of the detrained water [S ~> ppt] + real :: Tdown ! The temperature of the detrained water [C ~> degC] real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the ! conversion from H to m divided by the mean density times the time @@ -3091,11 +3118,10 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e real :: g_H2_2dt ! Half the gravitational acceleration times the square of the ! conversion from H to Z divided by the diagnostic time step ! [L2 Z H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. - + real :: x1 ! A temporary work variable [various] logical :: splittable_BL(SZI_(G)), orthogonal_extrap - real :: x1 - integer :: i, is, ie, k, k1, nkmb, nz + is = G%isc ; ie = G%iec ; nz = GV%ke nkmb = CS%nkml+CS%nkbl if (CS%nkbl /= 1) call MOM_error(FATAL,"MOM_mixed_layer: "// & @@ -3329,13 +3355,15 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. - type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control struct + type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. real :: BL_detrain_time_dflt ! The default value for BUFFER_LAY_DETRAIN_TIME [s] - real :: omega_frac_dflt, ustar_min_dflt, Hmix_min_m + real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] + real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [m s-1] + real :: Hmix_min_m ! The unscaled value of HMIX_MIN [m] integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3600,7 +3628,7 @@ function EF4(Ht, En, I_L, dR_de) real :: EF4 !< The integral [H-1 ~> m-1 or m2 kg-1]. ! Local variables - real :: exp_LHpE ! A nondimensional exponential decay. + real :: exp_LHpE ! A nondimensional exponential decay [nondim]. real :: I_HpE ! An inverse thickness plus entrainment [H-1 ~> m-1 or m2 kg-1]. real :: Res ! The result of the integral above [H-1 ~> m-1 or m2 kg-1]. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index a3450bd6e4..d51f796df1 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -242,20 +242,19 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) ! local variables real, dimension(SZI_(G)) :: & - b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. - d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. + b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. + d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. real, dimension(SZI_(G),SZK_(GV)) :: & - c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. + c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. - real :: h_tr ! h_tr is h at tracer points with a tiny thickness - ! added to ensure positive definiteness [H ~> m or kg m-2]. - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: I_h_int ! The inverse of the thickness associated with an - ! interface [H-1 ~> m-1 or m2 kg-1]. - real :: b_denom_T ! The first term in the denominators for the expressions - real :: b_denom_S ! for b1_T and b1_S, both [H ~> m or kg m-2]. + mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. + real :: h_tr ! h_tr is h at tracer points with a tiny thickness + ! added to ensure positive definiteness [H ~> m or kg m-2]. + real :: h_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: I_h_int ! The inverse of the thickness associated with an interface [H-1 ~> m-1 or m2 kg-1]. + real :: b_denom_T ! The first term in the denominator for the expression for b1_T [H ~> m or kg m-2]. + real :: b_denom_S ! The first term in the denominator for the expression for b1_S [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -497,17 +496,18 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) !! v_h as though ea and eb were being supplied with !! uniformly zero values. - ! local variables + ! Local variables real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: b1(SZI_(G)) ! A thickness used in the tridiagonal solver [H ~> m or kg m-2] real :: c1(SZI_(G),SZK_(GV)) ! A variable used in the tridiagonal solver [nondim] real :: d1(SZI_(G)) ! The complement of c1 [nondim] - real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring - real :: a_e(SZI_(G)), a_w(SZI_(G)) ! velocity points, ~1/2 in the open - ! ocean, nondimensional. - real :: sum_area, Idenom + ! Fractional weights of the neighboring velocity points, ~1/2 in the open ocean. + real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] + real :: a_e(SZI_(G)), a_w(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] + real :: sum_area ! A sum of adjacent areas [L2 ~> m2] + real :: Idenom ! The inverse of the denomninator in a weighted average [L-2 ~> m-2] logical :: mix_vertically, zero_mixing integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -527,6 +527,12 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) do i=is,ie sum_area = G%areaCu(I-1,j) + G%areaCu(I,j) if (sum_area > 0.0) then + ! If this were a simple area weighted average, this would just be I_denom = 1.0 / sum_area. + ! The other factor of sqrt(0.5*sum_area*G%IareaT(i,j)) is 1 for open ocean points on a + ! Cartesian grid. This construct predates the initial commit of the MOM6 code, and was + ! present in the GOLD code before February, 2010. I do not recall why this was added, and + ! the GOLD CVS server that contained the relevant history and logs appears to have been + ! decommissioned. Idenom = sqrt(0.5*G%IareaT(i,j) / sum_area) a_w(i) = G%areaCu(I-1,j) * Idenom a_e(i) = G%areaCu(I,j) * Idenom @@ -803,7 +809,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) ! converges extremely quickly (usually 1 guess) since this equation turns out to be rather ! linear for PE change with increasing X. ! Input parameters: - integer, dimension(3), intent(in) :: id_MLD !< Energy output diag IDs + integer, dimension(3), intent(in) :: id_MLD !< Energy output diagnostic IDs 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 @@ -1045,13 +1051,19 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Local variables integer, parameter :: maxGroundings = 5 integer :: numberOfGroundings, iGround(maxGroundings), jGround(maxGroundings) - real :: H_limit_fluxes - real :: IforcingDepthScale + real :: H_limit_fluxes ! Surface fluxes are scaled down fluxes when the total depth of the ocean + ! drops below this value [H ~> m or kg m-2] + real :: IforcingDepthScale ! The inverse of the layer thickness below which mass losses are + ! shifted to the next deeper layer [H ~> m or kg m-2] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: dThickness, dTemp, dSalt - real :: fractionOfForcing, hOld, Ithickness + real :: dThickness ! The change in layer thickness [H ~> m or kg m-2] + real :: dTemp ! The integrated change in layer temperature [C H ~> degC m or degC kg m-2] + real :: dSalt ! The integrated change in layer salinity [S H ~> ppt m or ppt kg m-2] + real :: fractionOfForcing ! THe fraction of the remaining forcing applied to a layer [nondim] + real :: hOld ! The original thickness of a layer [H ~> m or kg m-2] + real :: Ithickness ! The inverse of the new layer thickness [H-1 ~> m-1 or m2 kg-1] real :: RivermixConst ! A constant used in implementing river mixing [R Z2 T-1 ~> Pa s]. - real :: EnthalpyConst ! A constant used to control the enthalpy calculation + real :: EnthalpyConst ! A constant used to control the enthalpy calculation [nondim] ! By default EnthalpyConst = 1.0. If fluxes%heat_content_evap ! is associated enthalpy is provided via coupler and EnthalpyConst = 0.0. real, dimension(SZI_(G)) :: & @@ -1092,13 +1104,17 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t opacityBand ! The opacity (inverse of the exponential absorption length) of each frequency ! band of shortwave radiation in each layer [H-1 ~> m-1 or m2 kg-1] real, dimension(maxGroundings) :: hGrounding ! Thickness added by each grounding event [H ~> m or kg m-2] - real :: Temp_in, Salin_in + real :: Temp_in ! The initial temperature of a layer [C ~> degC] + real :: Salin_in ! The initial salinity of a layer [S ~> ppt] real :: g_Hconv2 ! A conversion factor for use in the TKE calculation ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density ! [Z T-2 R-1 ~> m4 s-2 kg-1] - logical :: calculate_energetics - logical :: calculate_buoyancy + logical :: calculate_energetics ! If true, calculate the energy required to mix the newly added + ! water over the topmost grid cell, assuming that the fluxes of heat and salt + ! and rejected brine are initially applied in vanishingly thin layers at the + ! top of the layer before being mixed throughout the layer. + logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, nb character(len=45) :: mesg diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index ddafbc3274..7cfcbfab07 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -122,7 +122,7 @@ module MOM_diabatic_driver !! other diffusivities. Otherwise, the larger of kappa- !! shear and ePBL diffusivities are used. real :: ePBL_Prandtl !< The Prandtl number used by ePBL to convert vertical - !! diffusivities into viscosities. + !! 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] @@ -133,7 +133,7 @@ module MOM_diabatic_driver !! FW fluxes are applied separately or combined before !! being applied. real :: ML_mix_first !< The nondimensional fraction of the mixed layer - !! algorithm that is applied before diffusive mixing. + !! algorithm that is applied before diffusive mixing [nondim]. !! The default is 0, while 0.5 gives Strang splitting !! and 1 is a sensible value too. Note that if there !! are convective instabilities in the initial state, @@ -174,8 +174,8 @@ module MOM_diabatic_driver real :: MLD_EN_VALS(3) !< Energy values for energy mixed layer diagnostics [R Z L2 T-2 ~> J m-2] !>@{ Diagnostic IDs - integer :: id_cg1 = -1 ! diag handle for mode-1 speed - integer, allocatable, dimension(:) :: id_cn ! diag handle for all mode speeds + integer :: id_cg1 = -1 ! diagnostic handle for mode-1 speed + integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 @@ -231,14 +231,14 @@ module MOM_diabatic_driver type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Control structure for a child module - type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control struct - type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control struct - type(energetic_PBL_CS) :: ePBL !< Energetic PBL control struct - type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control struct - type(geothermal_CS) :: geothermal !< Geothermal control struct - type(int_tide_CS) :: int_tide !< Internal tide control struct - type(opacity_CS) :: opacity !< Opacity control struct - type(regularize_layers_CS) :: regularize_layers !< Regularize layer control struct + type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control structure + type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control structure + type(energetic_PBL_CS) :: ePBL !< Energetic PBL control structure + type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control structure + type(geothermal_CS) :: geothermal !< Geothermal control structure + 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(group_pass_type) :: pass_hold_eb_ea !< For group halo pass type(group_pass_type) :: pass_Kv !< For group halo pass @@ -1659,9 +1659,10 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & ! These are targets so that the space can be shared with eaml & ebml. - eatr, & ! The equivalent of ea and eb for tracers, which differ from ea and - ebtr ! eb in that they tend to homogenize tracers in massless layers - ! near the boundaries [H ~> m or kg m-2] (for Bous or non-Bouss) + eatr, & ! The equivalent of ea for tracers, which differs from ea in that it tends to + ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] + ebtr ! The equivalent of eb for tracers, which differs from eb in that it tends to + ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] @@ -2620,7 +2621,7 @@ subroutine adiabatic(h, tv, fluxes, dt, G, GV, US, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: zeros ! An array of zeros. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: zeros ! An array of zeros with units of [H ~> m or kg m-2] zeros(:,:,:) = 0.0 @@ -2646,8 +2647,8 @@ subroutine diagnose_diabatic_diff_tendency(tv, h, temp_old, saln_old, dt, G, GV, type(diabatic_CS), pointer :: CS !< module control structure ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: ppt2mks ! Conversion factor from S to kg/kg [S-1 ~> ppt-1]. integer :: i, j, k, is, ie, js, je, nz @@ -2741,8 +2742,8 @@ subroutine diagnose_boundary_forcing_tendency(tv, h, temp_old, saln_old, h_old, type(diabatic_CS), pointer :: CS !< module control structure ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: ppt2mks ! Conversion factor from S to kg/kg [S-1 ~> ppt-1]. integer :: i, j, k, is, ie, js, je, nz @@ -2828,8 +2829,8 @@ subroutine diagnose_frazil_tendency(tv, h, temp_old, dt, G, GV, US, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(diabatic_CS), pointer :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d - real, dimension(SZI_(G),SZJ_(G)) :: work_2d + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: work_3d ! A 3-d work array for diagnostics [various] + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array for diagnostics [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz @@ -2942,10 +2943,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di !! tracer flow control module type(sponge_CS), pointer :: sponge_CSp !< pointer to the sponge module control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure - type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the oda incupd module control structure + type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the ocean data assimilation incremental + !! update module control structure ! Local variables - real :: Kd ! A diffusivity used in the default for other tracer diffusivities, in MKS units [m2 s-1] + real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] logical :: use_temperature character(len=20) :: EN1, EN2, EN3 @@ -3082,11 +3084,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "KD_MIN_TR were operating.", default=.false., do_not_log=.not.CS%useALEalgorithm) if (CS%mix_boundary_tracers .or. CS%mix_boundary_tracer_ALE) then - call get_param(param_file, mdl, "KD", Kd, default=0.0) + call get_param(param_file, mdl, "KD", Kd, units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_MIN_TR", CS%Kd_min_tr, & "A minimal diffusivity that should always be applied to "//& "tracers, especially in massless layers near the bottom. "//& - "The default is 0.1*KD.", units="m2 s-1", default=0.1*Kd, scale=US%m2_s_to_Z2_T) + "The default is 0.1*KD.", & + units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & "A bottom boundary layer tracer diffusivity that will "//& "allow for explicitly specified bottom fluxes. The "//& @@ -3280,9 +3283,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif - ! diagnostics for tendencies of temp and saln due to diabatic processes + ! Diagnostics for tendencies of temperature and salinity due to diabatic processes, ! available only for ALE algorithm. - ! diagnostics for tendencies of temp and heat due to frazil + ! Diagnostics for tendencies of temperature and heat due to frazil CS%id_diabatic_diff_h = register_diag_field('ocean_model', 'diabatic_diff_h', diag%axesTL, Time, & 'Cell thickness used during diabatic diffusion', & thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) @@ -3354,9 +3357,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di CS%diabatic_diff_tendency_diag = .true. endif - ! diagnostics for tendencies of thickness temp and saln due to boundary forcing + ! Diagnostics for tendencies of thickness temperature and salinity due to boundary forcing, ! available only for ALE algorithm. - ! diagnostics for tendencies of temp and heat due to frazil + ! Diagnostics for tendencies of temperature and heat due to frazil CS%id_boundary_forcing_h = register_diag_field('ocean_model', 'boundary_forcing_h', diag%axesTL, Time, & 'Cell thickness after applying boundary forcing', & thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) @@ -3593,8 +3596,8 @@ end subroutine diabatic_driver_end !! calculated flux of the layer above and an estimated flux in the !! layer below. This flux is subject to the following conditions: !! (1) the flux in the top and bottom layers are set by the boundary -!! conditions, and (2) no layer may be driven below an Angstrom thick- -!! ness. If there is a bulk mixed layer, the buffer layer is treated +!! conditions, and (2) no layer may be driven below a minimal thickness. +!! If there is a bulk mixed layer, the buffer layer is treated !! as a fixed density layer with vanishingly small diffusivity. !! !! diabatic takes 5 arguments: the two velocities (u and v), the diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index beb207624a..792c30cc98 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -113,7 +113,8 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & diff_work ! The work actually done by diffusion across each ! interface [R Z3 T-3 ~> W m-2]. Sum vertically for the total work. - real :: hm, fm, fr, fk ! Work variables with units of H, H, H, and H2. + real :: hm, fm, fr ! Work variables with units of [H ~> m or kg m-2]. + real :: fk ! A Work variable with units of [H2 ~> m2 or kg2 m-4] real :: b1(SZI_(G)) ! A variable used by the tridiagonal solver [H ~> m or kg m-2] real :: c1(SZI_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim] @@ -140,9 +141,11 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & zeros, & ! An array of all zeros. (Usually used with [H ~> m or kg m-2].) max_eakb, & ! The maximum value of eakb that might be realized [H ~> m or kg m-2]. min_eakb, & ! The minimum value of eakb that might be realized [H ~> m or kg m-2]. - err_max_eakb0, & ! The value of error returned by determine_Ea_kb - err_min_eakb0, & ! when eakb = min_eakb and max_eakb and ea_kbp1 = 0. - err_eakb0, & ! A value of error returned by determine_Ea_kb. + err_max_eakb0, & ! The value of error returned by determine_Ea_kb when eakb = max_eakb + ! and ea_kbp1 = 0 [H2 ~> m2 or kg2 m-4]. + err_min_eakb0, & ! The value of error returned by determine_Ea_kb when eakb = min_eakb + ! and ea_kbp1 = 0 [H2 ~> m2 or kg2 m-4]. + err_eakb0, & ! A value of error returned by determine_Ea_kb [H2 ~> m2 or kg2 m-4]. F_kb, & ! The value of F in layer kb, or equivalently the entrainment ! from below by layer kb [H ~> m or kg m-2]. dFdfm_kb, & ! The partial derivative of F with fm [nondim]. See dFdfm. @@ -187,7 +190,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! entrain from the layer above [H ~> m or kg m-2]. real :: Kd_here ! The effective diapycnal diffusivity times the timestep [H2 ~> m2 or kg2 m-4]. real :: h_avail ! The thickness that is available for entrainment [H ~> m or kg m-2]. - real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account. + real :: dS_kb_eff ! The value of dS_kb after limiting is taken into account [R ~> kg m-3]. real :: Rho_cor ! The depth-integrated potential density anomaly that ! needs to be corrected for [H R ~> kg m-2 or kg2 m-5]. real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. @@ -752,7 +755,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ea(i,j,k) = ea(i,j,k) + ea_cor eb(i,j,k) = eb(i,j,k) - (dS_kb(i) * I_dSkbp1(i)) * ea_cor elseif (k < kb(i)) then - ! Repetative, unless ea(kb) has been corrected. + ! Repetitive, unless ea(kb) has been corrected. ea(i,j,k) = ea(i,j,k+1) endif enddo @@ -761,7 +764,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ea(i,j,k) = ea(i,j,k+1) enddo ; enddo - ! Repetative, unless ea(kb) has been corrected. + ! Repetitive, unless ea(kb) has been corrected. k=kmb do i=is,ie ! Do not adjust eb through the base of the buffer layers, but it @@ -909,7 +912,7 @@ subroutine F_to_ent(F, h, kb, kmb, j, G, GV, CS, dsp1_ds, eakb, Ent_bl, ea, eb) real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dsp1_ds !< The ratio of coordinate variable !! differences across the interfaces below !! a layer over the difference across the - !! interface above the layer. + !! interface above the layer [nondim]. real, dimension(SZI_(G)), intent(in) :: eakb !< The entrainment from above by the layer !! below the buffer layer [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: Ent_bl !< The average entrainment upward and @@ -1232,13 +1235,14 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & - b1, c1, & ! b1 and c1 are variables used by the tridiagonal solver. - S, dS_dE, & ! The coordinate density [R ~> kg m-3] and its derivative with E. - ea, dea_dE, & ! The entrainment from above and its derivative with E. - eb, deb_dE ! The entrainment from below and its derivative with E. - real :: deriv_dSkb(SZI_(G)) - real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver. - real :: src ! A source term for dS_dR. + b1, c1, & ! b1 [H-1 ~> m-1 or m2 kg-1] and c1 [nondim] are variables used by the tridiagonal solver. + S, dS_dE, & ! The coordinate density [R ~> kg m-3] and its derivative with E [R H-1 ~> kg m-4 or m-1]. + ea, dea_dE, & ! The entrainment from above [H ~> m or kg m-2] and its derivative with E [nondim]. + eb, deb_dE ! The entrainment from below [H ~> m or kg m-2] and its derivative with E [nondim]. + real :: deriv_dSkb(SZI_(G)) ! The limited derivative of the new density difference across the base of + ! the buffer layers with the new density of the bottommost buffer layer [nondim] + real :: d1(SZI_(G)) ! d1 = 1.0-c1 is also used by the tridiagonal solver [nondim]. + real :: src ! A source term for dS_dR [R ~> kg m-3]. real :: h1 ! The thickness in excess of the minimum that will remain ! after exchange with the layer below [H ~> m or kg m-2]. logical, dimension(SZI_(G)) :: do_i @@ -1247,13 +1251,15 @@ subroutine determine_dSkb(h_bl, Sref, Ent_bl, E_kb, is, ie, kmb, G, GV, limit, & real :: h_tr ! h_tr is h at tracer points with a tiny thickness ! added to ensure positive definiteness [H ~> m or kg m-2]. real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. - real :: rat - real :: dS_kbp1, IdS_kbp1 - real :: deriv_dSLay - real :: Inv_term ! [nondim] + real :: rat ! A ratio of density differences [nondim] + real :: dS_kbp1 ! The density difference between the top two interior layers [R ~> kg m-3]. + real :: IdS_kbp1 ! The inverse of dS_kbp1 [R-1 ~> m3 kg-1] + real :: deriv_dSLay ! The derivative of the projected density difference across the topmost interior + ! layer with the density difference across the interface above it [nondim] + real :: Inv_term ! The inverse of a nondimensional expression [nondim] real :: f1, df1_drat ! Temporary variables [nondim]. real :: z, dz_drat, f2, df2_dz, expz ! Temporary variables [nondim]. - real :: eps_dSLay, eps_dSkb ! Small nondimensional constants. + real :: eps_dSLay, eps_dSkb ! Small nondimensional constants [nondim]. integer :: i, k if (present(ddSlay_dE) .and. .not.present(dSlay)) call MOM_error(FATAL, & @@ -1447,16 +1453,21 @@ subroutine F_kb_to_ea_kb(h_bl, Sref, Ent_bl, I_dSkbp1, F_kb, kmb, i, & real, optional, intent(in) :: tol_in !< A tolerance for the iterative determination !! of the entrainment [H ~> m or kg m-2]. - real :: max_ea, min_ea - real :: err, err_min, err_max - real :: derr_dea - real :: val, tolerance, tol1 - real :: ea_prev - real :: dS_kbp1 - logical :: bisect_next, Newton - real, dimension(SZI_(G)) :: dS_kb - real, dimension(SZI_(G)) :: maxF, ent_maxF, zeros - real, dimension(SZI_(G)) :: ddSkb_dE + real :: max_ea, min_ea ! Bounds on the estimated entraiment [H ~> m or kg m-2] + real :: err, err_min, err_max ! Errors in the mass flux balance [H R ~> kg m-2 or kg2 m-5] + real :: derr_dea ! The change in error with the change in ea [R ~> kg m-3] + real :: val ! An estimate mass flux [H R ~> kg m-2 or kg2 m-5] + real :: tolerance, tol1 ! Tolerances for the determination of the entrainment [H ~> m or kg m-2] + real :: ea_prev ! A previous estimate of ea_kb [H ~> m or kg m-2] + real :: dS_kbp1 ! The density difference between two interior layers [R ~> kg m-3] + real :: dS_kb(SZI_(G)) ! The limited potential density difference across the interface + ! between the bottommost buffer layer and the topmost interior layer [R ~> kg m-3] + real :: maxF(SZI_(G)) ! The maximum value of F (the density flux divided by density + ! differences) found in the range min_ent < ent < max_ent [H ~> m or kg m-2]. + real :: ent_maxF(SZI_(G)) ! The value of entrainment that gives maxF [H ~> m or kg m-2] + real :: zeros(SZI_(G)) ! An array of zero entrainments [H ~> m or kg m-2] + real :: ddSkb_dE(SZI_(G)) ! The partial derivative of dS_kb with ea_kb [R H-1 ~> kg m-4 or m-1] + logical :: bisect_next, Newton ! These indicate what method the next iteration should use integer :: it integer, parameter :: MAXIT = 30 @@ -1589,13 +1600,15 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & !! The input value is the first guess. real, dimension(SZI_(G)), optional, intent(out) :: error !< The error (locally defined in this !! routine) associated with the returned - !! solution. + !! solution [H2 ~> m2 or kg2 m-4] real, dimension(SZI_(G)), optional, intent(in) :: err_min_eakb0 !< The errors (locally defined) !! associated with min_eakb when ea_kbp1 = 0, - !! returned from a previous call to this fn. + !! returned from a previous call to this + !! subroutine [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G)), optional, intent(in) :: err_max_eakb0 !< The errors (locally defined) !! associated with min_eakb when ea_kbp1 = 0, - !! returned from a previous call to this fn. + !! returned from a previous call to this + !! subroutine [H2 ~> m2 or kg2 m-4]. real, dimension(SZI_(G)), optional, intent(out) :: F_kb !< The entrainment from below by the !! uppermost interior layer !! corresponding to the returned @@ -1719,7 +1732,7 @@ subroutine determine_Ea_kb(h_bl, dtKd_kb, Sref, I_dSkbp1, Ent_bl, ea_kbp1, & Ent(i) = Ent(i) - err(i) / derror_dE(i) elseif (false_position(i) .and. & (error_maxE(i) - error_minE(i) < 0.9*large_err)) then - ! Use the false postion method if there are decent error estimates. + ! Use the false position method if there are decent error estimates. Ent(i) = E_min(i) + (E_max(i)-E_min(i)) * & (-error_minE(i)/(error_maxE(i) - error_minE(i))) false_position(i) = .false. @@ -1813,17 +1826,21 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & ! negative) value. It is faster to find the true maximum by first finding the ! unlimited maximum and comparing it to the limited value at max_ent_in. real, dimension(SZI_(G)) :: & - ent, & - minent, maxent, ent_best, & - F_max_ent_in, & - F_maxent, F_minent, F, F_best, & - dF_dent, dF_dE_max, dF_dE_min, dF_dE_best, & - dS_kb, dS_kb_lim, ddSkb_dE, dS_anom_lim, & - chg_prev, chg_pre_prev - real :: dF_dE_mean, maxslope, minslope - real :: tolerance - real :: ratio_select_end - real :: rat, max_chg, min_chg, chg1, chg2, chg + ent, & ! The updated estimate of the entrainment [H ~> m or kg m-2] + minent, maxent, ent_best, & ! Various previous estimates of the entrainment [H ~> m or kg m-2] + F_max_ent_in, & ! The value of F that gives the input maximum value of ent [H ~> m or kg m-2] + F_maxent, F_minent, F, F_best, & ! Various estimates of F [H ~> m or kg m-2] + dF_dent, dF_dE_max, dF_dE_min, dF_dE_best, & ! Various derivatives of F with ent [nondim] + dS_kb, & ! The density difference across the interface between the bottommost + ! buffer layer and the topmost interior layer [R ~> kg m-3] + dS_kb_lim, dS_anom_lim, & ! Various limits on dS_kb [R ~> kg m-3] + ddSkb_dE, & ! The partial derivative of dS_kb with ent [R H-1 ~> kg m-4 or m-1]. + chg_prev, chg_pre_prev ! Changes in estimates of the entrainment from previous iterations [H ~> m or kg m-2] + real :: dF_dE_mean, maxslope, minslope ! Various derivatives of F with ent [nondim] + real :: tolerance ! The tolerance within which ent must be converged [H ~> m or kg m-2] + real :: ratio_select_end, rat ! Fractional changes in the value of ent to use for the next iteration + ! relative to its bounded range [nondim] + real :: max_chg, min_chg, chg1, chg2, chg ! Changes in entrainment estimates [H ~> m or kg m-2] logical, dimension(SZI_(G)) :: do_i, last_it, need_bracket, may_use_best logical :: doany, OK1, OK2, bisect, new_min_bound integer :: i, it, is1, ie1 @@ -1876,14 +1893,14 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & maxslope = MAX(dF_dE_mean, dF_dE_min(i), dF_dE_max(i)) minslope = MIN(dF_dE_mean, dF_dE_min(i), dF_dE_max(i)) if (F_minent(i) >= F_maxent(i)) then - if (dF_dE_min(i) > 0.0) then ; rat = 0.02 ! A small step should bracket the soln. + if (dF_dE_min(i) > 0.0) then ; rat = 0.02 ! A small step should bracket the solution. elseif (maxslope < ratio_select_end*minslope) then ! The maximum of F is at minent. F_best(i) = F_minent(i) ; ent_best(i) = minent(i) ; rat = 0.0 do_i(i) = .false. else ; rat = 0.382 ; endif ! Use the golden ratio else - if (dF_dE_max(i) < 0.0) then ; rat = 0.98 ! A small step should bracket the soln. + if (dF_dE_max(i) < 0.0) then ; rat = 0.98 ! A small step should bracket the solution. elseif (minslope > ratio_select_end*maxslope) then ! The maximum of F is at maxent. F_best(i) = F_maxent(i) ; ent_best(i) = maxent(i) ; rat = 1.0 @@ -1979,7 +1996,7 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & new_min_bound = .true. ! We have a new minimum bound. elseif ((F(i) <= F_maxent(i)) .and. (F(i) > F_minent(i))) then new_min_bound = .false. ! We have a new maximum bound. - else ! This case would bracket a minimum. Wierd. + else ! This case would bracket a minimum. Weird. ! Unless the derivative indicates that there is a maximum near the ! lower bound, try keeping the end with the larger value of F ! in a tie keep the minimum as the answer here will be compared @@ -2068,14 +2085,14 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re !! parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate diagnostic !! output. - type(entrain_diffusive_CS), intent(inout) :: CS !< Entrainment diffusion control struct + type(entrain_diffusive_CS), intent(inout) :: CS !< Entrainment diffusion control structure logical, intent(in) :: just_read_params !< If true, this call will only read !! and log parameters without registering !! any diagnostics ! Local variables - real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT, in MKS units [s] - real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT, in MKS units [m2 s-1] + real :: dt ! The dynamics timestep, used here in the default for TOLERANCE_ENT [T ~> s] + real :: Kd ! A diffusivity used in the default for TOLERANCE_ENT [Z2 T-1 ~> m2 s-1] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_entrain_diffusive" ! This module's name. @@ -2090,14 +2107,14 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re call get_param(param_file, mdl, "MAX_ENT_IT", CS%max_ent_it, & "The maximum number of iterations that may be used to "//& "calculate the interior diapycnal entrainment.", default=5, do_not_log=just_read_params) - ! In this module, KD is only used to set the default for TOLERANCE_ENT. [m2 s-1] - call get_param(param_file, mdl, "KD", Kd, default=0.0) + ! In this module, KD is only used to set the default for TOLERANCE_ENT. [Z2 T-1 ~> m2 s-1] + call get_param(param_file, mdl, "KD", Kd, units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DT", dt, & - "The (baroclinic) dynamics time step.", units = "s", & - fail_if_missing=.true., do_not_log=just_read_params) + "The (baroclinic) dynamics time step.", & + units="s", scale=US%s_to_T, fail_if_missing=.true., do_not_log=just_read_params) call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & + units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)*US%Z_to_m), scale=GV%m_to_H, & do_not_log=just_read_params) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R @@ -2119,10 +2136,10 @@ end subroutine entrain_diffusive_init !! mixing and advection in isopycnal layers. The main subroutine, !! calculate_entrainment, returns the entrainment by each layer !! across the interfaces above and below it. These are calculated -!! subject to the constraints that no layers can be driven to neg- -!! ative thickness and that the each layer maintains its target -!! density, using the scheme described in Hallberg (MWR 2000). There -!! may or may not be a bulk mixed layer above the isopycnal layers. +!! subject to the constraints that no layers can be driven to negative +!! thickness and that the each layer maintains its target density, +!! using the scheme described in Hallberg (MWR 2000). There may or +!! may not be a bulk mixed layer above the isopycnal layers. !! The solution is iterated until the change in the entrainment !! between successive iterations is less than some small tolerance. !! @@ -2134,9 +2151,9 @@ end subroutine entrain_diffusive_init !! diffusion, so the fully implicit upwind differencing scheme that !! is used is entirely appropriate. The downward buoyancy flux in !! each layer is determined from an implicit calculation based on -!! the previously calculated flux of the layer above and an estim- -!! ated flux in the layer below. This flux is subject to the foll- -!! owing conditions: (1) the flux in the top and bottom layers are +!! the previously calculated flux of the layer above and an estimated +!! flux in the layer below. This flux is subject to the following +!! conditions: (1) the flux in the top and bottom layers are !! set by the boundary conditions, and (2) no layer may be driven !! below an Angstrom thickness. If there is a bulk mixed layer, the !! mixed and buffer layers are treated as Eulerian layers, whose diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index c088eea5bb..1e8015eacd 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -356,8 +356,8 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & intent(inout) :: kv_io !< The vertical viscosity at each interface [Z2 T-1 ~> m2 s-1]. !! The previous value is used to initialize kappa - !! in the vertex columes as Kappa = Kv/Prandtl - !! to accelerate the iteration toward covergence. + !! in the vertex columns as Kappa = Kv/Prandtl + !! to accelerate the iteration toward convergence. real, intent(in) :: dt !< Time increment [T ~> s]. type(Kappa_shear_CS), pointer :: CS !< The control structure returned by a previous !! call to kappa_shear_init. @@ -650,7 +650,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & S2, & ! The squared shear at an interface [T-2 ~> s-2]. a1, & ! a1 is the coupling between adjacent interfaces in the TKE, ! velocity, and density equations [Z s-1 ~> m s-1] or [Z ~> m] - c1, & ! c1 is used in the tridiagonal (and similar) solvers. + c1, & ! c1 is used in the tridiagonal (and similar) solvers [nondim]. k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. kappa_out, & ! The kappa that results from the kappa equation [Z2 T-1 ~> m2 s-1]. @@ -675,9 +675,9 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! sources from the elliptic term [T-1 ~> s-1]. real :: dist_from_bot ! The distance from the bottom surface [Z ~> m]. - real :: b1 ! The inverse of the pivot in the tridiagonal equations. - real :: bd1 ! A term in the denominator of b1. - real :: d1 ! 1 - c1 in the tridiagonal equations. + real :: b1 ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. + real :: bd1 ! A term in the denominator of b1 [Z ~> m]. + real :: d1 ! 1 - c1 in the tridiagonal equations [nondim] real :: gR0 ! A conversion factor from Z to pressure, given by Rho_0 times g ! [R L2 T-2 Z-1 ~> kg m-2 s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. @@ -1060,10 +1060,13 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int !! diffusivity. ! Local variables - real, dimension(nz+1) :: c1 - real :: L2_to_Z2 ! A conversion factor from horizontal length units to vertical depth - ! units squared [Z2 s2 T-2 m-2 ~> 1]. - real :: a_a, a_b, b1, d1, bd1, b1nz_0 + real, dimension(nz+1) :: c1 ! A tridiagonal variable [nondim] + real :: L2_to_Z2 ! A conversion factor from horizontal length units to vertical depth + ! units squared [Z2 s2 T-2 m-2 ~> 1]. + real :: a_a, a_b ! Tridiagonal coupling coefficients [Z ~> m] + real :: b1, b1nz_0 ! Tridiagonal variables [Z-1 ~> m-1] + real :: bd1 ! A term in the denominator of b1 [Z ~> m] + real :: d1 ! A tridiagonal variable [nondim] integer :: k, ks, ke ks = 1 ; ke = nz @@ -1166,7 +1169,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity !! [Z2 T-1 ~> m2 s-1]. real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces - !! [Z-1 ~> m-1]. + !! [Z ~> m]. real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to !! boundaries [Z-2 ~> m-2]. real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. @@ -1203,7 +1206,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [T ~> s]. dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [T-1 ~> s-1]. e1 ! The fractional change in a layer TKE due to a change in the - ! TKE of the layer above when all the kappas below are 0. + ! TKE of the layer above when all the kappas below are 0 [nondim]. ! e1 is nondimensional, and 0 < e1 < 1. real :: tke_src ! The net source of TKE due to mixing against the shear ! and stratification [Z2 T-3 ~> m2 s-3]. (For convenience, @@ -1213,13 +1216,13 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real :: bK ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. real :: bQd1 ! A term in the denominator of bQ [Z T-1 ~> m s-1]. real :: bKd1 ! A term in the denominator of bK [Z ~> m]. - real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations. + real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations [nondim]. real :: c_s2 ! The coefficient for the decay of TKE due to - ! shear (i.e. proportional to |S|*tke), nondimensional. + ! shear (i.e. proportional to |S|*tke) [nondim]. real :: c_n2 ! The coefficient for the decay of TKE due to ! stratification (i.e. proportional to N*tke) [nondim]. real :: Ri_crit ! The critical shear Richardson number for shear- - ! driven mixing. The theoretical value is 0.25. + ! driven mixing [nondim]. The theoretical value is 0.25. real :: q0 ! The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: Ilambda2 ! 1.0 / CS%lambda**2 [nondim] real :: TKE_min ! The minimum value of shear-driven TKE that can be @@ -1227,31 +1230,33 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real :: kappa0 ! The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. - real :: eden1, eden2, I_eden, ome ! Variables used in calculating e1. + real :: eden1, eden2 ! Variables used in calculating e1 [Z-1 ~> m-1] + real :: I_eden ! The inverse of the denominator in e1 [Z ~> m] + real :: ome ! Variables used in calculating e1 [nondim] real :: diffusive_src ! The diffusive source in the kappa equation [Z T-1 ~> m s-1]. real :: chg_by_k0 ! The value of k_src that leads to an increase of ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1]. real :: kappa_mean ! A mean value of kappa [Z2 T-1 ~> m2 s-1]. real :: Newton_test ! The value of relative error that will cause the next - ! iteration to use Newton's method. + ! iteration to use Newton's method [nondim]. ! Temporary variables used in the Newton's method iterations. - real :: decay_term_k ! The decay term in the diffusivity equation + real :: decay_term_k ! The decay term in the diffusivity equation [Z-1 ~> m-1] real :: decay_term_Q ! The decay term in the TKE equation - proportional to [T-1 ~> s-1] real :: I_Q ! The inverse of TKE [T2 Z-2 ~> s2 m-2] - real :: kap_src + real :: kap_src ! A source term in the kappa equation [Z T-1 ~> m s-1] real :: v1 ! A temporary variable proportional to [T-1 ~> s-1] - real :: v2 - real :: tol_err ! The tolerance for max_err that determines when to - ! stop iterating. - real :: Newton_err ! The tolerance for max_err that determines when to - ! start using Newton's method. Empirically, an initial - ! value of about 0.2 seems to be most efficient. - real, parameter :: roundoff = 1.0e-16 ! A negligible fractional change in TKE. - ! This could be larger but performance gains are small. + real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] + real :: tol_err ! The tolerance for max_err that determines when to + ! stop iterating [nondim]. + real :: Newton_err ! The tolerance for max_err that determines when to + ! start using Newton's method [nondim]. Empirically, an initial + ! value of about 0.2 seems to be most efficient. + real, parameter :: roundoff = 1.0e-16 ! A negligible fractional change in TKE [nondim]. + ! This could be larger but performance gains are small. logical :: tke_noflux_bottom_BC = .false. ! Specify the boundary conditions - logical :: tke_noflux_top_BC = .false. ! that are applied to the TKE eqns. + logical :: tke_noflux_top_BC = .false. ! that are applied to the TKE equations. logical :: do_Newton ! If .true., use Newton's method for the next iteration. logical :: abort_Newton ! If .true., an Newton's method has encountered a 0 ! pivot, and should not have been used. @@ -1265,7 +1270,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! These variables are used only for debugging. logical, parameter :: debug_soln = .false. - real :: K_err_lin, Q_err_lin + real :: K_err_lin ! The imbalance in the K equation [Z T-1 ~> m s-1] + real :: Q_err_lin ! The imbalance in the Q equation [Z2 T-3 ~> m2 s-3] real, dimension(nz+1) :: & I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. @@ -1726,15 +1732,15 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) logical :: kappa_shear_init !< True if module is to be used, False otherwise ! Local variables + real :: KD_normal ! The KD of the main model, read here only as a parameter + ! for setting the default of KD_SMOOTH [Z2 T-1 ~> m2 s-1] + real :: kappa_0_default ! The default value for KD_KAPPA_SHEAR_0 [Z2 T-1 ~> m2 s-1] logical :: merge_mixedlayer logical :: debug_shear logical :: just_read ! If true, this module is not used, so only read the parameters. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_kappa_shear" ! This module's name. - real :: kappa_0_unscaled ! The value of kappa_0 in MKS units [m2 s-1] - real :: KD_normal ! The KD of the main model, read here only as a parameter - ! for setting the default of KD_SMOOTH in MKS units [m2 s-1] if (associated(CS)) then call MOM_error(WARNING, "kappa_shear_init called with an associated "// & @@ -1775,18 +1781,21 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "MAX_RINO_IT", CS%max_RiNo_it, & "The maximum number of iterations that may be used to "//& "estimate the Richardson number driven mixing.", & - default=50, do_not_log=just_read) - call get_param(param_file, mdl, "KD", KD_normal, default=0.0, do_not_log=.true.) + units="nondim", default=50, do_not_log=just_read) + call get_param(param_file, mdl, "KD", KD_normal, & + units="m2 s-1", scale=US%m2_s_to_Z2_T, default=0.0, do_not_log=.true.) + kappa_0_default = max(Kd_normal, 1.0e-7*US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_KAPPA_SHEAR_0", CS%kappa_0, & "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & - units="m2 s-1", default=max(KD_normal, 1.0e-7), scale=US%m2_s_to_Z2_T, & - unscaled=kappa_0_unscaled, do_not_log=just_read) + units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & + do_not_log=just_read) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & - units="m2 s-1", default=0.01*kappa_0_unscaled, scale=US%m2_s_to_Z2_T, do_not_log=just_read) + units="m2 s-1", default=0.01*CS%kappa_0*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & + do_not_log=just_read) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & "The nondimensional curvature of the function of the "//& "Richardson number in the kappa source term in the "//& @@ -1950,7 +1959,7 @@ end function kappa_shear_at_vertex !! TKE with shear and stratification fixed, then marches the density !! and velocities forward with an adaptive (and aggressive) time step !! in a predictor-corrector-corrector emulation of a trapezoidal -!! scheme. Run-time-settable parameters determine the tolerence to +!! scheme. Run-time-settable parameters determine the tolerance to !! which the kappa and TKE equations are solved and the minimum time !! step that can be taken. diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index deb1c90ca9..8966c12b79 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -151,10 +151,11 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. Rcv_tol, & ! A tolerence, relative to the target density differences ! between layers, for detraining into the interior [nondim]. - h_add_tgt, h_add_tot, & - h_tot1, Th_tot1, Sh_tot1, & - h_tot3, Th_tot3, Sh_tot3, & - h_tot2, Th_tot2, Sh_tot2 + h_add_tgt, & ! The target for the thickness to add to the mixed layers [H ~> m or kg m-2] + h_add_tot, & ! The net thickness added to the mixed layers [H ~> m or kg m-2] + h_tot1, h_tot2, h_tot3, & ! Debugging diagnostics of total thicknesses [H ~> m or kg m-2] + Th_tot1, Th_tot2, Th_tot3, & ! Debugging diagnostics of integrated temperatures [C H ~> degC m or degC kg m-2] + Sh_tot1, Sh_tot2, Sh_tot3 ! Debugging diagnostics of integrated salinities [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)) :: & h_prev_1d ! The previous thicknesses [H ~> m or kg m-2]. real :: I_dtol ! The inverse of the tolerance changes [nondim]. @@ -168,16 +169,17 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) int_flux, & ! Mass flux across the interfaces [H ~> m or kg m-2] int_Tflux, & ! Temperature flux across the interfaces [C H ~> degC m or degC kg m-2] int_Sflux ! Salinity flux across the interfaces [S H ~> ppt m or ppt kg m-2] - real :: h_add - real :: h_det_tot - real :: max_def_rat + real :: h_add ! The thickness to add to the layers above an interface [H ~> m or kg m-2] + real :: h_det_tot ! The total thickness detrained by the mixed layers [H ~> m or kg m-2] + real :: max_def_rat ! The maximum value of the ratio of the thickness deficit to the minimum depth [nondim] real :: Rcv_min_det ! The lightest (min) and densest (max) coordinate density real :: Rcv_max_det ! that can detrain into a layer [R ~> kg m-3]. - real :: int_top, int_bot - real :: h_predicted - real :: h_prev - real :: h_deficit + real :: int_top, int_bot ! The interface depths above and below a layer [H ~> m or kg m-2], positive upward. + real :: h_predicted ! An updated thickness [H ~> m or kg m-2] + real :: h_prev ! The previous thickness [H ~> m or kg m-2] + real :: h_deficit ! The difference between the layer thickness and the value estimated from the + ! filtered interface depths [H ~> m or kg m-2] logical :: cols_left, ent_any, more_ent_i(SZI_(G)), ent_i(SZI_(G)) logical :: det_any, det_i(SZI_(G)) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 6d35616b3a..8257d19bd3 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -69,8 +69,7 @@ module MOM_set_diffusivity !! drag law c_drag*|u|*u. logical :: BBL_mixing_as_max !< If true, take the maximum of the diffusivity !! from the BBL mixing and the other diffusivities. - !! Otherwise, diffusivities from the BBL_mixing is - !! added. + !! Otherwise, diffusivities from the BBL_mixing is added. logical :: use_LOTW_BBL_diffusivity !< If true, use simpler/less precise, BBL diffusivity. logical :: LOTW_BBL_use_omega !< If true, use simpler/less precise, BBL diffusivity. real :: Von_Karm !< The von Karman constant as used in the BBL diffusivity calculation @@ -115,10 +114,9 @@ module MOM_set_diffusivity !! is the rotation rate of the earth squared. real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. - real :: ML_rad_efold_coeff !< non-dim coefficient to scale penetration depth - real :: ML_rad_coeff !< coefficient, which scales MSTAR*USTAR^3 to - !! obtain energy available for mixing below - !! mixed layer base [nondim] + real :: ML_rad_efold_coeff !< Coefficient to scale penetration depth [nondim] + real :: ML_rad_coeff !< Coefficient which scales MSTAR*USTAR^3 to obtain energy + !! available for mixing below mixed layer base [nondim] logical :: ML_rad_bug !< If true use code with a bug that reduces the energy available !! in the transition layer by a factor of the inverse of the energy !! deposition lenthscale (in m). @@ -135,7 +133,7 @@ module MOM_set_diffusivity !! of the vertical component of rotation when !! setting the decay scale for mixed layer turbulence. real :: ML_omega_frac !< When setting the decay scale for turbulence, use - !! this fraction of the absolute rotation rate blended + !! this fraction [nondim] of the absolute rotation rate blended !! with the local value of f, as f^2 ~= (1-of)*f^2 + of*4*omega^2. logical :: user_change_diff !< If true, call user-defined code to change diffusivity. logical :: useKappaShear !< If true, use the kappa_shear module to find the @@ -149,9 +147,9 @@ module MOM_set_diffusivity logical :: use_tidal_mixing !< If true, activate tidal mixing diffusivity. logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. - real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering + real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 T-1 ~> m2 s-1] - real :: Kv_molecular !< molecular visc for double diff convect [Z2 T-1 ~> m2 s-1] + real :: Kv_molecular !< Molecular viscosity for double diffusive convection [Z2 T-1 ~> m2 s-1] integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's !! calculations. Values below 20190101 recover the answers from the @@ -185,9 +183,9 @@ module MOM_set_diffusivity Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from ackground diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - KT_extra => NULL(), & !< double diffusion diffusivity for temp [Z2 T-1 ~> m2 s-1]. - KS_extra => NULL(), & !< double diffusion diffusivity for saln [Z2 T-1 ~> m2 s-1]. + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [Z2 T-1 ~> m2 s-1]. + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [Z2 T-1 ~> m2 s-1]. drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE @@ -262,8 +260,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_int_2d, & !< The interface diffusivities [Z2 T-1 ~> m2 s-1] Kv_bkgnd, & !< The background diffusion related interface viscosities [Z2 T-1 ~> m2 s-1] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] - KT_extra, & !< Double difusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] - KS_extra !< Double difusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] + KT_extra, & !< Double diffusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] + KS_extra !< Double diffusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] real :: dissip ! local variable for dissipation calculations [Z2 R T-3 ~> W m-3] real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] @@ -673,7 +671,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(out) :: TKE_to_Kd !< The conversion rate between the !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain @@ -701,12 +699,11 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] p_0 ! An array of 0 pressures [R L2 T-2 ~> Pa] - real :: dh_max ! maximum amount of entrainment a layer could - ! undergo before entraining all fluid in the layers - ! above or below [Z ~> m]. + real :: dh_max ! maximum amount of entrainment a layer could undergo before + ! entraining all fluid in the layers above or below [Z ~> m]. real :: dRho_lay ! density change across a layer [R ~> kg m-3] real :: Omega2 ! rotation rate squared [T-2 ~> s-2] - real :: G_Rho0 ! gravitation accel divided by Bouss ref density [Z T-2 R-1 ~> m4 s-2 kg-1] + real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density [Z T-2 R-1 ~> m4 s-2 kg-1] real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 ~> m4 s-2 kg-1] real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] real :: I_dt ! 1/dt [T-1 ~> s-1] @@ -911,16 +908,16 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & z_from_bot ! The hieght above the bottom [Z ~> m]. real :: dz_int ! thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! gravitation acceleration divided by Bouss reference density + real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. - real :: H_neglect ! negligibly small thickness, in the same units as h. + real :: H_neglect ! A negligibly small thickness [H ~> m or kg m-2] logical :: do_i(SZI_(G)), do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -1064,8 +1061,8 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G)) :: & - dRho_dT, & ! partial derivatives of density wrt temp [R C-1 ~> kg m-3 degC-1] - dRho_dS, & ! partial derivatives of density wrt saln [R S-1 ~> kg m-3 ppt-1] + dRho_dT, & ! partial derivatives of density with respect to temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! partial derivatives of density with respect to salinity [R S-1 ~> kg m-3 ppt-1] pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at interfaces [C ~> degC] Salin_int ! Salinity at interfaces [S ~> ppt] @@ -1076,7 +1073,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 T-1 ~> m2 s-1] - real :: prandtl ! flux ratio for diffusive convection regime + real :: prandtl ! flux ratio for diffusive convection regime [nondim] real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] @@ -1146,7 +1143,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the - !! diapycnal diffusivity witin that layer, + !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain @@ -1274,7 +1271,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! if (maxEnt(i,k) <= 0.0) cycle if (maxTKE(i,k) <= 0.0) cycle - ! This is an analytic integral where diffusity is a quadratic function of + ! This is an analytic integral where diffusivity is a quadratic function of ! rho that goes asymptotically to 0 at Rho_top (vaguely following KPP?). if (TKE(i) > 0.0) then if (Rint(K) <= Rho_top(i)) then @@ -1395,7 +1392,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: dh, dhm1 ! thickness of layers k and k-1, respecitvely [Z ~> m]. + real :: dh, dhm1 ! thickness of layers k and k-1, respectively [Z ~> m]. real :: z_bot ! distance to interface k from bottom [Z ~> m]. real :: D_minus_z ! distance to interface k from surface [Z ~> m]. real :: total_thickness ! total thickness of water column [Z ~> m]. @@ -1550,7 +1547,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 T-1 ~> m2 s-1]. - real :: C1_6 ! 1/6 + real :: C1_6 ! 1/6 [nondim] real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] real :: dzL ! thickness converted to heights [Z ~> m]. @@ -1623,7 +1620,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, do i=is,ie ; if (do_i(i)) then dzL = GV%H_to_Z*h(i,j,k) ; z1 = dzL*I_decay(i) if (CS%ML_Rad_bug) then - ! These expresssions are dimensionally inconsistent. -RWH + ! These expressions are dimensionally inconsistent. -RWH ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then @@ -1881,8 +1878,8 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) ! Local variables real :: g_R0 ! g_R0 is a rescaled version of g/Rho [L2 Z-1 R-1 T-2 ~> m4 kg-1 s-2] - real :: eps, tmp ! nondimensional temporary variables - real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables + real :: eps, tmp ! nondimensional temporary variables [nondim] + real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables [nondim] real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] real :: Rcv(SZI_(G),SZK_(GV)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] @@ -1950,7 +1947,7 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) do k3=2,kmb ! ds_dsp1(i,k3) = MAX(a(k3),1e-5) - ! Deliberately treat convective instabilies of the upper mixed + ! Deliberately treat convective instabilities of the upper mixed ! and buffer layers with respect to the deepest buffer layer as ! though they don't exist. They will be eliminated by the upcoming ! call to the mixedlayer code anyway. @@ -1974,7 +1971,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control struct + type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control structure integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version @@ -1986,7 +1983,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ !! surface boundary layer. ! Local variables - real :: decay_length + real :: decay_length ! The maximum decay scale for the BBL diffusion [Z ~> m] logical :: ML_use_omega 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. @@ -2176,7 +2173,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "for an isopycnal layer-formulation.", & default=.false., do_not_log=.not.TKE_to_Kd_used) - ! set params related to the background mixing + ! set parameters related to the background mixing call bkgnd_mixing_init(Time, G, GV, US, param_file, CS%diag, CS%bkgnd_mixing_csp, physical_OBL_scheme) call get_param(param_file, mdl, "KV", CS%Kv, & @@ -2340,7 +2337,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ end subroutine set_diffusivity_init -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory subroutine set_diffusivity_end(CS) type(set_diffusivity_CS), intent(inout) :: CS !< Control structure for this module diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e9497d0e92..249cbb5777 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -48,10 +48,10 @@ module MOM_set_visc logical :: initialized = .false. !< True if this control structure has been initialized. real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. !! Runtime parameter `HBBL`. - real :: cdrag !< The quadratic drag coefficient. + real :: cdrag !< The quadratic drag coefficient [nondim]. !! Runtime parameter `CDRAG`. real :: c_Smag !< The Laplacian Smagorinsky coefficient for - !! calculating the drag in channels. + !! calculating the drag in channels [nondim]. real :: drag_bg_vel !< An assumed unresolved background velocity for !! calculating the bottom drag [L T-1 ~> m s-1]. !! Runtime parameter `DRAG_BG_VEL`. @@ -233,7 +233,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: C24_a ! 24/a [H-1 ~> m-1 or m2 kg-1]. real :: slope ! The absolute value of the bottom depth slope across ! a cell times the cell width [H ~> m or kg m-2]. - real :: apb_4a, ax2_3apb ! Various nondimensional ratios of a and slope. + real :: apb_4a, ax2_3apb ! Various nondimensional ratios of a and slope [nondim]. real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of a and slope [H-1 ~> m-1 or m2 kg-1]. ! All of the following "volumes" have units of thickness because they are normalized ! by the full horizontal area of a velocity cell. @@ -282,12 +282,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: h_bbl_fr ! The fraction of the bottom boundary layer in a layer [nondim]. real :: h_sum ! The sum of the thicknesses of the layers below the one being ! worked on [H ~> m or kg m-2]. - real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 - real :: C2pi_3 ! An irrational constant, 2/3 pi. - real :: tmp ! A temporary variable. - real :: tmp_val_m1_to_p1 + real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + real :: C2pi_3 ! An irrational constant, 2/3 pi. [nondim] + real :: tmp ! A temporary variable, sometimes in [Z ~> m] + real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] real :: curv_tol ! Numerator of curvature cubed, used to estimate - ! accuracy of a single L(:) Newton iteration + ! accuracy of a single L(:) Newton iteration [H5 ~> m3 or kg5 m-10] logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state @@ -1099,7 +1099,7 @@ function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) integer, intent(in) :: j !< The j-index of the u-location to work on. integer, intent(in) :: k !< The k-index of the u-location to work on. real, dimension(SZI_(G),SZJB_(G)),& - intent(in) :: mask2dCv !< A multiplicative mask of the v-points + intent(in) :: mask2dCv !< A multiplicative mask of the v-points [nondim] type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure real :: set_v_at_u !< The return value of v at u points points in the !! same units as u, i.e. [L T-1 ~> m s-1] or other units. @@ -1144,7 +1144,7 @@ function set_u_at_v(u, h, G, GV, i, j, k, mask2dCu, OBC) integer, intent(in) :: j !< The j-index of the u-location to work on. integer, intent(in) :: k !< The k-index of the u-location to work on. real, dimension(SZIB_(G),SZJ_(G)), & - intent(in) :: mask2dCu !< A multiplicative mask of the u-points + intent(in) :: mask2dCu !< A multiplicative mask of the u-points [nondim] type(ocean_OBC_type), pointer :: OBC !< A pointer to an open boundary condition structure real :: set_u_at_v !< The return value of u at v points in the !! same units as u, i.e. [L T-1 ~> m s-1] or other units. @@ -1213,8 +1213,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Rhtot, & ! The integrated density of layers that are within the surface mixed layer ! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no ! equation of state is used. - uhtot, & ! The depth integrated zonal and meridional velocities within - vhtot, & ! the surface mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + uhtot, & ! The depth integrated zonal velocity within the surface + ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + vhtot, & ! The depth integrated meridional velocity within the surface + ! mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. Idecay_len_TKE, & ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. dR_dT, & ! Partial derivative of the density at the base of layer nkml ! (roughly the base of the mixed layer) with temperature [R C-1 ~> kg m-3 degC-1]. @@ -1261,8 +1263,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! on the mixed layer thickness and density difference across ! the base of the mixed layer [L2 T-2 ~> m2 s-2]. real :: RiBulk ! The bulk Richardson number below which water is in the - ! viscous mixed layer, including reduction for turbulent - ! decay. Nondimensional. + ! viscous mixed layer, including reduction for turbulent decay [nondim] real :: dt_Rho0 ! The time step divided by the conversion from the layer ! thickness to layer mass [T H Z-1 R-1 ~> s m3 kg-1 or s]. real :: g_H_Rho0 ! The gravitational acceleration times the conversion from H to m divided @@ -1871,7 +1872,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) logical :: adiabatic, useKPP, useEPBL logical :: use_CVMix_shear, MLE_use_PBL_MLD, use_CVMix_conv integer :: isd, ied, jsd, jed, nz - real :: hfreeze !< If hfreeze > 0 [m], melt potential will be computed. + real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. character(len=40) :: mdl = "MOM_set_visc" ! This module's name. isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -1929,7 +1930,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) default=.false., do_not_log=.true.) ! visc%MLD needs to be allocated when melt potential is computed (HFREEZE>0) call get_param(param_file, mdl, "HFREEZE", hfreeze, & - default=-1.0, do_not_log=.true.) + units="m", default=-1.0, scale=US%m_to_Z, do_not_log=.true.) if (MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) @@ -2001,11 +2002,11 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [m] real :: Z_rescale ! A rescaling factor for heights from the representation in - ! a restart file to the internal representation in this run. + ! 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. + ! 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. + ! 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. @@ -2100,14 +2101,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "determine the mixed layer thickness for viscosity.", & default=.false.) if (CS%dynamic_viscous_ML) then - call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, default=0.0) + call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, units="nondim", default=0.0) call get_param(param_file, mdl, "BULK_RI_ML_VISC", CS%bulk_Ri_ML, & "The efficiency with which mean kinetic energy released "//& "by mechanically forced entrainment of the mixed layer "//& "is converted to turbulent kinetic energy. By default, "//& "BULK_RI_ML_VISC = BULK_RI_ML or 0.", units="nondim", & default=bulk_Ri_ML_dflt) - call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, default=0.0) + call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, units="nondim", default=0.0) call get_param(param_file, mdl, "TKE_DECAY_VISC", CS%TKE_decay, & "TKE_DECAY_VISC relates the vertical rate of decay of "//& "the TKE available for mechanical entrainment to the "//& @@ -2118,7 +2119,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & "If true, use the absolute rotation rate instead of the "//& "vertical component of rotation when setting the decay "//& - "scale for turbulence.", default=.false., do_not_log=.true.) + "scale for turbulence.", default=.false., do_not_log=.true.) omega_frac_dflt = 0.0 if (use_omega) then call MOM_error(WARNING, "ML_USE_OMEGA is deprecated; use ML_OMEGA_FRAC=1.0 instead.") @@ -2223,7 +2224,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS default=.false.) if (CS%Channel_drag) then - call get_param(param_file, mdl, "SMAG_LAP_CONST", smag_const1, default=-1.0) + call get_param(param_file, mdl, "SMAG_LAP_CONST", smag_const1, units="nondim", default=-1.0) cSmag_chan_dflt = 0.15 if (smag_const1 >= 0.0) cSmag_chan_dflt = smag_const1 From d01c42ae9c478972afb697feda382c123b1e7c60 Mon Sep 17 00:00:00 2001 From: Angus Gibson Date: Tue, 22 Nov 2022 10:06:47 +1100 Subject: [PATCH 057/629] Use small minimum ustar in mixed layer restratification If the forcing ustar is exactly zero, the denominator of the momentum mixing rate term reduces to just the Coriolis parameter. With a grid construction that is symmetric about the equator, this term is also exactly zero, leading to a division by zero. To avoid this, a very small minimum ustar value is introduced, using the Earth's rotation as a velocity timescale, in the same manner as in some of the vertical parameterisations. This should prevent the denominator of the momentum mixing rate from going to zero. --- .../lateral/MOM_mixed_layer_restrat.F90 | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 0aef33ddc6..506046340d 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -61,6 +61,7 @@ module MOM_mixed_layer_restrat 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 + real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] @@ -160,6 +161,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] + real :: ustar_min ! A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] 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 :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux @@ -307,6 +309,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z + ustar_min = 2e-4 * CS%omega * US%T_to_S * (GV%Angstrom_Z + dz_neglect) if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -378,7 +381,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! U - Component !$OMP do do j=js,je ; do I=is-1,ie - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) + u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & @@ -453,7 +456,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! V- component !$OMP do do J=js-1,je ; do i=is,ie - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) + u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & @@ -627,6 +630,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] + real :: ustar_min ! A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] @@ -662,6 +666,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z + ustar_min = 2e-4 * CS%omega * US%T_to_S * (GV%Angstrom_Z + dz_neglect) if (.not.use_EOS) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") @@ -705,7 +710,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do j=js,je ; do I=is-1,ie h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) + u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 @@ -751,7 +756,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do J=js-1,je ; do i=is,ie h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z - u_star = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) + u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 @@ -926,6 +931,10 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) endif + call get_param(param_file, mdl, "OMEGA", CS%omega, & + "The rotation rate of the earth.", units="s-1", & + default=7.2921e-5, scale=US%T_to_s) + CS%diag => diag From e2ef845146b4db971c44c4f2adf4a27cd4e150ab Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 7 Dec 2022 13:58:54 -0500 Subject: [PATCH 058/629] Switch from mpich to openmpi Testing to see if GH actions is failing due to MPI installation --- .github/actions/ubuntu-setup/action.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3fd2ea13cf..3f3ba5f0b6 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install mpich - sudo apt-get install libmpich-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" From 380864138fb936e3e0bd76bb5155d74200e89db8 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 7 Dec 2022 13:58:54 -0500 Subject: [PATCH 059/629] Switch from mpich to openmpi Testing to see if GH actions is failing due to MPI installation --- .github/actions/ubuntu-setup/action.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3fd2ea13cf..3f3ba5f0b6 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install mpich - sudo apt-get install libmpich-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" From 01242a7bec3a2c17cf168977fff01d9dad11cf93 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 12 Sep 2022 08:53:10 -0400 Subject: [PATCH 060/629] makedep PEP8 cleanup This is a first pass to refactoring the makedep script, primarily to make it PEP8 compliant. --- ac/makedep | 233 +++++++++++++++++++++++++++++++---------------------- 1 file changed, 138 insertions(+), 95 deletions(-) diff --git a/ac/makedep b/ac/makedep index 443371a79f..d201b49ab2 100755 --- a/ac/makedep +++ b/ac/makedep @@ -6,7 +6,8 @@ import argparse import glob import os import re -import sys # used only to get path to current script +import sys # used only to get path to current script + # Pre-compile re searches re_module = re.compile(r"^ *module +([a-z_0-9]+)") @@ -15,7 +16,9 @@ re_cpp_include = re.compile(r"^ *# *include *[<\"']([a-zA-Z_0-9\.]+)[>\"']") re_f90_include = re.compile(r"^ *include +[\"']([a-zA-Z_0-9\.]+)[\"']") re_program = re.compile(r"^ *[pP][rR][oO][gG][rR][aA][mM] +([a-zA-Z_0-9]+)") -def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, script_path): + +def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, + link_externals, script_path): """Create "makefile" after scanning "src_dis".""" # Scan everything Fortran related @@ -23,85 +26,92 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, # Lists of things # ... all F90 source - F90_files = [f for f in all_files if f.endswith('.f90') or f.endswith('.F90')] + F90_files = [ + f for f in all_files + if f.endswith('.f90') or f.endswith('.F90') + ] # ... all C source c_files = [f for f in all_files if f.endswith('.c')] # Dictionaries for associating files to files # maps basename of file to full path to file - f2F = dict( zip( [os.path.basename(f) for f in all_files], all_files ) ) + f2F = dict(zip([os.path.basename(f) for f in all_files], all_files)) # maps basename of file to directory - f2dir = dict( zip( [os.path.basename(f) for f in all_files], [os.path.dirname(f) for f in all_files] ) ) + f2dir = dict(zip([os.path.basename(f) for f in all_files], + [os.path.dirname(f) for f in all_files])) # Check for duplicate files in search path if not len(f2F) == len(all_files): a = [] for f in all_files: if os.path.basename(f) in a: - print('Warning: File %s was found twice! One is being ignored but which is undefined.'%(os.path.basename(f))) - a.append( os.path.basename(f) ) + print('Warning: File {} was found twice! One is being ignored ' + 'but which is undefined.'.format(os.path.basename(f))) + a.append(os.path.basename(f)) # maps object file to F90 source - o2F90 = dict( zip( [ object_file(f) for f in F90_files ], F90_files ) ) + o2F90 = dict(zip([object_file(f) for f in F90_files], F90_files)) # maps object file to C source - o2c = dict( zip( [ object_file(f) for f in c_files ], c_files ) ) + o2c = dict(zip([object_file(f) for f in c_files], c_files)) o2mods, o2uses, o2h, o2inc, o2prg, prg2o, mod2o = {}, {}, {}, {}, {}, {}, {} externals, all_modules = [], [] for f in F90_files: - mods, used, cpp, inc, prg = scan_fortran_file( f ) + mods, used, cpp, inc, prg = scan_fortran_file(f) # maps object file to modules produced - o2mods[ object_file(f) ] = mods + o2mods[object_file(f)] = mods # maps module produced to object file for m in mods: - mod2o[ m ] = object_file(f) + mod2o[m] = object_file(f) # maps object file to modules used - o2uses[ object_file(f) ] = used + o2uses[object_file(f)] = used # maps object file to .h files included - o2h[ object_file(f) ] = cpp + o2h[object_file(f)] = cpp # maps object file to .inc files included - o2inc[ object_file(f) ] = inc + o2inc[object_file(f)] = inc # maps object file to executables produced - o2prg[ object_file(f) ] = prg + o2prg[object_file(f)] = prg if prg: for p in prg: if p in prg2o.keys(): #raise ValueError("Files %s and %s both create the same program '%s'"%( # f,o2F90[prg2o[p]],p)) - print("Warning: Files %s and %s both create the same program '%s'"%( - f,o2F90[prg2o[p]],p)) - o = prg2o[ p ] - del prg2o[ p ] - #del o2prg[ o ] - need to keep so modifying instead - o2prg[ o ] = [ '[ignored %s]'%(p) ] + print("Warning: Files {} and {} both create the same " + "program '{}'".format(f, o2F90[prg2o[p]], p)) + o = prg2o[p] + del prg2o[p] + #del o2prg[o] - need to keep so modifying instead + o2prg[o] = ['[ignored %s]'%(p)] else: - prg2o[ p ] = object_file(f) + prg2o[p] = object_file(f) if not mods and not prg: - externals.append( object_file(f) ) + externals.append(object_file(f)) all_modules += mods for f in c_files: - _, _, cpp, inc, _ = scan_fortran_file( f ) + _, _, cpp, inc, _ = scan_fortran_file(f) # maps object file to .h files included - o2h[ object_file(f) ] = cpp + o2h[object_file(f)] = cpp # Are we building a library, single or multiple executables? targ_libs = [] if exec_target: if exec_target.endswith('.a'): - targ_libs.append( exec_target ) + targ_libs.append(exec_target) else: if len(prg2o.keys()) == 1: o = prg2o.values()[0] - del prg2o[ o2prg[o][0] ] - prg2o[ exec_target ] = o - o2prg[ o ] = exec_target + del prg2o[o2prg[o][0]] + prg2o[exec_target] = o + o2prg[o] = exec_target else: - raise ValueError("Option -x specified an executable name but none or multiple programs were found") - targets = [ exec_target ] + raise ValueError("Option -x specified an executable name but " + "none or multiple programs were found") + targets = [exec_target] else: if len(prg2o.keys()) == 0: - print("Warning: No programs were found and -x did not specify a library to build") + print("Warning: No programs were found and -x did not specify a " + "library to build") targets = prg2o.keys() # Create new makefile @@ -111,7 +121,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, print("# Invoked as", file=file) print('# '+' '.join(sys.argv), file=file) print("", file=file) - print("all:", " ".join( targets ), file=file) + print("all:", " ".join(targets), file=file) print("", file=file) #print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) @@ -123,14 +133,14 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, #print("", file=file) # Write rule for each object from Fortran - for o in sorted( o2F90.keys() ): + for o in sorted(o2F90.keys()): found_mods = [m for m in o2uses[o] if m in all_modules] missing_mods = [m for m in o2uses[o] if m not in all_modules] - incs = nested_inc( o2h[o] + o2inc[o], f2F ) - incdeps = sorted( set( [ f2F[f] for f in incs if f in f2F ] ) ) - incargs = sorted( set( [ '-I'+os.path.dirname(f) for f in incdeps ] ) ) + incs = nested_inc(o2h[o] + o2inc[o], f2F) + incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) + incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) if debug: - print("# Source file %s produces:"%(o2F90[o]), file=file) + print("# Source file {} produces:".format(o2F90[o]), file=file) print("# object:", o, file=file) print("# modules:", ' '.join(o2mods[o]), file=file) print("# uses:", ' '.join(o2uses[o]), file=file) @@ -142,13 +152,13 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, print("# program:", ' '.join(o2prg[o]), file=file) if o2mods[o]: print(' '.join(o2mods[o])+':',o, file=file) - print(o+':', o2F90[o], ' '.join(incdeps+found_mods), file=file) + print(o + ':', o2F90[o], ' '.join(incdeps+found_mods), file=file) print('\t'+fc_rule, ' '.join(incargs), file=file) # Write rule for each object from C - for o in sorted( o2c.keys() ): - incdeps = sorted( set( [ f2F[h] for h in o2h[o] if h in f2F ] ) ) - incargs = sorted( set( [ '-I'+os.path.dirname(f) for f in incdeps ] ) ) + for o in sorted(o2c.keys()): + incdeps = sorted(set([f2F[h] for h in o2h[o] if h in f2F])) + incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) if debug: print("# Source file %s produces:"%(o2c[o]), file=file) print("# object:", o, file=file) @@ -161,23 +171,24 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, # Externals (so called) if link_externals: print("", file=file) - print("# Note: The following object files are not associated with modules so we assume we should link with them:", file=file) + print("# Note: The following object files are not associated with " + "modules so we assume we should link with them:", file=file) print("# ", ' '.join(externals), file=file) o2x = None else: externals = [] # Write rules for linking executables - for p in sorted( prg2o.keys() ): + for p in sorted(prg2o.keys()): o = prg2o[p] print("", file=file) - print(p+':',' '.join( link_obj(o, o2uses, mod2o, all_modules) + externals ), file=file ) + print(p+':',' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) # Write rules for building libraries - for l in sorted( targ_libs ): + for l in sorted(targ_libs): print("", file=file) - print(l+':',' '.join( list(o2F90.keys()) + list(o2c.keys()) ), file=file ) + print(l+':',' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) print('\t$(AR) $(ARFLAGS) $@ $^', file=file) # Write cleanup rules @@ -190,11 +201,12 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, link_externals, print("remakedep:", file=file) print('\t'+' '.join(sys.argv), file=file) + def link_obj(obj, o2uses, mod2o, all_modules): """List of all objects needed to link "obj",""" def recur(obj, depth=0): if obj not in olst: - olst.append( obj) + olst.append(obj) else: return uses = [m for m in o2uses[obj] if m in all_modules] @@ -205,97 +217,128 @@ def link_obj(obj, o2uses, mod2o, all_modules): recur(o, depth=depth+1) #if o not in olst: # recur(o, depth=depth+1) - # olst.append( o ) + # olst.append(o) return return olst = [] recur(obj) - return sorted( set( olst) ) + return sorted(set(olst)) + def nested_inc(inc_files, f2F): - """List of all files included by "inc_files", either by #include or F90 include.""" + """List of all files included by "inc_files", either by #include or F90 + include.""" def recur(hfile): if hfile not in f2F.keys(): return - _, _, cpp, inc, _ = scan_fortran_file( f2F[hfile] ) - if len(cpp)+len(inc)>0: + _, _, cpp, inc, _ = scan_fortran_file(f2F[hfile]) + if len(cpp) + len(inc) > 0: for h in cpp+inc: if h not in hlst and h in f2F.keys(): recur(h) - hlst.append( h ) + hlst.append(h) return return hlst = [] for h in inc_files: recur(h) - return inc_files + sorted( set( hlst ) ) + return inc_files + sorted(set(hlst)) + def scan_fortran_file(src_file): - """Scan the Fortran file "src_file" and return lists of module defined, module used, and files included.""" + """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: lines = file.readlines() for line in lines: - match = re_module.match( line.lower() ) + match = re_module.match(line.lower()) if match: - if match.group(1) not in 'procedure': # avoid "module procedure" statements - module_decl.append( match.group(1) ) - match = re_use.match( line.lower() ) + if match.group(1) not in 'procedure': # avoid "module procedure" statements + module_decl.append(match.group(1)) + match = re_use.match(line.lower()) if match: - used_modules.append( match.group(1) ) - match = re_cpp_include.match( line ) + used_modules.append(match.group(1)) + match = re_cpp_include.match(line) if match: - cpp_includes.append( match.group(1) ) - match = re_f90_include.match( line ) + cpp_includes.append(match.group(1)) + match = re_f90_include.match(line) if match: - f90_includes.append( match.group(1) ) - match = re_program.match( line ) + f90_includes.append(match.group(1)) + match = re_program.match(line) if match: - programs.append( match.group(1) ) + programs.append(match.group(1)) used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] - return add_suff(module_decl, '.mod'), add_suff( used_modules, '.mod'), cpp_includes, f90_includes, programs - #return add_suff(module_decl, '.mod'), add_suff( sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs + return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs + #return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs + def object_file(src_file): - """Return the name of an object file that results from compiling src_file.""" - return os.path.splitext( os.path.basename( src_file ) )[0] + '.o' + """Return the name of an object file that results from compiling + src_file.""" + return os.path.splitext(os.path.basename(src_file))[0] + '.o' def find_files(src_dirs): - """Return sorted list of all source files starting from each directory in the list "src_dirs".""" + """Return sorted list of all source files starting from each directory in + the list "src_dirs".""" files = [] for path in src_dirs: if not os.path.isdir(path): - raise ValueError("Directory '%s' was not found"%(path)) - for p, d, f in os.walk( os.path.normpath(path), followlinks=True): + raise ValueError("Directory '{}' was not found".format(path)) + for p, d, f in os.walk(os.path.normpath(path), followlinks=True): for file in f: - if file.endswith('.F90') or file.endswith('.f90') or file.endswith('.h') or file.endswith('.inc') or file.endswith('.c'): + # TODO: use any() + if (file.endswith('.F90') or file.endswith('.f90') + or file.endswith('.h') or file.endswith('.inc') + or file.endswith('.c')): files.append(p+'/'+file) - return sorted( set( files ) ) + return sorted(set(files)) + def add_suff(lst, suff): """Add "suff" to each item in the list""" - return [ f+suff for f in lst ] + return [f + suff for f in lst] + # Parse arguments parser = argparse.ArgumentParser( - description="Generate make dependencies for F90 source code.") -parser.add_argument('path', nargs='+', - help="Directories to search for source code.") -parser.add_argument('-o', '--makefile', default='Makefile.dep', - help="Name of Makefile to put dependencies in to. Default is Makefile.dep.") -parser.add_argument('-f', '--fc_rule', default="$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<", - help="""String to use in the compilation rule. Default is: - '$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<'""") -parser.add_argument('-x', '--exec_target', - help="""Name of executable to build. - Fails if more than one program is found. - If EXEC ends in .a then a library is built.""") -parser.add_argument('-e', '--link_externals', action='store_true', - help="Always compile and link any files that do not produce modules (externals).") -parser.add_argument('-d', '--debug', action='store_true', - help="Annotate the makefile with extra information.") + description="Generate make dependencies for F90 source code." +) +parser.add_argument( + 'path', + nargs='+', + help="Directories to search for source code." +) +parser.add_argument( + '-o', '--makefile', + default='Makefile.dep', + help="Name of Makefile to put dependencies in to. Default is Makefile.dep." +) +parser.add_argument( + '-f', '--fc_rule', + default="$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<", + help="String to use in the compilation rule. Default is: " + "'$(FC) $(DEFS) $(FCFLAGS) $(CPPFLAGS) -c $<'" +) +parser.add_argument( + '-x', '--exec_target', + help="Name of executable to build. Fails if more than one program is " + "found. If EXEC ends in .a then a library is built." +) +parser.add_argument( + '-e', '--link_externals', + action='store_true', + help="Always compile and link any files that do not produce modules " + "(externals)." +) +parser.add_argument( + '-d', '--debug', + action='store_true', + help="Annotate the makefile with extra information." +) args = parser.parse_args() # Do the thing -create_deps(args.path, args.makefile, args.debug, args.exec_target, args.fc_rule, args.link_externals, sys.argv[0]) +create_deps(args.path, args.makefile, args.debug, args.exec_target, + args.fc_rule, args.link_externals, sys.argv[0]) From 8f7b1fb8a9b8c682fc83fe7f1091d71cef5d0d9b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 9 Dec 2022 10:33:48 -0500 Subject: [PATCH 061/629] makedep: Include C derived object files in list of "externals" Applying makedep to a single shot build of FMS+MOM6 (i.e. skipping the libFMS.a) I found the list of objects was incomplete because the C files were not covered by the module dependencies. makedep figures out the Fortran module dependencies and then has a list of "externals" to cover all the files that don't provide modules. "externals" are always compiled, in lieu of flinting the source code. This commit simply adds all the C object files to the list of externals. When building a library, the module dependencies are ignore and everything gets built, which is why this gap was not seen before. --- ac/makedep | 1 + 1 file changed, 1 insertion(+) diff --git a/ac/makedep b/ac/makedep index d201b49ab2..829928626b 100755 --- a/ac/makedep +++ b/ac/makedep @@ -92,6 +92,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, _, _, cpp, inc, _ = scan_fortran_file(f) # maps object file to .h files included o2h[object_file(f)] = cpp + externals.append(object_file(f)) # Are we building a library, single or multiple executables? targ_libs = [] From 9bc8772afb4c8a11a829c351824dfd431d7a14ce Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 9 Dec 2022 14:05:37 -0500 Subject: [PATCH 062/629] makedep: PEP8 cleanup Fixes all remaining PEP8 violations in ac/makedep (using line length = 132). --- ac/makedep | 36 ++++++++++++++++++------------------ 1 file changed, 18 insertions(+), 18 deletions(-) diff --git a/ac/makedep b/ac/makedep index 829928626b..5954f1aae5 100755 --- a/ac/makedep +++ b/ac/makedep @@ -74,14 +74,14 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, if prg: for p in prg: if p in prg2o.keys(): - #raise ValueError("Files %s and %s both create the same program '%s'"%( + # raise ValueError("Files %s and %s both create the same program '%s'"%( # f,o2F90[prg2o[p]],p)) print("Warning: Files {} and {} both create the same " "program '{}'".format(f, o2F90[prg2o[p]], p)) o = prg2o[p] del prg2o[p] - #del o2prg[o] - need to keep so modifying instead - o2prg[o] = ['[ignored %s]'%(p)] + # del o2prg[o] - need to keep so modifying instead + o2prg[o] = ['[ignored %s]' % (p)] else: prg2o[p] = object_file(f) if not mods and not prg: @@ -117,7 +117,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, # Create new makefile with open(makefile, 'w') as file: - print("# %s created by makedep"%(makefile), file=file) + print("# %s created by makedep" % (makefile), file=file) print("", file=file) print("# Invoked as", file=file) print('# '+' '.join(sys.argv), file=file) @@ -125,13 +125,13 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, print("all:", " ".join(targets), file=file) print("", file=file) - #print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) - #print("# record it here from when makedep was previously invoked.", file=file) - #print("SRC_DIRS ?= ${SRC_DIRS}", file=file) - #print("", file=file) + # print("# SRC_DIRS is usually set in the parent Makefile but in case is it not we", file=file) + # print("# record it here from when makedep was previously invoked.", file=file) + # print("SRC_DIRS ?= ${SRC_DIRS}", file=file) + # print("", file=file) - #print("# all_files:", ' '.join(all_files), file=file) - #print("", file=file) + # print("# all_files:", ' '.join(all_files), file=file) + # print("", file=file) # Write rule for each object from Fortran for o in sorted(o2F90.keys()): @@ -152,7 +152,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, print("# incargs:", ' '.join(incargs), file=file) print("# program:", ' '.join(o2prg[o]), file=file) if o2mods[o]: - print(' '.join(o2mods[o])+':',o, file=file) + print(' '.join(o2mods[o])+':', o, file=file) print(o + ':', o2F90[o], ' '.join(incdeps+found_mods), file=file) print('\t'+fc_rule, ' '.join(incargs), file=file) @@ -161,7 +161,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, incdeps = sorted(set([f2F[h] for h in o2h[o] if h in f2F])) incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) if debug: - print("# Source file %s produces:"%(o2c[o]), file=file) + print("# Source file %s produces:" % (o2c[o]), file=file) print("# object:", o, file=file) print("# includes_all:", ' '.join(o2h[o]), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) @@ -183,13 +183,13 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, for p in sorted(prg2o.keys()): o = prg2o[p] print("", file=file) - print(p+':',' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) + print(p+':', ' '.join(link_obj(o, o2uses, mod2o, all_modules) + externals), file=file) print('\t$(LD) $(LDFLAGS) -o $@ $^ $(LIBS)', file=file) # Write rules for building libraries - for l in sorted(targ_libs): + for lb in sorted(targ_libs): print("", file=file) - print(l+':',' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) + print(lb+':', ' '.join(list(o2F90.keys()) + list(o2c.keys())), file=file) print('\t$(AR) $(ARFLAGS) $@ $^', file=file) # Write cleanup rules @@ -211,12 +211,12 @@ def link_obj(obj, o2uses, mod2o, all_modules): else: return uses = [m for m in o2uses[obj] if m in all_modules] - if len(uses)>0: + if len(uses) > 0: ouses = [mod2o[m] for m in uses] for m in uses: o = mod2o[m] recur(o, depth=depth+1) - #if o not in olst: + # if o not in olst: # recur(o, depth=depth+1) # olst.append(o) return @@ -271,7 +271,7 @@ def scan_fortran_file(src_file): programs.append(match.group(1)) used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs - #return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs + # return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs def object_file(src_file): From 3327037b03e7d4e9c235c986e9935eab0bebd491 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 24 Nov 2022 08:22:20 -0500 Subject: [PATCH 063/629] Document units in 8 lat_param or diag modules Documented numerous internal variables and their units in 3 lateral parameterization modules (MOM_hor_visc, MOM_lateral_mixing_coeffs, MOM_MEKE_types) and the write_cputime module. In addition, the units of a number of internal variables in the MOM_sum_output module and arguments to call_tracer_stocks were added to their descriptions in comments. This commit includes the addition of units arguments in 9 unlogged get_param calls, comments describing why parameters are not rescaled, and the rescaling of MAXVEL in hor_visc_init. A number of spelling errors were also corrected in comments. All answers and output are bitwise identical. --- src/core/MOM_barotropic.F90 | 6 +- src/diagnostics/MOM_sum_output.F90 | 71 +++++------ src/framework/MOM_write_cputime.F90 | 27 +++-- .../testing/MOM_file_parser_tests.F90 | 8 +- .../lateral/MOM_MEKE_types.F90 | 4 +- .../lateral/MOM_hor_visc.F90 | 111 ++++++++++-------- .../lateral/MOM_lateral_mixing_coeffs.F90 | 74 +++++++----- src/tracer/MOM_tracer_flow_control.F90 | 36 +++--- 8 files changed, 184 insertions(+), 153 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 44711e6526..5fd8a97793 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4614,6 +4614,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "gravity waves) to 1 (for a backward Euler treatment). "//& "In practice, BEBT must be greater than about 0.05.", & units="nondim", default=0.1) + ! Note that dtbt_input is not rescaled because it has different units for + ! positive [s] and negative [nondim] values. call get_param(param_file, mdl, "DTBT", dtbt_input, & "The barotropic time step, in s. DTBT is only used with "//& "the split explicit time stepping. To set the time step "//& @@ -4621,8 +4623,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "a negative value gives the fraction of the stable value. "//& "Setting DTBT to 0 is the same as setting it to -0.98. "//& "The value of DTBT that will actually be used is an "//& - "integer fraction of DT, rounding down.", units="s or nondim",& - default = -0.98) + "integer fraction of DT, rounding down.", & + units="s or nondim", default=-0.98) call get_param(param_file, mdl, "BT_USE_OLD_CORIOLIS_BRACKET_BUG", & CS%use_old_coriolis_bracket_bug , & "If True, use an order of operations that is not bitwise "//& diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 4eb1e67e96..7797a266dd 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -4,6 +4,7 @@ module MOM_sum_output ! This file is part of MOM6. See LICENSE.md for the license. use iso_fortran_env, only : int64 +use MOM_checksums, only : is_NaN use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs @@ -108,14 +109,16 @@ module MOM_sum_output !! of calls to write_energy and revert to the standard !! energysavedays interval - real :: timeunit !< The length of the units for the time axis [s]. + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + logical :: date_stamped_output !< If true, use dates (not times) in messages to stdout. type(time_type) :: Start_time !< The start time of the simulation. ! Start_time is set in MOM_initialization.F90 integer, pointer :: ntrunc => NULL() !< The number of times the velocity has been !! truncated since the last call to write_energy. real :: max_Energy !< The maximum permitted energy per unit mass. If there is - !! more energy than this, the model should stop [m2 s-2]. + !! more energy than this, the model should stop [L2 T-2 ~> m2 s-2]. integer :: maxtrunc !< The number of truncations per energy save !! interval at which the run is stopped. logical :: write_stocks !< If true, write the integrated tracer amounts @@ -147,13 +150,12 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & type(Sum_output_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module. ! Local variables - real :: Time_unit ! The time unit in seconds for ENERGYSAVEDAYS [s] - real :: maxvel ! The maximum permitted velocity [m s-1] + real :: maxvel ! The maximum permitted velocity [L T-1 ~> m s-1] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_sum_output" ! This module's name. character(len=200) :: energyfile ! The name of the energy file. - character(len=32) :: filename_appendix = '' !fms appendix to filename for ensemble runs + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs if (associated(CS)) then call MOM_error(WARNING, "MOM_sum_output_init called with associated control structure.") @@ -190,13 +192,13 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & "The maximum permitted average energy per unit mass; the "//& "model will be stopped if there is more energy than "//& "this. If zero or negative, this is set to 10*MAXVEL^2.", & - units="m2 s-2", default=0.0) + units="m2 s-2", default=0.0, scale=US%m_s_to_L_T**2) if (CS%max_Energy <= 0.0) then call get_param(param_file, mdl, "MAXVEL", maxvel, & "The maximum velocity allowed before the velocity "//& - "components are truncated.", units="m s-1", default=3.0e8) + "components are truncated.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) CS%max_Energy = 10.0 * maxvel**2 - call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy) + call log_param(param_file, mdl, "MAX_ENERGY as used", US%L_T_to_m_s**2*CS%max_Energy, units="m2 s-2") endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & @@ -218,13 +220,12 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & call get_param(param_file, mdl, "DATE_STAMPED_STDOUT", CS%date_stamped_output, & "If true, use dates (not times) in messages to stdout", & default=.true.) + ! Note that the units of CS%Timeunit are the MKS units of [s]. call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & "The time unit in seconds a number of input fields", & units="s", default=86400.0) if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 - - if (CS%do_APE_calc) then call get_param(param_file, mdl, "READ_DEPTH_LIST", CS%read_depth_list, & "Read the depth list from a file if it exists or "//& @@ -257,18 +258,15 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & CS%DL%listsize = 1 endif - call get_param(param_file, mdl, "TIMEUNIT", Time_unit, & - "The time unit for ENERGYSAVEDAYS.", & - units="s", default=86400.0) call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & "The interval in units of TIMEUNIT between saves of the "//& "energies of the run and other globally summed diagnostics.",& - default=set_time(0,days=1), timeunit=Time_unit) + default=set_time(0,days=1), timeunit=CS%Timeunit) call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & "The starting interval in units of TIMEUNIT for the first call "//& "to save the energies of the run and other globally summed diagnostics. "//& "The interval increases by a factor of 2. after each call to write_energy.",& - default=set_time(seconds=0), timeunit=Time_unit) + default=set_time(seconds=0), timeunit=CS%Timeunit) if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & (CS%energysavedays_geometric < CS%energysavedays)) then @@ -328,7 +326,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: PE_tot ! The total available potential energy [J]. real :: Z_0APE(SZK_(GV)+1) ! The uniform depth which overlies the same ! volume as is below an interface [Z ~> m]. - real :: H_0APE(SZK_(GV)+1) ! A version of Z_0APE, converted to m, usually positive. + real :: H_0APE(SZK_(GV)+1) ! A version of Z_0APE, converted to m, usually positive [m]. real :: toten ! The total kinetic & potential energies of ! all layers [J] (i.e. kg m2 s-2). real :: En_mass ! The total kinetic and potential energies divided by @@ -381,7 +379,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci real :: CFL_lin ! A simpler definition of the CFL number [nondim]. real :: max_CFL(2) ! The maxima of the CFL numbers [nondim]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - tmp1 ! A temporary array + tmp1 ! A temporary array used in reproducing sums [various] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & PE_pt ! The potential energy at each point [J]. real, dimension(SZI_(G),SZJ_(G)) :: & @@ -398,21 +396,26 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci ! lbelow & labove are lower & upper limits for li ! in the search for the entry in lH to use. integer :: start_of_day, num_days - real :: reday, var + real :: reday ! Time in units given by CS%Timeunit, but often [days] character(len=240) :: energypath_nc character(len=200) :: mesg character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str logical :: date_stamped type(time_type) :: dt_force ! A time_type version of the forcing timestep. - real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers - real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers - real :: Tr_max(MAX_FIELDS_) ! The global maximum unmasked value of the tracers + ! The units of the tracer stock vary between tracers, with [conc] given explicitly by Tr_units. + real :: Tr_stocks(MAX_FIELDS_) ! The total amounts of each of the registered tracers [kg conc] + real :: Tr_min(MAX_FIELDS_) ! The global minimum unmasked value of the tracers [conc] + real :: Tr_max(MAX_FIELDS_) ! The global maximum unmasked value of the tracers [conc] real :: Tr_min_x(MAX_FIELDS_) ! The x-positions of the global tracer minima + ! in the units of G%geoLonT, often [degrees_E] or [km] real :: Tr_min_y(MAX_FIELDS_) ! The y-positions of the global tracer minima - real :: Tr_min_z(MAX_FIELDS_) ! The z-positions of the global tracer minima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: Tr_min_z(MAX_FIELDS_) ! The z-positions of the global tracer minima [layer] real :: Tr_max_x(MAX_FIELDS_) ! The x-positions of the global tracer maxima + ! in the units of G%geoLonT, often [degrees_E] or [km] real :: Tr_max_y(MAX_FIELDS_) ! The y-positions of the global tracer maxima - real :: Tr_max_z(MAX_FIELDS_) ! The z-positions of the global tracer maxima + ! in the units of G%geoLatT, often [degrees_N] or [km] + real :: Tr_max_z(MAX_FIELDS_) ! The z-positions of the global tracer maxima [layer] logical :: Tr_minmax_avail(MAX_FIELDS_) ! A flag indicating whether the global minimum and ! maximum information are available for each of the tracers character(len=40), dimension(MAX_FIELDS_) :: & @@ -860,8 +863,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif endif - var = real(CS%ntrunc) - call write_field(CS%fileenergy_nc, CS%fields(1), var, reday) + call write_field(CS%fileenergy_nc, CS%fields(1), real(CS%ntrunc), reday) call write_field(CS%fileenergy_nc, CS%fields(2), toten, reday) call write_field(CS%fileenergy_nc, CS%fields(3), PE, reday) call write_field(CS%fileenergy_nc, CS%fields(4), KE, reday) @@ -891,13 +893,12 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci call flush_file(CS%fileenergy_nc) - ! The second (impossible-looking) test looks for a NaN in En_mass. - if ((En_mass>CS%max_Energy) .or. & - ((En_mass>CS%max_Energy) .and. (En_mass US%L_T_to_m_s**2*CS%max_Energy) then write(mesg,'("Energy per unit mass of ",ES11.4," exceeds ",ES11.4)') & - En_mass, CS%max_Energy - call MOM_error(FATAL, & - "write_energy : Excessive energy per unit mass or NaNs forced model termination.") + En_mass, US%L_T_to_m_s**2*CS%max_Energy + call MOM_error(FATAL, "write_energy : Excessive energy per unit mass forced model termination.") endif if (CS%ntrunc>CS%maxtrunc) then call MOM_error(FATAL, "write_energy : Ocean velocity has been truncated too many times.") @@ -913,7 +914,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci end subroutine write_energy -!> This subroutine accumates the net input of volume, salt and heat, through +!> This subroutine accumulates the net input of volume, salt and heat, through !! the ocean surface for use in diagnosing conservation. subroutine accumulate_net_input(fluxes, sfc_state, tv, dt, G, US, CS) type(forcing), intent(in) :: fluxes !< A structure containing pointers to any possible @@ -1100,7 +1101,7 @@ end subroutine depth_list_setup subroutine create_depth_list(G, DL, min_depth_inc) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(Depth_List), intent(inout) :: DL !< The list of depths, areas and volumes to create - real, intent(in) :: min_depth_inc !< The minimum increment bewteen depths in the list [Z ~> m] + real, intent(in) :: min_depth_inc !< The minimum increment between depths in the list [Z ~> m] ! Local variables real, dimension(G%Domain%niglobal*G%Domain%njglobal + 1) :: & @@ -1110,7 +1111,7 @@ subroutine create_depth_list(G, DL, min_depth_inc) indx2 !< The position of an element in the original unsorted list. real :: Dnow !< The depth now being considered for sorting [Z ~> m]. real :: Dprev !< The most recent depth that was considered [Z ~> m]. - real :: vol !< The running sum of open volume below a deptn [Z L2 ~> m3]. + real :: vol !< The running sum of open volume below a depth [Z L2 ~> m3]. real :: area !< The open area at the current depth [L2 ~> m2]. real :: D_list_prev !< The most recent depth added to the list [Z ~> m]. logical :: add_to_list !< This depth should be included as an entry on the list. @@ -1360,7 +1361,7 @@ subroutine get_depth_list_checksums(G, US, depth_chksum, area_chksum) character(len=16), intent(out) :: area_chksum !< Area checksum hexstring integer :: i, j - real, allocatable :: field(:,:) + real, allocatable :: field(:,:) ! A temporary array for output converted to MKS units [m] or [m2] allocate(field(G%isc:G%iec, G%jsc:G%jec)) diff --git a/src/framework/MOM_write_cputime.F90 b/src/framework/MOM_write_cputime.F90 index 5277cef1f6..025dcad2ac 100644 --- a/src/framework/MOM_write_cputime.F90 +++ b/src/framework/MOM_write_cputime.F90 @@ -21,17 +21,17 @@ module MOM_write_cputime !> A control structure that regulates the writing of CPU time type, public :: write_cputime_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: maxcpu !< The maximum amount of cpu time per processor + real :: maxcpu !< The maximum amount of CPU time per processor !! for which MOM should run before saving a restart - !! file and quiting with a return value that + !! file and quitting with a return value that !! indicates that further execution is required to - !! complete the simulation, in wall-clock seconds. + !! complete the simulation [wall-clock seconds]. type(time_type) :: Start_time !< The start time of the simulation. !! Start_time is set in MOM_initialization.F90 - real :: startup_cputime !< The CPU time used in the startup phase of the model. - real :: prev_cputime = 0.0 !< The last measured CPU time. - real :: dn_dcpu_min = -1.0 !< The minimum derivative of timestep with CPU time. - real :: cputime2 = 0.0 !< The accumulated cpu time. + real :: startup_cputime !< The CPU time used in the startup phase of the model [clock_cycles]. + real :: prev_cputime = 0.0 !< The last measured CPU time [clock_cycles]. + real :: dn_dcpu_min = -1.0 !< The minimum derivative of timestep with CPU time [steps clock_cycles-1]. + real :: cputime2 = 0.0 !< The accumulated CPU time [clock_cycles]. integer :: previous_calls = 0 !< The number of times write_CPUtime has been called. integer :: prev_n = 0 !< The value of n from the last call. integer :: fileCPU_ascii= -1 !< The unit number of the CPU time file. @@ -76,8 +76,8 @@ subroutine MOM_write_cputime_init(param_file, directory, Input_start_time, CS) ! Read all relevant parameters and write them to the model log. - ! Determine whether all paramters are set to their default values. - call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, default=-1.0, do_not_log=.true.) + ! Determine whether all parameters are set to their default values. + call get_param(param_file, mdl, "MAXCPU", CS%maxcpu, units="wall-clock seconds", default=-1.0, do_not_log=.true.) call get_param(param_file, mdl, "CPU_TIME_FILE", CS%CPUfile, default="CPU_stats", do_not_log=.true.) all_default = (CS%maxcpu == -1.0) .and. (trim(CS%CPUfile) == trim("CPU_stats")) @@ -135,10 +135,11 @@ subroutine write_cputime(day, n, CS, nmax, call_end) ! Local variables real :: d_cputime ! The change in CPU time since the last call - ! this subroutine. - integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK - real :: reday ! A real version of day. - integer :: start_of_day, num_days + ! this subroutine [clock_cycles] + integer :: new_cputime ! The CPU time returned by SYSTEM_CLOCK [clock_cycles] + real :: reday ! The time in days, including fractional days [days] + integer :: start_of_day ! The number of seconds since the start of the day + integer :: num_days ! The number of days in the time if (.not.associated(CS)) call MOM_error(FATAL, & "write_energy: Module must be initialized before it is used.") diff --git a/src/framework/testing/MOM_file_parser_tests.F90 b/src/framework/testing/MOM_file_parser_tests.F90 index 5ad90caf1b..673cef8c16 100644 --- a/src/framework/testing/MOM_file_parser_tests.F90 +++ b/src/framework/testing/MOM_file_parser_tests.F90 @@ -1468,7 +1468,7 @@ subroutine test_get_param_real call create_test_file(param_filename) call open_param_file(param_filename, param) - call get_param(param, module_name, sample_param_name, sample) + call get_param(param, module_name, sample_param_name, sample, units="") call close_param_file(param) end subroutine test_get_param_real @@ -1480,7 +1480,7 @@ subroutine test_get_param_real_no_read_no_log call create_test_file(param_filename) call open_param_file(param_filename, param) - call get_param(param, module_name, sample_param_name, sample, & + call get_param(param, module_name, sample_param_name, sample, units="", & do_not_read=.true., do_not_log=.true.) call close_param_file(param) end subroutine test_get_param_real_no_read_no_log @@ -1493,7 +1493,7 @@ subroutine test_get_param_real_array call create_test_file(param_filename) call open_param_file(param_filename, param) - call get_param(param, module_name, sample_param_name, sample) + call get_param(param, module_name, sample_param_name, sample, units="") call close_param_file(param) end subroutine test_get_param_real_array @@ -1505,7 +1505,7 @@ subroutine test_get_param_real_array_no_read_no_log call create_test_file(param_filename) call open_param_file(param_filename, param) - call get_param(param, module_name, sample_param_name, sample, & + call get_param(param, module_name, sample_param_name, sample, units="", & do_not_read=.true., do_not_log=.true.) call close_param_file(param) end subroutine test_get_param_real_array_no_read_no_log diff --git a/src/parameterizations/lateral/MOM_MEKE_types.F90 b/src/parameterizations/lateral/MOM_MEKE_types.F90 index 57de7c0b02..e51f558ce3 100644 --- a/src/parameterizations/lateral/MOM_MEKE_types.F90 +++ b/src/parameterizations/lateral/MOM_MEKE_types.F90 @@ -26,8 +26,8 @@ module MOM_MEKE_types ! Parameters real :: KhTh_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTh [nondim] real :: KhTr_fac = 1.0 !< Multiplier to map Kh(MEKE) to KhTr [nondim]. - real :: backscatter_Ro_pow = 0.0 !< Power in Rossby number function for backscatter. - real :: backscatter_Ro_c = 0.0 !< Coefficient in Rossby number function for backscatter. + real :: backscatter_Ro_pow = 0.0 !< Power in Rossby number function for backscatter [nondim]. + real :: backscatter_Ro_c = 0.0 !< Coefficient in Rossby number function for backscatter [nondim]. end type MEKE_type diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index d118f625bf..0574297c0c 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -52,7 +52,7 @@ module MOM_hor_visc logical :: better_bound_Ah !< If true, use a more careful bounding of the !! biharmonic viscosity to guarantee stability. real :: Re_Ah !! If nonzero, the biharmonic coefficient is scaled - !< so that the biharmonic Reynolds number is equal to this. + !< so that the biharmonic Reynolds number is equal to this [nondim]. real :: bound_coef !< The nondimensional coefficient of the ratio of !! the viscosity bounds to the theoretical maximum !! for stability without considering other terms [nondim]. @@ -123,8 +123,8 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & Kh_Max_xx, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xx, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. - n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points - n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points + n1n2_h, & !< Factor n1*n2 in the anisotropic direction tensor at h-points [nondim] + n1n1_m_n2n2_h, & !< Factor n1**2-n2**2 in the anisotropic direction tensor at h-points [nondim] grid_sp_h2, & !< Harmonic mean of the squares of the grid [L2 ~> m2] grid_sp_h3 !< Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: Kh_bg_xy @@ -141,8 +141,8 @@ module MOM_hor_visc real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & Kh_Max_xy, & !< The maximum permitted Laplacian viscosity [L2 T-1 ~> m2 s-1]. Ah_Max_xy, & !< The maximum permitted biharmonic viscosity [L4 T-1 ~> m4 s-1]. - n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points - n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points + n1n2_q, & !< Factor n1*n2 in the anisotropic direction tensor at q-points [nondim] + n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] @@ -181,8 +181,10 @@ module MOM_hor_visc type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostics - ! real, allocatable :: hf_diffu(:,:,:) ! Zonal hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. - ! real, allocatable :: hf_diffv(:,:,:) ! Meridional hor. visc. accel. x fract. thickness [L T-2 ~> m s-2]. + ! real, allocatable :: hf_diffu(:,:,:) ! Zonal horizontal viscous acceleleration times + ! ! fractional thickness [L T-2 ~> m s-2]. + ! real, allocatable :: hf_diffv(:,:,:) ! Meridional horizontal viscous acceleleration times + ! ! fractional thickness [L T-2 ~> m s-2]. ! 3D diagnostics hf_diffu(diffv) are commented because there is no clarity on proper remapping grid option. ! The code is retained for debugging purposes in the future. @@ -242,12 +244,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! of along-coordinate stress tensor [L T-2 ~> m s-2]. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields !! related to Mesoscale Eddy Kinetic Energy. - type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control struct + type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type - type(barotropic_CS), intent(in), optional :: BT !< Barotropic control struct - type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control struct + type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure + type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics ! Local variables @@ -256,20 +258,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - ubtav ! zonal barotropic vel. ave. over baroclinic time-step [L T-1 ~> m s-1] + ubtav ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - vbtav ! meridional barotropic vel. ave. over baroclinic time-step [L T-1 ~> m s-1] + vbtav ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [T-1 ~> s-1] div_xx, & ! Estimate of horizontal divergence at h-points [T-1 ~> s-1] sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] - str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2] - str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg s-2] + str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but + ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. + str_xx_GME,& ! smoothed diagonal term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xx, & ! A copy of str_xx that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] FrictWorkIntz, & ! depth integrated energy dissipated by lateral friction [R L2 T-3 ~> W m-2] grad_vort_mag_h, & ! Magnitude of vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] @@ -288,8 +291,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 ~> s-1] sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1] - str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2] - str_xy_GME, & ! smoothed cross term in the stress tensor from GME [H L2 T-2 ~> m3 s-2 or kg s-2] + str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but + ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. + str_xy_GME, & ! smoothed cross term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] @@ -310,9 +314,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & - KH_u_GME !< interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + KH_u_GME !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & - KH_v_GME !< interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + KH_v_GME !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1] Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] @@ -324,7 +328,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & 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 coeff. at h-points [L2 T-1 ~> m2 s-1] + GME_coeff_h ! GME coefficient at h-points [L2 T-1 ~> m2 s-1] 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] @@ -342,7 +346,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: RoScl ! The scaling function for MEKE source term [nondim] real :: FatH ! abs(f) at h-point for MEKE source term [T-1 ~> s-1] real :: local_strain ! Local variable for interpolating computed strain rates [T-1 ~> s-1]. - real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE. Otherwise =1. + real :: meke_res_fn ! A copy of the resolution scaling factor if being applied to MEKE [nondim]. Otherwise = 1. real :: GME_coeff ! The GME (negative) viscosity coefficient [L2 T-1 ~> m2 s-1] real :: DY_dxBu ! Ratio of meridional over zonal grid spacing at vertices [nondim] real :: DX_dyBu ! Ratio of zonal over meridional grid spacing at vertices [nondim] @@ -352,7 +356,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: KE ! Local kinetic energy [L2 T-2 ~> m2 s-2] real :: d_del2u ! dy-weighted Laplacian(u) diff in x [L-2 T-1 ~> m-2 s-1] real :: d_del2v ! dx-weighted Laplacian(v) diff in y [L-2 T-1 ~> m-2 s-1] - real :: d_str ! Stress tensor update [H L2 T-2 ~> m3 s-2 or kg s-2] + real :: d_str ! Stress tensor update [L2 T-2 ~> m2 s-2] real :: grad_vort ! Vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1] real :: grad_vort_qg ! QG-based vorticity gradient magnitude [L-1 T-1 ~> m-1 s-1] real :: grid_Kh ! Laplacian viscosity bound by grid [L2 T-1 ~> m2 s-1] @@ -365,7 +369,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: use_MEKE_Au integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - real :: inv_PI3, inv_PI2, inv_PI6 + real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] ! Fields evaluated on active layers, used for constructing 3D stress fields ! NOTE: The position of these declarations can impact performance, due to the @@ -419,7 +423,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if ((rescale_Kh .or. CS%res_scale_MEKE) & .and. (.not. allocated(VarMix%Res_fn_h) .or. .not. allocated(VarMix%Res_fn_q))) & call MOM_error(FATAL, "MOM_hor_visc: VarMix%Res_fn_h and VarMix%Res_fn_q "//& - "both need to be associated with Resoln_scaled_Kh or RES_SCALE_MEKE_VISC.") + "both need to be associated with Resoln_scaled_Kh or RES_SCALE_MEKE_VISC.") elseif (CS%res_scale_MEKE) then call MOM_error(FATAL, "MOM_hor_visc: VarMix needs to be associated if "//& "RES_SCALE_MEKE_VISC is True.") @@ -430,7 +434,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_GME) then - ! initialize diag. array with zeros + ! Initialize diagnostic arrays with zeros GME_coeff_h(:,:,:) = 0.0 GME_coeff_q(:,:,:) = 0.0 str_xx_GME(:,:) = 0.0 @@ -1418,11 +1422,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call smooth_GME(CS, G, GME_flux_h=str_xx_GME) call smooth_GME(CS, G, GME_flux_q=str_xy_GME) + ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = (str_xx(i,j) + str_xx_GME(i,j)) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - ! GME is applied below + ! This adds in GME and changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. if (CS%no_slip) then do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = (str_xy(I,J) + str_xy_GME(I,J)) * (hq(I,J) * CS%reduction_xy(I,J)) @@ -1434,10 +1439,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif else ! .not. use_GME + ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = str_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo + ! This changes the units of str_xy from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. if (CS%no_slip) then do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = str_xy(I,J) * (hq(I,J) * CS%reduction_xy(I,J)) @@ -1685,10 +1692,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics - real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v - real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v - ! u0v is the Laplacian sensitivities to the v velocities - ! at u points [L-2 ~> m-2], with u0u, v0u, and v0v defined similarly. + ! u0v is the Laplacian sensitivities to the v velocities at u points, with u0u, v0u, and v0v defined analogously. + real, dimension(SZIB_(G),SZJ_(G)) :: u0u, u0v ! Laplacian sensitivities at u points [L-2 ~> m-2] + real, dimension(SZI_(G),SZJB_(G)) :: v0u, v0v ! Laplacian sensitivities at v points [L-2 ~> m-2] real :: grid_sp_h2 ! Harmonic mean of the squares of the grid [L2 ~> m2] real :: grid_sp_h3 ! Harmonic mean of the squares of the grid^(3/2) [L3 ~> m3] real :: grid_sp_q2 ! spacings at h and q points [L2 ~> m2] @@ -1708,19 +1714,19 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) real :: Kh_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing gives Laplacian viscosity real :: Ah_vel_scale ! this speed [L T-1 ~> m s-1] times grid spacing cubed gives biharmonic viscosity real :: Ah_time_scale ! damping time-scale for biharmonic visc [T ~> s] - real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant - real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant - real :: Leith_Lap_const ! nondimensional Laplacian Leith constant - real :: Leith_bi_const ! nondimensional biharmonic Leith constant + real :: Smag_Lap_const ! nondimensional Laplacian Smagorinsky constant [nondim] + real :: Smag_bi_const ! nondimensional biharmonic Smagorinsky constant [nondim] + real :: Leith_Lap_const ! nondimensional Laplacian Leith constant [nondim] + real :: Leith_bi_const ! nondimensional biharmonic Leith constant [nondim] real :: dt ! The dynamics time step [T ~> s] real :: Idt ! The inverse of dt [T-1 ~> s-1] - real :: denom ! work variable; the denominator of a fraction - real :: maxvel ! largest permitted velocity components [m s-1] + real :: denom ! work variable; the denominator of a fraction [L-2 ~> m-2] or [L-4 ~> m-4] + real :: maxvel ! largest permitted velocity components [L T-1 ~> m s-1] real :: bound_Cor_vel ! grid-scale velocity variations at which value ! the quadratically varying biharmonic viscosity ! balances Coriolis acceleration [L T-1 ~> m s-1] real :: Kh_sin_lat ! Amplitude of latitudinally dependent viscosity [L2 T-1 ~> m2 s-1] - real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat + real :: Kh_pwr_of_sine ! Power used to raise sin(lat) when using Kh_sin_lat [nondim] logical :: bound_Cor_def ! parameter setting of BOUND_CORIOLIS logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. @@ -1732,9 +1738,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags character(len=200) :: inputdir, filename ! Input file names and paths character(len=80) :: Kh_var ! Input variable names - real :: deg2rad ! Converts degrees to radians - real :: slat_fn ! sin(lat)**Kh_pwr_of_sine - real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction + real :: deg2rad ! Converts degrees to radians [radians degree-1] + real :: slat_fn ! sin(lat)**Kh_pwr_of_sine [nondim] + real :: aniso_grid_dir(2) ! Vector (n1,n2) for anisotropic direction [nondim] integer :: aniso_mode ! Selects the mode for setting the anisotropic direction integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -1945,12 +1951,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "value of BOUND_CORIOLIS (or false).", default=bound_Cor_def, & do_not_log=.not.CS%Smagorinsky_Ah) if (.not.CS%Smagorinsky_Ah) CS%bound_Coriolis = .false. - call get_param(param_file, mdl, "MAXVEL", maxvel, default=3.0e8) + call get_param(param_file, mdl, "MAXVEL", maxvel, & + units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) call get_param(param_file, mdl, "BOUND_CORIOLIS_VEL", bound_Cor_vel, & "The velocity scale at which BOUND_CORIOLIS_BIHARM causes "//& "the biharmonic drag to have comparable magnitude to the "//& "Coriolis acceleration. The default is set by MAXVEL.", & - units="m s-1", default=maxvel, scale=US%m_s_to_L_T, & + units="m s-1", default=maxvel*US%L_T_to_m_s, scale=US%m_s_to_L_T, & do_not_log=.not.(CS%Smagorinsky_Ah .and. CS%bound_Coriolis)) call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & @@ -2229,8 +2236,8 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J)) enddo ; enddo CS%Ah_bg_xy(:,:) = 0.0 - ! The 0.3 below was 0.4 in MOM1.10. The change in hq requires - ! this to be less than 1/3, rather than 1/2 as before. + ! The 0.3 below was 0.4 in HIM 1.10. The change in hq requires + ! this to be less than 1/3, rather than 1/2 as before. if (CS%better_bound_Ah .or. CS%bound_Ah) Ah_Limit = 0.3 / (dt*64.0) if (CS%Smagorinsky_Ah .and. CS%bound_Coriolis) & BoundCorConst = 1.0 / (5.0*(bound_Cor_vel*bound_Cor_vel)) @@ -2533,10 +2540,10 @@ subroutine align_aniso_tensor_to_grid(CS, n1, n2) real, intent(in) :: n1 !< i-component of direction vector [nondim] real, intent(in) :: n2 !< j-component of direction vector [nondim] ! Local variables - real :: recip_n2_norm + real :: recip_n2_norm ! The inverse of the squared magnitude of n1 and n2 [nondim] ! For normalizing n=(n1,n2) in case arguments are not a unit vector recip_n2_norm = n1**2 + n2**2 - if (recip_n2_norm > 0.) recip_n2_norm = 1./recip_n2_norm + if (recip_n2_norm > 0.) recip_n2_norm = 1. / recip_n2_norm CS%n1n2_h(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n2_q(:,:) = 2. * ( n1 * n2 ) * recip_n2_norm CS%n1n1_m_n2n2_h(:,:) = ( n1 * n1 - n2 * n2 ) * recip_n2_norm @@ -2549,13 +2556,13 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) type(hor_visc_CS), intent(in) :: CS !< Control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: GME_flux_h!< GME diffusive flux - !! at h points + !! at h points [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: GME_flux_q!< GME diffusive flux - !! at q points + !! at q points [L2 T-2 ~> m2 s-2] ! local variables - real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original - real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original - real :: wc, ww, we, wn, ws ! averaging weights for smoothing + real, dimension(SZI_(G),SZJ_(G)) :: GME_flux_h_original ! The previous value of GME_flux_h [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJB_(G)) :: GME_flux_q_original ! The previous value of GME_flux_q [L2 T-2 ~> m2 s-2] + real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] integer :: i, j, s, halosz integer :: xh, xq ! The number of valid extra halo points for h and q points. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -2618,7 +2625,7 @@ end subroutine smooth_GME !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) - type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control struct + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure if (CS%Laplacian .or. CS%biharmonic) then DEALLOC_(CS%dx2h) ; DEALLOC_(CS%dx2q) ; DEALLOC_(CS%dy2h) ; DEALLOC_(CS%dy2q) DEALLOC_(CS%dx_dyT) ; DEALLOC_(CS%dy_dxT) ; DEALLOC_(CS%dx_dyBu) ; DEALLOC_(CS%dy_dxBu) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 50ddd224ed..47d1cd6eb3 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -120,12 +120,13 @@ module MOM_lateral_mixing_coeffs ! Parameters logical :: use_Visbeck !< Use Visbeck formulation for thickness diffusivity integer :: VarMix_Ktop !< Top layer to start downward integrals - real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula + real :: Visbeck_L_scale !< Fixed length scale in Visbeck formula [L ~> m], or if negative a scaling + !! factor [nondim] relating this length scale squared to the cell area real :: Eady_GR_D_scale !< Depth over which to average SN [Z ~> m] - real :: Res_coef_khth !< A non-dimensional number that determines the function + real :: Res_coef_khth !< A coefficient [nondim] that determines the function !! of resolution, used for thickness and tracer mixing, as: !! F = 1 / (1 + (Res_coef_khth*Ld/dx)^Res_fn_power) - real :: Res_coef_visc !< A non-dimensional number that determines the function + real :: Res_coef_visc !< A coefficient [nondim] that determines the function !! of resolution, used for lateral viscosity, as: !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] @@ -167,13 +168,13 @@ module MOM_lateral_mixing_coeffs !> Calculates the non-dimensional depth functions. subroutine calc_depth_function(G, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure ! Local variables integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq integer :: i, j - real :: H0 ! local variable for reference depth - real :: expo ! exponent used in the depth dependent scaling + real :: H0 ! The depth above which KHTH is linearly scaled away [Z ~> m] + real :: expo ! exponent used in the depth dependent scaling [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -186,6 +187,7 @@ subroutine calc_depth_function(G, CS) if (.not. allocated(CS%Depth_fn_v)) call MOM_error(FATAL, & "calc_depth_function: %Depth_fn_v is not associated with Depth_scaled_KhTh.") + ! For efficiency, the reciprocal of H0 should be used instead. H0 = CS%depth_scaled_khth_h0 expo = CS%depth_scaled_khth_exp !$OMP do @@ -206,7 +208,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) 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 type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure ! Local variables ! Depending on the power-function being used, dimensional rescaling may be limited, so some @@ -454,8 +456,8 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, intent(in) :: dt !< Time increment [T ~> s] - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure ! Local variables real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & e ! The interface heights relative to mean sea level [Z ~> m]. @@ -511,27 +513,30 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope [nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: N2_u !< Buoyancy (Brunt-Vaisala) frequency !! at u-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: slope_y !< Meridional isoneutral slope + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: slope_y !< Meridional isoneutral slope [nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: N2_v !< Buoyancy (Brunt-Vaisala) frequency !! at v-points [L2 Z-2 T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure ! Local variables real :: S2 ! Interface slope squared [nondim] real :: N2 ! Positive buoyancy frequency or zero [T-2 ~> s-2] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] - real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. - integer :: is, ie, js, je, nz - integer :: i, j, k - integer :: l_seg - real :: S2max, wNE, wSE, wSW, wNW - real :: H_u(SZIB_(G)), H_v(SZI_(G)) - real :: S2_u(SZIB_(G), SZJ_(G)) - real :: S2_v(SZI_(G), SZJB_(G)) + real :: H_geom ! The geometric mean of Hup and Hdn [H ~> m or kg m-2]. + real :: S2max ! An upper bound on the squared slopes [nondim] + real :: wNE, wSE, wSW, wNW ! Weights of adjacent points [nondim] + real :: H_u(SZIB_(G)), H_v(SZI_(G)) ! Layer thicknesses at u- and v-points [H ~> m or kg m-2] + + ! Note that at some points in the code S2_u and S2_v hold the running depth + ! integrals of the squared slope [H ~> m or kg m-2] before the average is taken. + real :: S2_u(SZIB_(G),SZJ_(G)) ! The thickness-weighted depth average of the squared slope at u points [nondim]. + real :: S2_v(SZI_(G),SZJB_(G)) ! The thickness-weighted depth average of the squared slope at v points [nondim]. + + integer :: i, j, k, is, ie, js, je, nz, l_seg if (.not. CS%initialized) call MOM_error(FATAL, "calc_Visbeck_coeffs_old: "// & "Module must be initialized before it is used.") @@ -628,7 +633,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C enddo enddo -! Offer diagnostic fields for averaging. + ! Offer diagnostic fields for averaging. if (query_averaging_enabled(CS%diag)) then if (CS%id_S2_u > 0) call post_data(CS%id_S2_u, S2_u, CS%diag) if (CS%id_S2_v > 0) call post_data(CS%id_S2_v, S2_v, CS%diag) @@ -667,7 +672,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, real :: sum_dz(SZI_(G)) ! Cumulative sum of z-thicknesses [Z ~> m] real :: vint_SN(SZIB_(G)) ! Cumulative integral of SN [Z T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G)) :: SN_cpy !< SN at u-points [T-1 ~> s-1] - real :: dz_neglect ! An incy wincy distance to avoid division by zero [Z ~> m] + real :: dz_neglect ! A negligibly small distance to avoid division by zero [Z ~> m] real :: r_crp_dist ! The inverse of the distance over which to scale the cropping [Z-1 ~> m-1] real :: dB, dT ! Elevation variables used when cropping [Z ~> m] integer :: i, j, k, l_seg @@ -805,13 +810,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(VarMix_CS), intent(inout) :: CS !< Variable mixing control struct + type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] logical, intent(in) :: calculate_slopes !< If true, calculate slopes !! internally otherwise use slopes stored in CS ! Local variables - real :: E_x(SZIB_(G), SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) - real :: E_y(SZI_(G), SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) + real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) + real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -820,11 +825,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. + real :: S2N2_u_local(SZIB_(G),SZJ_(G),SZK_(GV)) ! The depth integral of the slope times + ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] + real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times + ! the buoyancy frequency squared at v-points [Z T-2 ~> m s-2] integer :: is, ie, js, je, nz integer :: i, j, k integer :: l_seg - real :: S2N2_u_local(SZIB_(G), SZJ_(G),SZK_(GV)) - real :: S2N2_v_local(SZI_(G), SZJB_(G),SZK_(GV)) if (.not. CS%initialized) call MOM_error(FATAL, "calc_slope_functions_using_just_e: "// & "Module must be initialized before it is used.") @@ -970,14 +977,14 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real :: h_at_slope_below ! The thickness below [H ~> m or kg m-2] real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] + real :: inv_PI3 ! The inverse of pi cubed [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz - real :: inv_PI3 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB nz = GV%ke - inv_PI3 = 1.0/((4.0*atan(1.0))**3) + inv_PI3 = 1.0 / ((4.0*atan(1.0))**3) if ((k > 1) .and. (k < nz)) then @@ -1076,7 +1083,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients ! Local variables - real :: KhTr_Slope_Cff, KhTh_Slope_Cff, oneOrTwo + real :: KhTr_Slope_Cff ! The nondimensional coefficient in the Visbeck formula + ! for the epipycnal tracer diffusivity [nondim] + real :: KhTh_Slope_Cff ! The nondimensional coefficient in the Visbeck formula + ! for the interface depth diffusivity [nondim] + real :: oneOrTwo ! A variable that may be 1 or 2, depending on which form + ! of the equatorial deformation radius us used [nondim] real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when ! calculating the first-mode wave speed [Z ~> m] real :: KhTr_passivity_coeff ! Coefficient setting the ratio between along-isopycnal tracer @@ -1187,7 +1199,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! Indicate whether to calculate the Eady growth rate CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) call get_param(param_file, mdl, "KHTR_PASSIVITY_COEFF", KhTr_passivity_coeff, & - default=0., do_not_log=.true.) + units="nondim", default=0., do_not_log=.true.) CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. (KhTr_passivity_coeff>0.) call get_param(param_file, mdl, "MLE_FRONT_LENGTH", MLE_front_length, & units="m", default=0.0, scale=US%m_to_L, do_not_log=.true.) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index af0dded244..46001a2dc3 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -379,13 +379,14 @@ subroutine call_tracer_register_obc_segments(GV, param_file, CS, tr_Reg, OBC) call register_MOM_generic_tracer_segments(CS%MOM_generic_tracer_CSp, GV, OBC, tr_Reg, param_file) end subroutine call_tracer_register_obc_segments + !> This subroutine extracts the chlorophyll concentrations from the model state, if possible subroutine get_chl_from_model(Chl_array, 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. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: Chl_array !< The array in which to store the model's - !! Chlorophyll-A concentrations in mg m-3. + !! Chlorophyll-A concentrations [mg m-3]. type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. @@ -635,21 +636,28 @@ subroutine call_tracer_stocks(h, stock_values, G, GV, US, CS, stock_names, stock logical, dimension(:), & optional, intent(inout) :: got_min_max !< Indicates whether the global min and !! max are found for each tracer - real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer - real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer - real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum - real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum - real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum - real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum - real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum - real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum + real, dimension(:), optional, intent(out) :: global_min !< The global minimum of each tracer [conc] + real, dimension(:), optional, intent(out) :: global_max !< The global maximum of each tracer [conc] + real, dimension(:), optional, intent(out) :: xgmin !< The x-position of the global minimum in the + !! units of G%geoLonT, often [degrees_E] or [km] + real, dimension(:), optional, intent(out) :: ygmin !< The y-position of the global minimum in the + !! units of G%geoLatT, often [degrees_N] or [km] + real, dimension(:), optional, intent(out) :: zgmin !< The z-position of the global minimum [layer] + real, dimension(:), optional, intent(out) :: xgmax !< The x-position of the global maximum in the + !! units of G%geoLonT, often [degrees_E] or [km] + real, dimension(:), optional, intent(out) :: ygmax !< The y-position of the global maximum in the + !! units of G%geoLatT, often [degrees_N] or [km] + real, dimension(:), optional, intent(out) :: zgmax !< The z-position of the global maximum [layer] ! Local variables character(len=200), dimension(MAX_FIELDS_) :: names, units character(len=200) :: set_pkg_name - ! real, dimension(MAX_FIELDS_) :: values - type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP - type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP + ! real, dimension(MAX_FIELDS_) :: values ! Globally integrated tracer amounts in a + ! new list for each tracer package [kg conc] + type(EFP_type), dimension(MAX_FIELDS_) :: values_EFP ! Globally integrated tracer amounts in a + ! new list for each tracer package [kg conc] + type(EFP_type), dimension(MAX_FIELDS_) :: stock_val_EFP ! Globally integrated tracer amounts in a + ! single master list for all tracers [kg conc] integer :: max_ns, ns_tot, ns, index, nn, n if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_stocks: "// & @@ -758,12 +766,12 @@ subroutine store_stocks(pkg_name, ns, names, units, values, index, stock_values, character(len=*), dimension(:), & intent(in) :: units !< Units to use in the metadata for each stock. type(EFP_type), dimension(:), & - intent(in) :: values !< The values of the tracer stocks + intent(in) :: values !< The values of the tracer stocks [conc kg] integer, intent(in) :: index !< The integer stock index from !! stocks_constants_mod of the stock to be returned. If this is !! present and greater than 0, only a single stock can be returned. type(EFP_type), dimension(:), & - intent(inout) :: stock_values !< The master list of stock values + intent(inout) :: stock_values !< The master list of stock values [conc kg] character(len=*), intent(inout) :: set_pkg_name !< The name of the last tracer package whose !! stocks were stored for a specific index. This is !! used to trigger an error if there are redundant stocks. From a80b91dedf974415a73d13c1d8f653b1f6eb8350 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 11:13:50 -0700 Subject: [PATCH 064/629] use more cesm style logging --- config_src/drivers/nuopc_cap/mom_cap.F90 | 130 ++++++++++++----------- 1 file changed, 69 insertions(+), 61 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b01e2019da..f1f2bdced6 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -5,16 +5,14 @@ module MOM_cap_mod use constants_mod, only: constants_init use diag_manager_mod, only: diag_manager_init, diag_manager_end use field_manager_mod, only: field_manager_init, field_manager_end -use fms_mod, only: fms_init, fms_end, open_namelist_file, check_nml_error -use fms_mod, only: close_file, file_exist, uppercase -use fms_io_mod, only: fms_io_exit -use mpp_domains_mod, only: domain2d, mpp_get_compute_domain, mpp_get_compute_domains +use mom_coms_infra, only: MOM_infra_init, MOM_infra_end +use mom_io_infra, only: io_infra_end +use mom_domain_infra, only: get_domain_extent +use MOM_io, only: stdout +use mpp_domains_mod, only: mpp_get_compute_domains use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes -use mpp_io_mod, only: mpp_open, MPP_RDONLY, MPP_ASCII, MPP_OVERWR, MPP_APPEND, mpp_close, MPP_SINGLE -use mpp_mod, only: stdlog, stdout, mpp_root_pe, mpp_clock_id -use mpp_mod, only: mpp_clock_begin, mpp_clock_end, MPP_CLOCK_SYNC -use mpp_mod, only: MPP_CLOCK_DETAILED, CLOCK_COMPONENT, MAXPES + use time_manager_mod, only: set_calendar_type, time_type, increment_date use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR @@ -40,8 +38,7 @@ module MOM_cap_mod use MOM_cap_methods, only: ChkErr #ifdef CESMCOUPLED -use shr_file_mod, only: shr_file_setLogUnit, shr_file_getLogUnit -use shr_mpi_mod, only : shr_mpi_min, shr_mpi_max +use shr_log_mod, only: shr_log_setLogUnit, shr_log_getLogUnit #endif use time_utils_mod, only: esmf2fms_time @@ -80,6 +77,7 @@ module MOM_cap_mod use ESMF, only: ESMF_AlarmGet, ESMF_AlarmIsCreated, ESMF_ALARMLIST_ALL, ESMF_AlarmIsEnabled use ESMF, only: ESMF_STATEITEM_NOTFOUND, ESMF_FieldWrite use ESMF, only: ESMF_END_ABORT, ESMF_Finalize +use ESMF, only: ESMF_REDUCE_MAX, ESMF_REDUCE_MIN, ESMF_VMAllReduce use ESMF, only: operator(==), operator(/=), operator(+), operator(-) ! TODO ESMF_GridCompGetInternalState does not have an explicit Fortran interface. @@ -140,7 +138,6 @@ module MOM_cap_mod logical :: write_diagnostics = .false. logical :: overwrite_timeslice = .false. character(len=32) :: runtype !< run type -integer :: logunit !< stdout logging unit number logical :: profile_memory = .true. logical :: grid_attach_area = .false. logical :: use_coldstart = .true. @@ -489,7 +486,30 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) !$ call omp_set_num_threads(nthrds) - call fms_init(mpi_comm_mom) + ! reset shr logging to my log file + if (localPet==0) then + call NUOPC_CompAttributeGet(gcomp, name="diro", & + isPresent=isPresentDiro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", & + isPresent=isPresentLogfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresentDiro .and. isPresentLogfile) then + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) + else + stdout = output_unit + endif + else + stdout = output_unit + endif + call shr_log_setLogUnit(stdout) + + call MOM_infra_init(mpi_comm_mom) + call constants_init call field_manager_init @@ -526,7 +546,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time_start = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) if (is_root_pe()) then - write(logunit,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second + write(stdout,*) subname//'current time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif ! get start/reference time @@ -538,33 +558,14 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) - if (is_root_pe()) then - write(logunit,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second - endif ! rsd need to figure out how to get this without share code !call shr_nuopc_get_component_instance(gcomp, inst_suffix, inst_index) !inst_name = "OCN"//trim(inst_suffix) - ! reset shr logging to my log file + if (is_root_pe()) then - call NUOPC_CompAttributeGet(gcomp, name="diro", & - isPresent=isPresentDiro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", & - isPresent=isPresentLogfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - open(newunit=logunit,file=trim(diro)//"/"//trim(logfile)) - else - logunit = output_unit - endif - else - logunit = output_unit + write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif starttype = "" @@ -659,7 +660,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call ocean_model_init_sfc(ocean_state, ocean_public) - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) allocate ( Ice_ocean_boundary% u_flux (isc:iec,jsc:jec), & Ice_ocean_boundary% v_flux (isc:iec,jsc:jec), & @@ -823,7 +824,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo - + if(is_root_pe()) write(stdout,*) 'InitializeAdvertise complete' end subroutine InitializeAdvertise !> Called by NUOPC to realize import and export fields. "Realizing" a field @@ -904,6 +905,12 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8) :: max_med2mod_areacor real(ESMF_KIND_R8) :: min_mod2med_areacor real(ESMF_KIND_R8) :: min_med2mod_areacor + + real(ESMF_KIND_R8) :: min_areacor(2) + real(ESMF_KIND_R8) :: max_areacor(2) + real(ESMF_KIND_R8) :: min_areacor_glob(2) + real(ESMF_KIND_R8) :: max_areacor_glob(2) + real(ESMF_KIND_R8) :: max_mod2med_areacor_glob real(ESMF_KIND_R8) :: max_med2mod_areacor_glob real(ESMF_KIND_R8) :: min_mod2med_areacor_glob @@ -913,7 +920,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) rc = ESMF_SUCCESS - call shr_file_setLogUnit (logunit) + call shr_log_setLogUnit (stdout) !---------------------------------------------------------------------------- ! Get pointers to ocean internal state @@ -1032,7 +1039,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (localPet == 0) then - write(logunit,*)'mesh file for mom6 domain is ',trim(cvalue) + write(stdout,*)'mesh file for mom6 domain is ',trim(cvalue) endif ! recreate the mesh using the above distGrid @@ -1060,7 +1067,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_MeshGet(Emesh, elemMaskArray=elemMaskArray, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) n = 0 do j = jsc, jec jg = j + ocean_grid%jsc - jsc @@ -1148,19 +1155,20 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) deallocate(model_areas) ! Write diagnostic output for correction factors - min_mod2med_areacor = minval(mod2med_areacor) - max_mod2med_areacor = maxval(mod2med_areacor) - min_med2mod_areacor = minval(med2mod_areacor) - max_med2mod_areacor = maxval(med2mod_areacor) - call shr_mpi_max(max_mod2med_areacor, max_mod2med_areacor_glob, mpicom) - call shr_mpi_min(min_mod2med_areacor, min_mod2med_areacor_glob, mpicom) - call shr_mpi_max(max_med2mod_areacor, max_med2mod_areacor_glob, mpicom) - call shr_mpi_min(min_med2mod_areacor, min_med2mod_areacor_glob, mpicom) + min_areacor(1) = minval(mod2med_areacor) + max_areacor(1) = maxval(mod2med_areacor) + min_areacor(2) = minval(med2mod_areacor) + max_areacor(2) = maxval(med2mod_areacor) + call ESMF_VMAllReduce(vm, min_areacor, min_areacor_glob, 2, ESMF_REDUCE_MIN, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMAllReduce(vm, max_areacor, max_areacor_glob, 2, ESMF_REDUCE_MAX, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) then - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& - min_mod2med_areacor_glob, max_mod2med_areacor_glob, 'MOM6' - write(logunit,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& - min_med2mod_areacor_glob, max_med2mod_areacor_glob, 'MOM6' + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_mod2med_areacor, max_mod2med_areacor ',& + min_areacor_glob(1), max_areacor_glob(1), 'MOM6' + write(stdout,'(2A,2g23.15,A )') trim(subname),' : min_med2mod_areacor, max_med2mod_areacor ',& + min_areacor_glob(2), max_areacor_glob(2), 'MOM6' end if #endif @@ -1311,7 +1319,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! values for j=0 and wrap-around in i. on tripole seam, decomposition ! domains are 1 larger in j; to load corner values need to loop one extra row - call mpp_get_compute_domain(ocean_public%domain, isc, iec, jsc, jec) + call get_domain_extent(ocean_public%domain, isc, iec, jsc, jec) lbnd1 = lbound(dataPtr_mask,1) ubnd1 = ubound(dataPtr_mask,1) @@ -1568,7 +1576,7 @@ subroutine ModelAdvance(gcomp, rc) rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") - call shr_file_setLogUnit (logunit) + call shr_log_setLogUnit (stdout) !$ call omp_set_num_threads(nthrds) @@ -1782,7 +1790,7 @@ subroutine ModelAdvance(gcomp, rc) endif if (is_root_pe()) then - write(logunit,*) subname//' writing restart file ',trim(restartname) + write(stdout,*) subname//' writing restart file ',trim(restartname) endif endif endif ! restart_mode @@ -2039,8 +2047,8 @@ subroutine ocean_model_finalize(gcomp, rc) call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) call field_manager_end() - call fms_io_exit() - call fms_end() + call io_infra_end() + call MOM_infra_end() write(*,*) 'MOM: --- completed ---' @@ -2253,17 +2261,17 @@ end subroutine fld_list_add #ifndef CESMCOUPLED -subroutine shr_file_setLogUnit(nunit) +subroutine shr_log_setLogUnit(nunit) integer, intent(in) :: nunit ! do nothing for this stub - its just here to replace ! having cppdefs in the main program -end subroutine shr_file_setLogUnit +end subroutine shr_log_setLogUnit -subroutine shr_file_getLogUnit(nunit) +subroutine shr_log_getLogUnit(nunit) integer, intent(in) :: nunit ! do nothing for this stub - its just here to replace ! having cppdefs in the main program -end subroutine shr_file_getLogUnit +end subroutine shr_log_getLogUnit #endif !> @@ -2761,7 +2769,7 @@ end subroutine shr_file_getLogUnit !! with incoming coupling fields from other components. These three derived types are allocated during the !! [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase. Also during that !! phase, the `ice_ocean_boundary` type members are all allocated using bounds retrieved -!! from `mpp_get_compute_domain()`. +!! from `get_domain_extent()`. !! !! During the [InitializeRealize] (@ref MOM_cap_mod::initializerealize) phase, !! `ESMF_Field`s are created for each of the coupling fields in the `ice_ocean_boundary` From c9334608c1f3a557e0ace7b8f710dd32f2bbdac2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 29 Nov 2022 02:24:14 -0500 Subject: [PATCH 065/629] +Add 10 units arguments to get_param calls Add units arguments to 10 get_param calls in 7 files. Also changed comments describing the various units that might be used for geoLat or geoLon variables in the ocean_grid_type to use standard syntax. The added units arguments lead to some minor differences in MOM_parameter_doc files, but all answers are bitwise identical. --- .../mct_cap/mom_surface_forcing_mct.F90 | 2 +- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 2 +- src/ALE/MOM_hybgen_regrid.F90 | 4 +- src/core/MOM_grid.F90 | 43 ++++++++++--------- src/framework/MOM_diag_mediator.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 36 ++++++++-------- src/ocean_data_assim/MOM_oda_driver.F90 | 2 +- 7 files changed, 46 insertions(+), 45 deletions(-) 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 259aa8a678..78f7bad268 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -1119,7 +1119,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) if (restore_salt) then call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & 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 8691f564dd..738866c8ef 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -1209,7 +1209,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call get_param(param_file, mdl, "WIND_STRESS_MULTIPLIER", CS%wind_stress_multiplier, & "A factor multiplying the wind-stress given to the ocean by the "//& "coupler. This is used for testing and should be =1.0 for any "//& - "production runs.", default=1.0) + "production runs.", units="nondim", default=1.0) call get_param(param_file, mdl, "USE_CFC_CAP", CS%use_CFC, & default=.false., do_not_log=.true.) diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index cc961b88f2..271caa7ad6 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -172,11 +172,11 @@ subroutine init_hybgen_regrid(CS, GV, US, param_file) call get_param(param_file, mdl, "HYBGEN_REMAP_MIN_ZSTAR_DILATE", CS%min_dilate, & "The maximum amount of dilation that is permitted when converting target "//& "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & - default=0.5) + units="nondim", default=0.5) call get_param(param_file, mdl, "HYBGEN_REMAP_MAX_ZSTAR_DILATE", CS%max_dilate, & "The maximum amount of dilation that is permitted when converting target "//& "coordinates from z to z* [nondim]. This limit applies when drying occurs.", & - default=2.0) + units="nondim", default=2.0) CS%onem = 1.0 * GV%m_to_H diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index f3a48f3ded..d2a0c86da8 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -75,8 +75,8 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & mask2dT, & !< 0 for land points and 1 for ocean points on the h-grid [nondim]. - geoLatT, & !< The geographic latitude at q points in degrees of latitude or m. - geoLonT, & !< The geographic longitude at q points in degrees of longitude or m. + geoLatT, & !< The geographic latitude at q points [degrees_N] or [km] or [m]. + geoLonT, & !< The geographic longitude at q points [degrees_E] or [km] or [m]. dxT, & !< dxT is delta x at h points [L ~> m]. IdxT, & !< 1/dxT [L-1 ~> m-1]. dyT, & !< dyT is delta y at h points [L ~> m]. @@ -84,15 +84,15 @@ module MOM_grid areaT, & !< The area of an h-cell [L2 ~> m2]. IareaT, & !< 1/areaT [L-2 ~> m-2]. sin_rot, & !< The sine of the angular rotation between the local model grid's northward - !! and the true northward directions. + !! and the true northward directions [nondim]. cos_rot !< The cosine of the angular rotation between the local model grid's northward - !! and the true northward directions. + !! and the true northward directions [nondim]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & mask2dCu, & !< 0 for boundary points and 1 for ocean points on the u grid [nondim]. OBCmaskCu, & !< 0 for boundary or OBC points and 1 for ocean points on the u grid [nondim]. - geoLatCu, & !< The geographic latitude at u points in degrees of latitude or m. - geoLonCu, & !< The geographic longitude at u points in degrees of longitude or m. + geoLatCu, & !< The geographic latitude at u points [degrees_N] or [km] or [m] + geoLonCu, & !< The geographic longitude at u points [degrees_E] or [km] or [m]. dxCu, & !< dxCu is delta x at u points [L ~> m]. IdxCu, & !< 1/dxCu [L-1 ~> m-1]. dyCu, & !< dyCu is delta y at u points [L ~> m]. @@ -104,8 +104,8 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: & mask2dCv, & !< 0 for boundary points and 1 for ocean points on the v grid [nondim]. OBCmaskCv, & !< 0 for boundary or OBC points and 1 for ocean points on the v grid [nondim]. - geoLatCv, & !< The geographic latitude at v points in degrees of latitude or m. - geoLonCv, & !< The geographic longitude at v points in degrees of longitude or m. + geoLatCv, & !< The geographic latitude at v points [degrees_N] or [km] or [m] + geoLonCv, & !< The geographic longitude at v points [degrees_E] or [km] or [m]. dxCv, & !< dxCv is delta x at v points [L ~> m]. IdxCv, & !< 1/dxCv [L-1 ~> m-1]. dyCv, & !< dyCv is delta y at v points [L ~> m]. @@ -126,8 +126,8 @@ module MOM_grid real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & mask2dBu, & !< 0 for boundary points and 1 for ocean points on the q grid [nondim]. - geoLatBu, & !< The geographic latitude at q points in degrees of latitude or m. - geoLonBu, & !< The geographic longitude at q points in degrees of longitude or m. + geoLatBu, & !< The geographic latitude at q points [degrees_N] or [km] or [m] + geoLonBu, & !< The geographic longitude at q points [degrees_E] or [km] or [m]. dxBu, & !< dxBu is delta x at q points [L ~> m]. IdxBu, & !< 1/dxBu [L-1 ~> m-1]. dyBu, & !< dyBu is delta y at q points [L ~> m]. @@ -181,8 +181,8 @@ module MOM_grid ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) - real :: south_lat !< The latitude (or y-coordinate) of the first v-line - real :: west_lon !< The longitude (or x-coordinate) of the first u-line + real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] + real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] real :: len_lat !< The latitudinal (or y-coord) extent of physical domain real :: len_lon !< The longitudinal (or x-coord) extent of physical domain real :: Rad_Earth !< The radius of the planet [m] @@ -221,9 +221,11 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v integer, allocatable, dimension(:) :: ibegin, iend, jbegin, jend character(len=40) :: mod_nm = "MOM_grid" ! This module's name. + mean_SeaLev_scale = 1.0 ; if (associated(G%US)) mean_SeaLev_scale = G%US%m_to_Z ! Read all relevant parameters and write them to the model log. - call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, default=0.0, do_not_log=.true.) + call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & + units="m", default=0.0, scale=mean_SeaLev_scale, do_not_log=.true.) call log_version(param_file, mod_nm, version, & "Parameters providing information about the lateral grid.", & log_to_all=.true., layout=.true., all_default=(G%Z_ref==0.0)) @@ -236,7 +238,6 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v layoutParam=.true.) if (present(US)) then ; if (associated(US)) G%US => US ; endif - mean_SeaLev_scale = 1.0 ; if (associated(G%US)) mean_SeaLev_scale = G%US%m_to_Z call get_param(param_file, mod_nm, "REFERENCE_HEIGHT", G%Z_ref, & "A reference value for geometric height fields, such as bathyT.", & units="m", default=0.0, scale=mean_SeaLev_scale) @@ -477,8 +478,8 @@ end subroutine set_derived_metrics !> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0. function Adcroft_reciprocal(val) result(I_val) - real, intent(in) :: val !< The value being inverted. - real :: I_val !< The Adcroft reciprocal of val. + real, intent(in) :: val !< The value being inverted [A]. + real :: I_val !< The Adcroft reciprocal of val [A-1]. I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val end function Adcroft_reciprocal @@ -488,12 +489,12 @@ logical function isPointInCell(G, i, j, x, y) type(ocean_grid_type), intent(in) :: G !< Grid type integer, intent(in) :: i !< i index of cell to test integer, intent(in) :: j !< j index of cell to test - real, intent(in) :: x !< x coordinate of point - real, intent(in) :: y !< y coordinate of point + real, intent(in) :: x !< x coordinate of point [degrees_E] + real, intent(in) :: y !< y coordinate of point [degrees_N] ! Local variables - real :: xNE, xNW, xSE, xSW ! Longitudes of cell corners [degLon] - real :: yNE, yNW, ySE, ySW ! Latitudes of cell corners [degLat] - real :: l0, l1, l2, l3 ! Crossed products of differences in position [degLon degLat] + real :: xNE, xNW, xSE, xSW ! Longitudes of cell corners [degrees_E] + real :: yNE, yNW, ySE, ySW ! Latitudes of cell corners [degrees_N] + real :: l0, l1, l2, l3 ! Crossed products of differences in position [degrees_E degrees_N] real :: p0, p1, p2, p3 ! Trinary unitary values reflecting the signs of the crossed products [nondim] isPointInCell = .false. xNE = G%geoLonBu(i ,j ) ; yNE = G%geoLatBu(i ,j ) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index fbfd4e3976..092b12a2d2 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3228,7 +3228,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, 'DIAG_MISVAL', diag_cs%missing_value, & 'Set the default missing value to use for diagnostics.', & - default=1.e20) + units="various", default=1.e20) call get_param(param_file, mdl, 'DIAG_AS_CHKSUM', diag_cs%diag_as_chksum, & 'Instead of writing diagnostics to the diag manager, write '//& 'a text file containing the checksum (bitcount) of the array.', & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index e605f3e581..2ed64359cb 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -80,7 +80,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), !! in [R L2 T-1 ~> kg m-1 s-1]. real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, - !! often in [kg-1/3 m-1/3 s-1]. + !! often in [Pa-3 s-1] if n_Glen is 3. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] @@ -149,9 +149,9 @@ module MOM_ice_shelf_dynamics real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that - !! determines when to stop the conjugate gradient iterations. + !! determines when to stop the conjugate gradient iterations [nondim]. real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, - !! that sets when to stop the iterative velocity solver + !! that sets when to stop the iterative velocity solver [nondim] integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm @@ -265,7 +265,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate( CS%t_shelf(isd:ied,jsd:jed), source=-10.0*US%degC_to_C ) ! [C ~> degC] allocate( CS%ice_visc(isd:ied,jsd:jed), source=0.0 ) allocate( CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25 ) ! [Pa-3 s-1] - allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) ! [Pa] + allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) ! [R L2 T-2 ~> Pa] allocate( CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10 ) ! [Pa (m-1 s)^n_sliding] allocate( CS%OD_av(isd:ied,jsd:jed), source=0.0 ) allocate( CS%ground_frac(isd:ied,jsd:jed), source=0.0 ) @@ -389,7 +389,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & "A factor used to limit timestep as CFL_FACTOR * min (\Delta x / u). "//& - "This is only used with an ice-only model.", default=0.25) + "This is only used with an ice-only model.", units="nondim", default=0.25) endif call get_param(param_file, mdl, "RHO_0", CS%density_ocean_avg, & "avg ocean density used in floatation cond", & @@ -414,9 +414,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & - "tolerance in CG solver, relative to initial residual", default=1.e-6) + "tolerance in CG solver, relative to initial residual", units="nondim", default=1.e-6) call get_param(param_file, mdl, "ICE_NONLINEAR_TOLERANCE", CS%nonlinear_tolerance, & - "nonlin tolerance in iterative velocity solve",default=1.e-6) + "nonlin tolerance in iterative velocity solve", units="nondim", default=1.e-6) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_MAXIT", CS%cg_max_iterations, & "max iteratiions in CG solver", default=2000) call get_param(param_file, mdl, "THRESH_FLOAT_COL_DEPTH", CS%thresh_float_col_depth, & @@ -1298,7 +1298,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! R,u,v,Z valid region moves in by 1 - ! beta_k = (Z \dot R) / (Zold \dot Rold} + ! beta_k = (Z \dot R) / (Zold \dot Rold) sum_vec(:,:) = 0.0 ; sum_vec_2(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq @@ -2639,17 +2639,17 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) enddo ; enddo - if (trim(CS%ice_viscosity_compute)=="CONSTANT") then - CS%ice_visc(i,j) =1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) - ! constant viscocity for debugging - elseif (trim(CS%ice_viscosity_compute)=="MODEL") then - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + if (trim(CS%ice_viscosity_compute)=="CONSTANT") then + CS%ice_visc(i,j) = 1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) + ! constant viscocity for debugging + elseif (trim(CS%ice_viscosity_compute)=="MODEL") then + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) - elseif(trim(CS%ice_viscosity_compute)=="OBS") then - if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) =CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) - ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file - endif - endif + elseif (trim(CS%ice_viscosity_compute)=="OBS") then + if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) = CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) + ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file + endif + endif enddo ; enddo deallocate(Phi) end subroutine calc_shelf_visc diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index c48324962b..2a1a96168a 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -219,7 +219,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) if (CS%do_bias_adjustment) then call get_param(PF, mdl, "TRACER_ADJUSTMENT_FACTOR", CS%bias_adjustment_multiplier, & "A multiplicative scaling factor for the climatological tracer tendency adjustment ", & - default=1.0) + units="nondim", default=1.0) endif call get_param(PF, mdl, "USE_BASIN_MASK", CS%use_basin_mask, & "If true, add a basin mask to delineate weakly connected "//& From 7824dcec75baec29402f57714c4ae41550ae385a Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 12:19:04 -0700 Subject: [PATCH 066/629] switch to openmpi for github tests --- .github/actions/ubuntu-setup/action.yml | 4 ++-- config_src/drivers/nuopc_cap/mom_cap.F90 | 10 ---------- 2 files changed, 2 insertions(+), 12 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3fd2ea13cf..3f3ba5f0b6 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install mpich - sudo apt-get install libmpich-dev + sudo apt-get install openmpi-bin + sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index f1f2bdced6..7b5bc38cae 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -901,20 +901,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8), allocatable :: mesh_areas(:) real(ESMF_KIND_R8), allocatable :: model_areas(:) real(ESMF_KIND_R8), pointer :: dataPtr_mesh_areas(:) - real(ESMF_KIND_R8) :: max_mod2med_areacor - real(ESMF_KIND_R8) :: max_med2mod_areacor - real(ESMF_KIND_R8) :: min_mod2med_areacor - real(ESMF_KIND_R8) :: min_med2mod_areacor - real(ESMF_KIND_R8) :: min_areacor(2) real(ESMF_KIND_R8) :: max_areacor(2) real(ESMF_KIND_R8) :: min_areacor_glob(2) real(ESMF_KIND_R8) :: max_areacor_glob(2) - - real(ESMF_KIND_R8) :: max_mod2med_areacor_glob - real(ESMF_KIND_R8) :: max_med2mod_areacor_glob - real(ESMF_KIND_R8) :: min_mod2med_areacor_glob - real(ESMF_KIND_R8) :: min_med2mod_areacor_glob character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' !-------------------------------- From 12238ae219238275ebc75cf6aa7249ba26657dfb Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 12:39:20 -0700 Subject: [PATCH 067/629] remove whitespace --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 7b5bc38cae..4684b0e6ff 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -507,7 +507,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) stdout = output_unit endif call shr_log_setLogUnit(stdout) - + call MOM_infra_init(mpi_comm_mom) call constants_init From cac67d1e79a7a708881f6101a827cbadf71579e1 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Mon, 12 Dec 2022 12:53:36 -0700 Subject: [PATCH 068/629] revert change to github action --- .github/actions/ubuntu-setup/action.yml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3f3ba5f0b6..3fd2ea13cf 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -13,7 +13,7 @@ runs: sudo apt-get install netcdf-bin sudo apt-get install libnetcdf-dev sudo apt-get install libnetcdff-dev - sudo apt-get install openmpi-bin - sudo apt-get install libopenmpi-dev + sudo apt-get install mpich + sudo apt-get install libmpich-dev sudo apt-get install linux-tools-common echo "::endgroup::" From 0111d4549ec8a66a74c6070f6e223fb9dd2dab2b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 30 Nov 2022 05:24:50 -0500 Subject: [PATCH 069/629] +Add x_ax_unit_short to ocean_grid_type Added the new elements x_ax_unit_short and y_ax_unit_short to the ocean_grid_type and the dyn_horgrid_type to facilitate the documentation of the units of variables when they depend on the units of the axes. This includes modifying some units that were being reported as the meaningless "[k]" into the meaningful "[km]", and some units that were being reported as just "[degrees]" are now being reported with the more specific "[degrees_E]" or "[degrees_N]". These new elements are also being used in the baroclinic_zone_initialization and circle_OBCs modules, and comments describing the units of a number of the internal variables in the former module were added or modified. The description of the AXIS_UNITS parameter was expanded to provide some of the other working options. All answers are bitwise identical, but there are minor changes in a number of the MOM_parameter_doc files. --- src/core/MOM_grid.F90 | 6 +- src/core/MOM_transcribe_grid.F90 | 2 + src/framework/MOM_dyn_horgrid.F90 | 9 ++- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 39 ++++++------ src/initialization/MOM_grid_initialize.F90 | 39 +++++++----- src/user/baroclinic_zone_initialization.F90 | 59 +++++++++++-------- src/user/circle_obcs_initialization.F90 | 4 +- 7 files changed, 95 insertions(+), 63 deletions(-) diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index d2a0c86da8..2e413e505b 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -146,8 +146,12 @@ module MOM_grid gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes. !! On many grids this is the same as geoLonBu. character(len=40) :: & + ! Except on a Cartesian grid, these are usually some variant of "degrees". x_axis_units, & !< The units that are used in labeling the x coordinate axes. - y_axis_units !< The units that are used in labeling the y coordinate axes. + y_axis_units, & !< The units that are used in labeling the y coordinate axes. + ! These are internally generated names, including "m", "km", "deg_E" and "deg_N". + x_ax_unit_short, & !< A short description of the x-axis units for documenting parameter units + y_ax_unit_short !< A short description of the y-axis units for documenting parameter units real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. diff --git a/src/core/MOM_transcribe_grid.F90 b/src/core/MOM_transcribe_grid.F90 index 8f8da21ef3..b8e213fa62 100644 --- a/src/core/MOM_transcribe_grid.F90 +++ b/src/core/MOM_transcribe_grid.F90 @@ -133,6 +133,7 @@ subroutine copy_dyngrid_to_MOM_grid(dG, oG, US) ! Copy various scalar variables and strings. oG%x_axis_units = dG%x_axis_units ; oG%y_axis_units = dG%y_axis_units + oG%x_ax_unit_short = dG%x_ax_unit_short ; oG%y_ax_unit_short = dG%y_ax_unit_short oG%areaT_global = dG%areaT_global ; oG%IareaT_global = dG%IareaT_global oG%south_lat = dG%south_lat ; oG%west_lon = dG%west_lon oG%len_lat = dG%len_lat ; oG%len_lon = dG%len_lon @@ -291,6 +292,7 @@ subroutine copy_MOM_grid_to_dyngrid(oG, dG, US) ! Copy various scalar variables and strings. dG%x_axis_units = oG%x_axis_units ; dG%y_axis_units = oG%y_axis_units + dG%x_ax_unit_short = oG%x_ax_unit_short ; dG%y_ax_unit_short = oG%y_ax_unit_short dG%areaT_global = oG%areaT_global ; dG%IareaT_global = oG%IareaT_global dG%south_lat = oG%south_lat ; dG%west_lon = oG%west_lon dG%len_lat = oG%len_lat ; dG%len_lon = oG%len_lon diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 60c30d8e94..8c163f710f 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -145,9 +145,12 @@ module MOM_dyn_horgrid !< The longitude of B points for the purpose of labeling the output axes. !! On many grids this is the same as geoLonBu. character(len=40) :: & + ! Except on a Cartesian grid, these are usually some variant of "degrees". x_axis_units, & !< The units that are used in labeling the x coordinate axes. - y_axis_units !< The units that are used in labeling the y coordinate axes. - ! Except on a Cartesian grid, these are usually some variant of "degrees". + y_axis_units, & !< The units that are used in labeling the y coordinate axes. + ! These are internally generated names, including "m", "km", "deg_E" and "deg_N". + x_ax_unit_short, & !< A short description of the x-axis units for documenting parameter units + y_ax_unit_short !< A short description of the y-axis units for documenting parameter units real, allocatable, dimension(:,:) :: & bathyT !< Ocean bottom depth at tracer points, in depth units [Z ~> m]. @@ -382,6 +385,8 @@ subroutine rotate_dyn_horgrid(G_in, G, US, turns) G%x_axis_units = G_in%y_axis_units G%y_axis_units = G_in%x_axis_units + G%x_ax_unit_short = G_in%y_ax_unit_short + G%y_ax_unit_short = G_in%x_ax_unit_short G%south_lat = G_in%south_lat G%west_lon = G_in%west_lon G%len_lat = G_in%len_lat diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index 479b1dfd1e..dabb075cf3 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -42,8 +42,9 @@ module MOM_IS_diag_mediator integer :: fms_diag_id !< underlying FMS diag id character(len=24) :: name !< The diagnostic name real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. - real, pointer, dimension(:,:) :: mask2d => null() !< A 2-d mask on the data domain for this diagnostic - real, pointer, dimension(:,:) :: mask2d_comp => null() !< A 2-d mask on the computational domain for this diagnostic + real, pointer, dimension(:,:) :: mask2d => null() !< A 2-d mask on the data domain for this diagnostic [nondim] + real, pointer, dimension(:,:) :: mask2d_comp => null() !< A 2-d mask on the computational domain + !! for this diagnostic [nondim] end type diag_type !> The SIS_diag_ctrl data type contains times to regulate diagnostics along with masks and @@ -64,7 +65,7 @@ module MOM_IS_diag_mediator integer :: ied !< The end i-index of cell centers within the data domain integer :: jsd !< The start j-index of cell centers within the data domain integer :: jed !< The end j-index of cell centers within the data domain - real :: time_int !< The time interval in s for any fields that are offered for averaging. + real :: time_int !< The time interval for any fields that are offered for averaging [s]. type(time_type) :: time_end !< The end time of the valid interval for any offered field. logical :: ave_enabled = .false. !< .true. if averaging is enabled. @@ -89,7 +90,7 @@ module MOM_IS_diag_mediator #define DIAG_ALLOC_CHUNK_SIZE 15 type(diag_type), dimension(:), allocatable :: diags !< The array of diagnostics integer :: next_free_diag_id !< The next unused diagnostic ID - !> default missing value to be sent to ALL diagnostics registerations + !> default missing value to be sent to ALL diagnostics registerations [various] real :: missing_value = -1.0e34 type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type @@ -101,8 +102,8 @@ module MOM_IS_diag_mediator !> Set up the grid and axis information for use by the ice shelf model. subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output character(len=*), optional, intent(in) :: axes_set_name !< A name to use for this set of axes. !! The default is "ice". ! This subroutine sets up the grid and axis information for use by the ice shelf model. @@ -111,8 +112,8 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) integer :: id_xq, id_yq, id_xh, id_yh logical :: Cartesian_grid character(len=80) :: grid_config, units_temp, set_name -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_IS_diag_mediator" ! This module's name. set_name = "ice_shelf" ; if (present(axes_set_name)) set_name = trim(axes_set_name) @@ -128,8 +129,9 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) "\t spherical - a spherical grid \n"//& "\t mercator - a Mercator grid", fail_if_missing=.true.) - G%x_axis_units = "degrees_E" - G%y_axis_units = "degrees_N" + G%x_axis_units = "degrees_E" ; G%y_axis_units = "degrees_N" + G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N" + if (index(lowercase(trim(grid_config)),"cartesian") > 0) then ! This is a cartesian grid, and may have different axis units. Cartesian_grid = .true. @@ -141,8 +143,10 @@ subroutine set_IS_axes_info(G, param_file, diag_cs, axes_set_name) "implemented.", default='degrees') if (units_temp(1:1) == 'k') then G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers" + G%x_ax_unit_short = "km" ; G%y_ax_unit_short = "km" elseif (units_temp(1:1) == 'm') then G%x_axis_units = "meters" ; G%y_axis_units = "meters" + G%x_ax_unit_short = "m" ; G%y_ax_unit_short = "m" endif call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) else @@ -343,12 +347,11 @@ end subroutine post_IS_data !> Enable the accumulation of time averages over the specified time interval. subroutine enable_averaging(time_int_in, time_end_in, diag_cs) - real, intent(in) :: time_int_in !< The time interval over which any values -! !! that are offered are valid [s]. - type(time_type), intent(in) :: time_end_in !< The end time of the valid interval. - type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output -! This subroutine enables the accumulation of time averages over the -! specified time interval. + real, intent(in) :: time_int_in !< The time interval over which any values + !! that are offered are valid [s]. + type(time_type), intent(in) :: time_end_in !< The end time of the valid interval. + type(diag_ctrl), intent(inout) :: diag_cs !< A structure that is used to regulate diagnostic output + ! This subroutine enables the accumulation of time averages over the specified time interval. ! if (num_file==0) return diag_cs%time_int = time_int_in @@ -371,8 +374,8 @@ subroutine enable_averages(time_int, time_end, diag_CS, T_to_s) !! that are offered are valid [T ~> s]. type(time_type), intent(in) :: time_end !< The end time of the valid interval. type(diag_ctrl), intent(inout) :: diag_CS !< A structure that is used to regulate diagnostic output - real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to [s]. -! This subroutine enables the accumulation of time averages over the specified time interval. + real, optional, intent(in) :: T_to_s !< A conversion factor for time_int to seconds [s T-1 ~> 1]. + ! This subroutine enables the accumulation of time averages over the specified time interval. if (present(T_to_s)) then diag_cs%time_int = time_int*T_to_s diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index d84d2275e4..964007c663 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -27,17 +27,17 @@ module MOM_grid_initialize !> Global positioning system (aka container for information to describe the grid) type, private :: GPS ; private - real :: len_lon !< The longitudinal or x-direction length of the domain. - real :: len_lat !< The latitudinal or y-direction length of the domain. + real :: len_lon !< The longitudinal or x-direction length of the domain [degrees_E] or [km] or [m]. + real :: len_lat !< The latitudinal or y-direction length of the domain [degrees_N] or [km] or [m]. real :: west_lon !< The western longitude of the domain or the equivalent - !! starting value for the x-axis. + !! starting value for the x-axis [degrees_E] or [km] or [m]. real :: south_lat !< The southern latitude of the domain or the equivalent - !! starting value for the y-axis. + !! starting value for the y-axis [degrees_N] or [km] or [m]. real :: Rad_Earth_L !< The radius of the Earth in rescaled units [L ~> m] real :: Lat_enhance_factor !< The amount by which the meridional resolution - !! is enhanced within LAT_EQ_ENHANCE of the equator. + !! is enhanced within LAT_EQ_ENHANCE of the equator [nondim] real :: Lat_eq_enhance !< The latitude range to the north and south of the equator - !! over which the resolution is enhanced, in degrees. + !! over which the resolution is enhanced [degrees_N] logical :: isotropic !< If true, an isotropic grid on a sphere (also known as a Mercator grid) !! is used. With an isotropic grid, the meridional extent of the domain !! (LENLAT), the zonal extent (LENLON), and the number of grid points in each @@ -83,6 +83,8 @@ subroutine set_grid_metrics(G, param_file, US) ! These are defaults that may be changed in the next select block. G%x_axis_units = "degrees_east" ; G%y_axis_units = "degrees_north" + G%x_ax_unit_short = "degrees_E" ; G%y_ax_unit_short = "degrees_N" + G%Rad_Earth_L = -1.0*US%m_to_L ; G%len_lat = 0.0 ; G%len_lon = 0.0 select case (trim(config)) case ("mosaic"); call set_grid_metrics_from_mosaic(G, param_file, US) @@ -379,7 +381,10 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) call get_param(param_file, mdl, "AXIS_UNITS", units_temp, & "The units for the Cartesian axes. Valid entries are: \n"//& " \t degrees - degrees of latitude and longitude \n"//& - " \t m - meters \n \t k - kilometers", default="degrees") + " \t m or meter(s) - meters \n"//& + " \t k or km or kilometer(s) - kilometers", default="degrees") + if (trim(units_temp) == "k") units_temp = "km" + call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & "The southern latitude of the domain or the equivalent "//& "starting value for the y-axis.", units=units_temp, & @@ -399,8 +404,10 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) if (units_temp(1:1) == 'k') then G%x_axis_units = "kilometers" ; G%y_axis_units = "kilometers" + G%x_ax_unit_short = "km" ; G%y_ax_unit_short = "km" elseif (units_temp(1:1) == 'm') then G%x_axis_units = "meters" ; G%y_axis_units = "meters" + G%x_ax_unit_short = "m" ; G%y_ax_unit_short = "m" endif call log_param(param_file, mdl, "explicit AXIS_UNITS", G%x_axis_units) @@ -513,16 +520,16 @@ subroutine set_grid_metrics_spherical(G, param_file, US) PI = 4.0*atan(1.0); PI_180 = atan(1.0)/45. call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & - "The southern latitude of the domain.", units="degrees", & + "The southern latitude of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "LENLAT", G%len_lat, & - "The latitudinal length of the domain.", units="degrees", & + "The latitudinal length of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "WESTLON", G%west_lon, & - "The western longitude of the domain.", units="degrees", & + "The western longitude of the domain.", units="degrees_E", & default=0.0) call get_param(param_file, mdl, "LENLON", G%len_lon, & - "The longitudinal length of the domain.", units="degrees", & + "The longitudinal length of the domain.", units="degrees_E", & fail_if_missing=.true.) call get_param(param_file, mdl, "RAD_EARTH", G%Rad_Earth_L, & "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) @@ -668,16 +675,16 @@ subroutine set_grid_metrics_mercator(G, param_file, US) PI = 4.0*atan(1.0) ; PI_2 = 0.5*PI call get_param(param_file, mdl, "SOUTHLAT", GP%south_lat, & - "The southern latitude of the domain.", units="degrees", & + "The southern latitude of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "LENLAT", GP%len_lat, & - "The latitudinal length of the domain.", units="degrees", & + "The latitudinal length of the domain.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "WESTLON", GP%west_lon, & - "The western longitude of the domain.", units="degrees", & + "The western longitude of the domain.", units="degrees_E", & default=0.0) call get_param(param_file, mdl, "LENLON", GP%len_lon, & - "The longitudinal length of the domain.", units="degrees", & + "The longitudinal length of the domain.", units="degrees_E", & fail_if_missing=.true.) call get_param(param_file, mdl, "RAD_EARTH", GP%Rad_Earth_L, & "The radius of the Earth.", units="m", default=6.378e6, scale=US%m_to_L) @@ -704,7 +711,7 @@ subroutine set_grid_metrics_mercator(G, param_file, US) units="nondim", default=1.0) call get_param(param_file, mdl, "LAT_EQ_ENHANCE", GP%Lat_eq_enhance, & "The latitude range to the north and south of the equator "//& - "over which the resolution is enhanced.", units="degrees", & + "over which the resolution is enhanced.", units="degrees_N", & default=0.0) ! With an isotropic grid, the north-south extent of the domain, diff --git a/src/user/baroclinic_zone_initialization.F90 b/src/user/baroclinic_zone_initialization.F90 index eb1f943b87..2ff4e1ec80 100644 --- a/src/user/baroclinic_zone_initialization.F90 +++ b/src/user/baroclinic_zone_initialization.F90 @@ -36,14 +36,17 @@ subroutine bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, real, intent(out) :: S_ref !< Reference salinity [S ~> ppt] real, intent(out) :: dSdz !< Salinity stratification [S Z-1 ~> ppt m-1] real, intent(out) :: delta_S !< Salinity difference across baroclinic zone [S ~> ppt] - real, intent(out) :: dSdx !< Linear salinity gradient - !! in [S G%xaxis_units-1 ~> ppt G%xaxis_units-1] + real, intent(out) :: dSdx !< Linear salinity gradient, often in [S km-1 ~> ppt km-1] + !! or [S degrees_E-1 ~> ppt degrees_E-1], depending on + !! the value of G%x_axis_units real, intent(out) :: T_ref !< Reference temperature [C ~> degC] real, intent(out) :: dTdz !< Temperature stratification [C Z-1 ~> degC m-1] real, intent(out) :: delta_T !< Temperature difference across baroclinic zone [C ~> degC] - real, intent(out) :: dTdx !< Linear temperature gradient - !! in [C G%x_axis_units-1 ~> degC G%x_axis_units-1] - real, intent(out) :: L_zone !< Width of baroclinic zone in [G%x_axis_units] + real, intent(out) :: dTdx !< Linear temperature gradient, often in [C km-1 ~> degC km-1] + !! or [C degrees_E-1 ~> degC degrees_E-1], depending on + !! the value of G%x_axis_units + real, intent(out) :: L_zone !< Width of baroclinic zone, often in [km] or [degrees_N], + !! depending on the value of G%y_axis_units logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing h. @@ -53,21 +56,21 @@ subroutine bcz_params(G, GV, US, param_file, S_ref, dSdz, delta_S, dSdx, T_ref, call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & units='ppt', default=35., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "DSDZ", dSdz, 'Salinity stratification', & - units='ppt/m', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) - call get_param(param_file, mdl,"DELTA_S",delta_S,'Salinity difference across baroclinic zone', & + units='ppt m-1', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_S",delta_S, 'Salinity difference across baroclinic zone', & units='ppt', default=0.0, scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"DSDX",dSdx,'Meridional salinity difference', & - units='ppt/'//trim(G%x_axis_units), default=0.0, scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', & - units='C', default=10., scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DSDX", dSdx,'Meridional salinity difference', & + units='ppt '//trim(G%x_ax_unit_short)//'-1', default=0.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='degC', default=10., scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "DTDZ", dTdz, 'Temperature stratification', & - units='C/m', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) - call get_param(param_file, mdl,"DELTA_T",delta_T,'Temperature difference across baroclinic zone', & - units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) - call get_param(param_file, mdl,"DTDX",dTdx,'Meridional temperature difference', & - units='C/'//trim(G%x_axis_units), default=0.0, scale=US%degC_to_C, do_not_log=just_read) - call get_param(param_file, mdl,"L_ZONE",L_zone,'Width of baroclinic zone', & - units=G%x_axis_units, default=0.5*G%len_lat, do_not_log=just_read) + units='degC m-1', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_T", delta_T,'Temperature difference across baroclinic zone', & + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "DTDX", dTdx,'Meridional temperature difference', & + units='degC '//trim(G%x_ax_unit_short)//'-1', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "L_ZONE", L_zone, 'Width of baroclinic zone', & + units=G%y_ax_unit_short, default=0.5*G%len_lat, do_not_log=just_read) call closeParameterBlock(param_file) end subroutine bcz_params @@ -92,12 +95,20 @@ subroutine baroclinic_zone_init_temperature_salinity(T, S, h, depth_tot, G, GV, !! parameters without changing T & S. integer :: i, j, k, is, ie, js, je, nz - real :: T_ref, dTdz, dTdx, delta_T ! Parameters describing temperature distribution [C ~> degC] - real :: S_ref, dSdz, dSdx, delta_S ! Parameters describing salinity distribution [S ~> ppt] - real :: L_zone ! Width of baroclinic zone in [G%axis_units] - real :: zc, zi ! Depths in depth units [Z ~> m] - real :: x, xd, xs, y, yd, fn - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: T_ref, delta_T ! Parameters describing temperature distribution [C ~> degC] + real :: dTdz ! Vertical temperature gradients [C Z-1 ~> degC m-1] + real :: dTdx ! Zonal temperature gradients [C axis_units-1 ~> degC axis_units-1] + real :: S_ref, delta_S ! Parameters describing salinity distribution [S ~> ppt] + real :: dSdz ! Vertical salinity gradients [S Z-1 ~> ppt m-1] + real :: dSdx ! Zonal salinity gradients [S axis_units-1 ~> ppt axis_units-1] + real :: L_zone ! Width of baroclinic zone, often in [km] or [degrees_N], depending + ! on the value of G%y_axis_units + real :: zc, zi ! Depths in depth units [Z ~> m] + real :: x ! X-position relative to the domain center [degrees_E] or [km] or [m] + real :: y ! Y-position relative to the domain center [degrees_N] or [km] or [m] + real :: fn ! A smooth function based on the position in the baroclinic zone [nondim] + real :: xs, xd, yd ! Fractional x- and y-positions relative to the domain extent [nondim] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 9553aafafb..f8e9b342ac 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -59,11 +59,11 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus ! Parameters read by cartesian grid initialization call get_param(param_file, mdl, "DISK_RADIUS", diskrad, & "The radius of the initially elevated disk in the "//& - "circle_obcs test case.", units=G%x_axis_units, & + "circle_obcs test case.", units=G%x_ax_unit_short, & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DISK_X_OFFSET", xOffset, & "The x-offset of the initially elevated disk in the "//& - "circle_obcs test case.", units=G%x_axis_units, & + "circle_obcs test case.", units=G%x_ax_unit_short, & default = 0.0, do_not_log=just_read) call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & "Initial amplitude of interface height displacements "//& From 490bfcae44a38df05e84c732ad117cdab705f78b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 3 Dec 2022 07:37:34 -0500 Subject: [PATCH 070/629] Scale default parameters Apply dimensional rescaling of parameters that are only used as defaults for other parameters, with the rescaling explicitly undone as a part of the default argument specification. This includes de-emphasizing the use of GV%Angstrom_m, instead using GV%Angstrom_Z. As a result, fewer get_param calls read in dimensional variables without specifying a scaling factor that can be compared with their declared units. All answers and output are bitwise identical. --- src/core/MOM_open_boundary.F90 | 2 +- src/core/MOM_verticalGrid.F90 | 10 +-- .../MOM_coord_initialization.F90 | 24 ++++--- .../MOM_state_initialization.F90 | 12 ++-- src/parameterizations/lateral/MOM_MEKE.F90 | 22 +++---- .../lateral/MOM_tidal_forcing.F90 | 22 ++++--- .../vertical/MOM_bkgnd_mixing.F90 | 30 ++++----- .../vertical/MOM_bulk_mixed_layer.F90 | 24 +++---- .../vertical/MOM_energetic_PBL.F90 | 8 +-- .../vertical/MOM_entrain_diffusive.F90 | 2 +- .../vertical/MOM_set_viscosity.F90 | 63 +++++++++---------- 11 files changed, 111 insertions(+), 108 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index abe63a950a..47d6953ce1 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -5590,7 +5590,7 @@ end subroutine remap_OBC_fields !> Adjust interface heights to fit the bathymetry and diagnose layer thickness. !! !! If the bottom most interface is below the topography then the bottom-most -!! layers are contracted to GV%Angstrom_m. +!! layers are contracted to GV%Angstrom_Z. !! If the bottom most interface is above the topography then the entire column !! is dilated (expanded) to fill the void. !! @remark{There is a (hard-wired) "tolerance" parameter such that the diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 2df65f09aa..e40ab20d5c 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -114,9 +114,9 @@ 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, "ANGSTROM", GV%Angstrom_m, & + call get_param(param_file, mdl, "ANGSTROM", GV%Angstrom_Z, & "The minimum layer thickness, usually one-Angstrom.", & - units="m", default=1.0e-10) + units="m", default=1.0e-10, scale=US%m_to_Z) call get_param(param_file, mdl, "H_RESCALE_POWER", H_power, & "An integer power of 2 that is used to rescale the model's "//& "intenal units of thickness. Valid values range from -300 to 300.", & @@ -156,13 +156,13 @@ 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 * GV%Angstrom_m + GV%Angstrom_H = GV%m_to_H * US%Z_to_m*GV%Angstrom_Z GV%H_to_MKS = GV%H_to_m else GV%kg_m2_to_H = 1.0 / GV%H_to_kg_m2 GV%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H GV%H_to_m = GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) - GV%Angstrom_H = GV%Angstrom_m*1000.0*GV%kg_m2_to_H + GV%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 endif GV%H_subroundoff = 1e-20 * max(GV%Angstrom_H,GV%m_to_H*1e-17) @@ -170,7 +170,7 @@ subroutine verticalGridInit( param_file, GV, US ) 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_Z = US%m_to_Z * GV%Angstrom_m + GV%Angstrom_m = US%Z_to_m * GV%Angstrom_Z 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 diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 66c09cb6a3..c956c6b4be 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -314,8 +314,8 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta real, dimension(GV%ke) :: T0 ! A profile of temperatures [C ~> degC] real, dimension(GV%ke) :: S0 ! A profile of salinities [S ~> ppt] real, dimension(GV%ke) :: Pref ! A array of reference pressures [R L2 T-2 ~> Pa] - real :: S_Ref ! Default salinity range parameters [ppt]. - real :: T_Ref ! Default temperature range parameters [degC]. + real :: S_Ref ! Default salinity range parameters [S ~> ppt]. + real :: T_Ref ! Default temperature range parameters [C ~> degC]. real :: S_Light, S_Dense ! Salinity range parameters [S ~> ppt]. real :: T_Light, T_Dense ! Temperature range parameters [C ~> degC]. real :: res_rat ! The ratio of density space resolution in the denser part @@ -332,22 +332,26 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta call callTree_enter(trim(mdl)//"(), MOM_coord_initialization.F90") call get_param(param_file, mdl, "T_REF", T_Ref, & - "The default initial temperatures.", units="degC", default=10.0) + "The default initial temperatures.", & + units="degC", default=10.0, scale=US%degC_to_C) call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_Light, & "The initial temperature of the lightest layer when "//& - "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref, scale=US%degC_to_C) + "COORD_CONFIG is set to ts_range.", & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C) call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_Dense, & "The initial temperature of the densest layer when "//& - "COORD_CONFIG is set to ts_range.", units="degC", default=T_Ref, scale=US%degC_to_C) + "COORD_CONFIG is set to ts_range.", & + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C) call get_param(param_file, mdl, "S_REF", S_Ref, & - "The default initial salinities.", units="PSU", default=35.0) + "The default initial salinities.", & + units="PSU", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_Light, & - "The initial lightest salinities when COORD_CONFIG "//& - "is set to ts_range.", default = S_Ref, units="PSU", scale=US%ppt_to_S) + "The initial lightest salinities when COORD_CONFIG is set to ts_range.", & + units="PSU", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_Dense, & - "The initial densest salinities when COORD_CONFIG "//& - "is set to ts_range.", default = S_Ref, units="PSU", scale=US%ppt_to_S) + "The initial densest salinities when COORD_CONFIG is set to ts_range.", & + units="PSU", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & "The ratio of density space resolution in the densest "//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index d3e8a2b18a..62438cbc7f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1782,8 +1782,8 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P "A reference temperature used in initialization.", & units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_Ref, & - "A reference salinity used in initialization.", units="PSU", & - default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + "A reference salinity used in initialization.", & + units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & @@ -2480,8 +2480,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just integer :: nkd ! number of levels to use for regridding input arrays real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. real :: eps_rho ! A negligibly small density difference [R ~> kg m-3]. - real :: PI_180 ! for conversion from degrees to radians - real :: Hmix_default ! The default initial mixed layer depth [m]. + real :: PI_180 ! for conversion from degrees to radians [radian degree-1] + real :: Hmix_default ! The default initial mixed layer depth [Z ~> m]. real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. real :: missing_value_temp ! The missing value in the input temperature field real :: missing_value_salt ! The missing value in the input salinity field @@ -2680,10 +2680,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just default=.false., do_not_log=just_read.or.(GV%nkml==0)) if (GV%nkml == 0) separate_mixed_layer = .false. call get_param(PF, mdl, "MINIMUM_DEPTH", Hmix_default, & - units="m", default=0.0, scale=1.0) + units="m", default=0.0, scale=US%m_to_Z) call get_param(PF, mdl, "Z_INIT_HMIX_DEPTH", Hmix_depth, & "The mixed layer depth in the initial conditions when Z_INIT_SEPARATE_MIXED_LAYER "//& - "is set to true.", default=Hmix_default, units="m", scale=US%m_to_Z, & + "is set to true.", units="m", default=US%Z_to_m*Hmix_default, scale=US%m_to_Z, & do_not_log=(just_read .or. .not.separate_mixed_layer)) call get_param(PF, mdl, "LAYER_Z_INIT_IC_EXTRAP_BUG", density_extrap_bug, & "If true use an expression with a vertical indexing bug for extrapolating the "//& diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 18c156e1f1..10d4270202 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1196,8 +1196,8 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, "each time step.", default=.false.) if (CS%MEKE_equilibrium_restoring) then call get_param(param_file, mdl, "MEKE_RESTORING_TIMESCALE", MEKE_restoring_timescale, & - "The timescale used to nudge MEKE toward its equilibrium value.", units="s", & - default=1e6, scale=US%s_to_T) + "The timescale used to nudge MEKE toward its equilibrium value.", & + units="s", default=1e6, scale=US%s_to_T) CS%MEKE_restoring_rate = 1.0 / MEKE_restoring_timescale endif @@ -1210,8 +1210,8 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, "by GME. If MEKE_GMECOEFF is negative, this conversion "//& "is not used or calculated.", units="nondim", default=-1.0) call get_param(param_file, mdl, "MEKE_BGSRC", CS%MEKE_BGsrc, & - "A background energy source for MEKE.", units="W kg-1", & - default=0.0, scale=US%m_to_L**2*US%T_to_s**3) + "A background energy source for MEKE.", & + units="W kg-1", default=0.0, scale=US%m_to_L**2*US%T_to_s**3) call get_param(param_file, mdl, "MEKE_KH", CS%MEKE_Kh, & "A background lateral diffusivity of MEKE. "//& "Use a negative value to not apply lateral diffusion to MEKE.", & @@ -1248,11 +1248,9 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) call get_param(param_file, mdl, "MEKE_KHTH_FAC", MEKE%KhTh_fac, & - "A factor that maps MEKE%Kh to KhTh.", units="nondim", & - default=0.0) + "A factor that maps MEKE%Kh to KhTh.", units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_KHTR_FAC", MEKE%KhTr_fac, & - "A factor that maps MEKE%Kh to KhTr.", units="nondim", & - default=0.0) + "A factor that maps MEKE%Kh to KhTr.", units="nondim", default=0.0) call get_param(param_file, mdl, "MEKE_KHMEKE_FAC", CS%KhMEKE_Fac, & "A factor that maps MEKE%Kh to Kh for MEKE itself.", & units="nondim", default=0.0) @@ -1336,13 +1334,11 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, ! Nonlocal module parameters call get_param(param_file, mdl, "CDRAG", cdrag, & - "CDRAG is the drag coefficient relating the magnitude of "//& - "the velocity field to the bottom stress.", units="nondim", & - default=0.003) + "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, "MEKE_CDRAG", CS%cdrag, & "Drag coefficient relating the magnitude of the velocity "//& - "field to the bottom stress in MEKE.", units="nondim", & - default=cdrag) + "field to the bottom stress in MEKE.", units="nondim", default=cdrag) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index dcf12f915f..520c70172f 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -70,16 +70,16 @@ module MOM_tidal_forcing sin_struct(:,:,:), & !< The sine and cosine based structures that can cos_struct(:,:,:), & !< be associated with the astronomical forcing [nondim]. cosphasesal(:,:,:), & !< The cosine and sine of the phase of the - sinphasesal(:,:,:), & !< self-attraction and loading amphidromes. + sinphasesal(:,:,:), & !< self-attraction and loading amphidromes [nondim]. ampsal(:,:,:), & !< The amplitude of the SAL [Z ~> m]. cosphase_prev(:,:,:), & !< The cosine and sine of the phase of the - sinphase_prev(:,:,:), & !< amphidromes in the previous tidal solutions. + sinphase_prev(:,:,:), & !< amphidromes in the previous tidal solutions [nondim]. amp_prev(:,:,:) !< The amplitude of the previous tidal solution [Z ~> m]. type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL - integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] - real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] - real, allocatable :: Snm_Re(:), & !< Real and imaginary SHT coefficient for SHT SAL - Snm_Im(:) !< [Z ~> m] + integer :: sal_sht_Nd !< Maximum degree for SHT [nondim] + real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nondim] + real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] + Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] end type tidal_forcing_CS integer :: id_clock_tides !< CPU clock for tides @@ -99,9 +99,12 @@ module MOM_tidal_forcing subroutine astro_longitudes_init(time_ref, longitudes) type(time_type), intent(in) :: time_ref !> Time to calculate longitudes for. type(astro_longitudes), intent(out) :: longitudes !> Lunar and solar longitudes at time_ref. + + ! Local variables real :: D !> Time since the reference date [days] real :: T !> Time in Julian centuries [centuries] real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim] + ! Find date at time_ref in days since 1900-01-01 D = time_type_to_real(time_ref - set_date(1900, 1, 1)) / (24.0 * 3600.0) ! Time since 1900-01-01 in Julian centuries @@ -542,7 +545,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & "The maximum degree of the spherical harmonics transformation used for "// & "calculating the self-attraction and loading term for tides.", & - default=0, do_not_log=.not. CS%tidal_sal_sht) + default=0, do_not_log=.not.CS%tidal_sal_sht) call get_param(param_file, mdl, "RHO_0", rhoW, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& @@ -551,8 +554,9 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) call get_param(param_file, mdl, "RHO_E", rhoE, & "The mean solid earth density. This is used for calculating the "// & - "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%tidal_sal_sht) + "self-attraction and loading term.", & + units="kg m-3", default=5517.0, scale=US%kg_m3_to_R, & + do_not_log=.not.CS%tidal_sal_sht) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 5a39f83c5d..6d016aa18b 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -37,13 +37,13 @@ module MOM_bkgnd_mixing ! Parameters real :: Bryan_Lewis_c1 !< The vertical diffusivity values for Bryan-Lewis profile - !! at |z|=D [m2 s-1] + !! at |z|=D [Z2 T-1 ~> m2 s-1] real :: Bryan_Lewis_c2 !< The amplitude of variation in diffusivity for the - !! Bryan-Lewis diffusivity profile [m2 s-1] + !! Bryan-Lewis diffusivity profile [Z2 T-1 ~> m2 s-1] real :: Bryan_Lewis_c3 !< The inverse length scale for transition region in the - !! Bryan-Lewis diffusivity profile [m-1] + !! Bryan-Lewis diffusivity profile [Z-1 ~> m-1] real :: Bryan_Lewis_c4 !< The depth where diffusivity is Bryan_Lewis_bl1 in the - !! Bryan-Lewis profile [m] + !! Bryan-Lewis profile [Z ~> m] real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] real :: bckgrnd_vdc_eq !< Equatorial diffusivity (Gregg) when @@ -156,7 +156,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KDML is a depricated parameter that should not be used.") call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & - units="m2 s-1", default=-1., scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KD_ML_TOT cannot be set when using a physically based ocean "//& "boundary layer mixing parameterization.") @@ -202,19 +202,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call get_param(param_file, mdl, "BRYAN_LEWIS_C1", CS%Bryan_Lewis_c1, & "The vertical diffusivity values for Bryan-Lewis profile at |z|=D.", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "BRYAN_LEWIS_C2", CS%Bryan_Lewis_c2, & "The amplitude of variation in diffusivity for the Bryan-Lewis profile", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "BRYAN_LEWIS_C3", CS%Bryan_Lewis_c3, & "The inverse length scale for transition region in the Bryan-Lewis profile", & - units="m-1", fail_if_missing=.true.) + units="m-1", scale=US%Z_to_m, fail_if_missing=.true.) call get_param(param_file, mdl, "BRYAN_LEWIS_C4", CS%Bryan_Lewis_c4, & "The depth where diffusivity is BRYAN_LEWIS_C1 in the Bryan-Lewis profile",& - units="m", fail_if_missing=.true.) + units="m", scale=US%m_to_Z, fail_if_missing=.true.) endif ! CS%Bryan_Lewis_diffusivity @@ -276,8 +276,8 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL "the Earth's rotation period, used with the Henyey "//& "scaling from the mixing.", units="nondim", default=20.0) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) endif call get_param(param_file, mdl, "KD_TANH_LAT_FN", CS%Kd_tanh_lat_fn, & @@ -369,10 +369,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, call CVMix_init_bkgnd(max_nlev=nz, & zw = depth_int(:), & !< interface depths relative to the surface in m, must be positive. - bl1 = CS%Bryan_Lewis_c1, & - bl2 = CS%Bryan_Lewis_c2, & - bl3 = CS%Bryan_Lewis_c3, & - bl4 = CS%Bryan_Lewis_c4, & + bl1 = US%Z2_T_to_m2_s*CS%Bryan_Lewis_c1, & + bl2 = US%Z2_T_to_m2_s*CS%Bryan_Lewis_c2, & + bl3 = US%m_to_Z*CS%Bryan_Lewis_c3, & + bl4 = US%Z_to_m*CS%Bryan_Lewis_c4, & prandtl = CS%prandtl_bkgnd) Kd_col(:) = 0.0 ; Kv_col(:) = 0.0 ! Is this line necessary? diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 2f8e03480e..a00e97a497 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -49,7 +49,7 @@ module MOM_bulk_mixed_layer !! the mixed layer is converted to TKE [nondim]. real :: bulk_Ri_convective !< The efficiency with which convectively !! released mean kinetic energy becomes TKE [nondim]. - real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nomdim] + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. real :: H_limit_fluxes !< When the total ocean depth is less than this !! value [H ~> m or kg m-2], scale away all surface forcing to @@ -3357,12 +3357,12 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) !! output. type(bulkmixedlayer_CS), intent(inout) :: CS !< Bulk mixed layer control structure -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. real :: BL_detrain_time_dflt ! The default value for BUFFER_LAY_DETRAIN_TIME [s] real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] - real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [m s-1] + real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] real :: Hmix_min_m ! The unscaled value of HMIX_MIN [m] integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega @@ -3396,8 +3396,8 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "BULK_RI_ML", CS%bulk_Ri_ML, & "The efficiency with which mean kinetic energy released "//& "by mechanically forced entrainment of the mixed layer "//& - "is converted to turbulent kinetic energy.", units="nondim",& - fail_if_missing=.true.) + "is converted to turbulent kinetic energy.", & + units="nondim", fail_if_missing=.true.) call get_param(param_file, mdl, "ABSORB_ALL_SW", CS%absorb_all_sw, & "If true, all shortwave radiation is absorbed by the "//& "ocean, instead of passing through to the bottom mud.", & @@ -3409,8 +3409,8 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "NSTAR2", CS%nstar2, & "The portion of any potential energy released by "//& "convective adjustment that is available to drive "//& - "entrainment at the base of mixed layer. By default "//& - "NSTAR2=NSTAR.", units="nondim", default=CS%nstar) + "entrainment at the base of mixed layer. By default NSTAR2=NSTAR.", & + units="nondim", default=CS%nstar) call get_param(param_file, mdl, "BULK_RI_CONVECTIVE", CS%bulk_Ri_convective, & "The efficiency with which convectively released mean "//& "kinetic energy is converted to turbulent kinetic "//& @@ -3446,7 +3446,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "relative to the density range within the mixed and "//& "buffer layers, when the detrainment is going into the "//& "lightest interior layer, nondimensional, or a negative "//& - "value not to apply this limit.", units="nondim", default = -1.0) + "value not to apply this limit.", units="nondim", default=-1.0) call get_param(param_file, mdl, "BUFFER_LAYER_HMIN_THICK", CS%Hbuffer_min, & "The minimum buffer layer thickness when the mixed layer is very thick.", & units="m", default=5.0, scale=GV%m_to_H) @@ -3493,12 +3493,12 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "layers before sorting when ML_RESORT is true.", & units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. ! This gives a minimum decay scale that is typically much less than Angstrom. - ustar_min_dflt = 2e-4*US%s_to_T*CS%omega*(GV%Angstrom_m + GV%H_to_m*GV%H_subroundoff) + ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & "The minimum value of ustar that should be used by the "//& "bulk mixed layer model in setting vertical TKE decay "//& - "scales. This must be greater than 0.", units="m s-1", & - default=ustar_min_dflt, scale=US%m_to_Z*US%T_to_s) + "scales. This must be greater than 0.", & + 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) if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 852ff4cee1..bd0740ccbd 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1961,8 +1961,8 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/1. General ePBL settings call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_S) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_S) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & "If true, use the absolute rotation rate instead of the "//& "vertical component of rotation when setting the decay "//& @@ -2014,8 +2014,8 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "MKE_TO_TKE_EFFIC", CS%MKE_to_TKE_effic, & "The efficiency with which mean kinetic energy released "//& "by mechanically forced entrainment of the mixed layer "//& - "is converted to turbulent kinetic energy.", units="nondim", & - default=0.0) + "is converted to turbulent kinetic energy.", & + units="nondim", default=0.0) call get_param(param_file, mdl, "TKE_DECAY", CS%TKE_decay, & "TKE_DECAY relates the vertical rate of decay of the "//& "TKE available for mechanical entrainment to the natural "//& diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 792c30cc98..9e749874c3 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -2114,7 +2114,7 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re units="s", scale=US%s_to_T, fail_if_missing=.true., do_not_log=just_read_params) call get_param(param_file, mdl, "TOLERANCE_ENT", CS%Tolerance_Ent, & "The tolerance with which to solve for entrainment values.", & - units="m", default=MAX(100.0*GV%Angstrom_m,1.0e-4*sqrt(dt*Kd)*US%Z_to_m), scale=GV%m_to_H, & + units="m", default=US%Z_to_m*MAX(100.0*GV%Angstrom_Z,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & do_not_log=just_read_params) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 249cbb5777..91c85ced26 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1995,11 +1995,13 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS real :: TKE_decay_dflt ! The default value of a coefficient scaling the vertical decay ! rate of TKE [nondim] real :: bulk_Ri_ML_dflt ! The default bulk Richardson number for a bulk mixed layer [nondim] - real :: Kv_background ! The background kinematic viscosity in the interior [m2 s-1] + real :: Kv_background ! The background kinematic viscosity in the interior [Z2 T-1 ~> m2 s-1] real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate that ! is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] - real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [m] + real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [Z ~> m] + 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]? @@ -2103,19 +2105,17 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (CS%dynamic_viscous_ML) then call get_param(param_file, mdl, "BULK_RI_ML", bulk_Ri_ML_dflt, units="nondim", default=0.0) call get_param(param_file, mdl, "BULK_RI_ML_VISC", CS%bulk_Ri_ML, & - "The efficiency with which mean kinetic energy released "//& - "by mechanically forced entrainment of the mixed layer "//& - "is converted to turbulent kinetic energy. By default, "//& - "BULK_RI_ML_VISC = BULK_RI_ML or 0.", units="nondim", & - default=bulk_Ri_ML_dflt) + "The efficiency with which mean kinetic energy released by mechanically "//& + "forced entrainment of the mixed layer is converted to turbulent "//& + "kinetic energy. By default, BULK_RI_ML_VISC = BULK_RI_ML or 0.", & + units="nondim", default=bulk_Ri_ML_dflt) call get_param(param_file, mdl, "TKE_DECAY", TKE_decay_dflt, units="nondim", default=0.0) call get_param(param_file, mdl, "TKE_DECAY_VISC", CS%TKE_decay, & "TKE_DECAY_VISC relates the vertical rate of decay of "//& "the TKE available for mechanical entrainment to the "//& "natural Ekman depth for use in calculating the dynamic "//& - "mixed layer viscosity. By default, "//& - "TKE_DECAY_VISC = TKE_DECAY or 0.", units="nondim", & - default=TKE_decay_dflt) + "mixed layer viscosity. By default, TKE_DECAY_VISC = TKE_DECAY or 0.", & + units="nondim", default=TKE_decay_dflt) call get_param(param_file, mdl, "ML_USE_OMEGA", use_omega, & "If true, use the absolute rotation rate instead of the "//& "vertical component of rotation when setting the decay "//& @@ -2131,28 +2131,27 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "local value of f, as sqrt((1-of)*f^2 + of*4*omega^2).", & units="nondim", default=omega_frac_dflt) call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) ! This give a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) else call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) endif - call get_param(param_file, mdl, "HBBL", CS%Hbbl, & + call get_param(param_file, mdl, "HBBL", Hbbl, & "The thickness of a bottom boundary layer with a viscosity increased by "//& "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& "defined but LINEAR_DRAG is not.", & - units="m", fail_if_missing=.true.) ! Rescaled later + units="m", scale=US%m_to_Z, fail_if_missing=.true.) ! Rescaled later if (CS%bottomdraglaw) then call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress. CDRAG is only "//& - "used if BOTTOMDRAGLAW is defined.", units="nondim", & - default=0.003) + "used if BOTTOMDRAGLAW is defined.", units="nondim", default=0.003) call get_param(param_file, mdl, "BBL_USE_TIDAL_BG", CS%BBL_use_tidal_bg, & "Flag to use the tidal RMS amplitude in place of constant "//& "background velocity for computing u* in the BBL. "//& @@ -2187,25 +2186,26 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (use_regridding .and. (.not. CS%BBL_use_EOS)) & call MOM_error(FATAL,"When using MOM6 in ALE mode it is required to set BBL_USE_EOS to True.") endif - call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & + call get_param(param_file, mdl, "BBL_THICK_MIN", BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& - "near-bottom viscosity.", units="m", default=0.0) ! Rescaled later + "near-bottom viscosity.", units="m", default=0.0, scale=US%m_to_Z) call get_param(param_file, mdl, "HTBL_SHELF_MIN", CS%Htbl_shelf_min, & "The minimum top boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& - "near-top viscosity.", units="m", default=CS%BBL_thick_min, scale=GV%m_to_H) + "near-top viscosity.", units="m", default=US%Z_to_m*BBL_thick_min, scale=GV%m_to_H) call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & "The thickness over which near-surface velocities are "//& "averaged for the drag law under an ice shelf. By "//& - "default this is the same as HBBL", units="m", default=CS%Hbbl, scale=GV%m_to_H) + "default this is the same as HBBL", & + units="m", default=US%Z_to_m*Hbbl, scale=GV%m_to_H) call get_param(param_file, mdl, "KV", Kv_background, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", fail_if_missing=.true.) + units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) call get_param(param_file, mdl, "USE_KPP", use_KPP, & "If true, turns on the [CVMix] KPP scheme of Large et al., 1994, "//& @@ -2214,10 +2214,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & - units="m2 s-1", default=Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KV_TBL_MIN", CS%KV_TBL_min, & "The minimum viscosities in the top boundary layer.", & - units="m2 s-1", default=Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "CORRECT_BBL_BOUNDS", CS%correct_BBL_bounds, & "If true, uses the correct bounds on the BBL thickness and "//& "viscosity so that the bottom layer feels the intended drag.", & @@ -2239,23 +2239,22 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 endif - Chan_max_thick_dflt = -1.0 - if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*CS%Hbbl - if (CS%body_force_drag) Chan_max_thick_dflt = CS%Hbbl + Chan_max_thick_dflt = -1.0*US%m_to_Z + if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*Hbbl + if (CS%body_force_drag) Chan_max_thick_dflt = Hbbl call get_param(param_file, mdl, "CHANNEL_DRAG_MAX_BBL_THICK", CS%Chan_drag_max_vol, & "The maximum bottom boundary layer thickness over which the channel drag is "//& "exerted, or a negative value for no fixed limit, instead basing the BBL "//& "thickness on the bottom stress, rotation and stratification. The default is "//& "proportional to HBBL if USE_JACKSON_PARAM or DRAG_AS_BODY_FORCE is true.", & - units="m", default=Chan_max_thick_dflt, scale=GV%m_to_H, & + units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=GV%m_to_H, & do_not_log=.not.CS%Channel_drag) call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) - ! These unit conversions are out outside the get_param calls because they are also defaults. - CS%Hbbl = CS%Hbbl * GV%m_to_H ! Rescale - CS%BBL_thick_min = CS%BBL_thick_min * GV%m_to_H ! Rescale + CS%Hbbl = Hbbl * GV%Z_to_H ! Rescaled for later use + CS%BBL_thick_min = BBL_thick_min * GV%Z_to_H ! Rescaled for later use if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then ! This is necessary for reproducibility across restarts in non-symmetric mode. From 8bc69f67e7437aa13f949f8cff03d3e4c705c96c Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 13 Dec 2022 13:52:54 -0700 Subject: [PATCH 071/629] further improvement to logunit setting --- config_src/drivers/nuopc_cap/mom_cap.F90 | 13 +++++-------- 1 file changed, 5 insertions(+), 8 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 4684b0e6ff..08f564973b 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -38,7 +38,7 @@ module MOM_cap_mod use MOM_cap_methods, only: ChkErr #ifdef CESMCOUPLED -use shr_log_mod, only: shr_log_setLogUnit, shr_log_getLogUnit +use shr_log_mod, only: shr_log_setLogUnit #endif use time_utils_mod, only: esmf2fms_time @@ -507,7 +507,10 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) stdout = output_unit endif call shr_log_setLogUnit(stdout) - + call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeSet(gcomp, "logunit", logunit, rc=rc) + if (chkerr(rc,__LINE__,u_FILE_u)) return call MOM_infra_init(mpi_comm_mom) call constants_init @@ -2256,12 +2259,6 @@ subroutine shr_log_setLogUnit(nunit) ! do nothing for this stub - its just here to replace ! having cppdefs in the main program end subroutine shr_log_setLogUnit - -subroutine shr_log_getLogUnit(nunit) - integer, intent(in) :: nunit - ! do nothing for this stub - its just here to replace - ! having cppdefs in the main program -end subroutine shr_log_getLogUnit #endif !> From a789254e0fcbe31f675410507793ca2455f5cbe8 Mon Sep 17 00:00:00 2001 From: Jim Edwards Date: Tue, 13 Dec 2022 15:09:58 -0700 Subject: [PATCH 072/629] get the variable name correct --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 08f564973b..c909be8652 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -509,7 +509,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call shr_log_setLogUnit(stdout) call NUOPC_CompAttributeAdd(gcomp, (/"logunit"/), rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeSet(gcomp, "logunit", logunit, rc=rc) + call NUOPC_CompAttributeSet(gcomp, "logunit", stdout, rc=rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call MOM_infra_init(mpi_comm_mom) From c80db6786a8061ab744ddafa81c6ac7893fb213a Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Fri, 2 Dec 2022 16:49:19 -0700 Subject: [PATCH 073/629] Make sure EBT structure is computed when desired This addition makes sure that CS%ebt_struct is filled/computed if the user specifies KHTH_USE_EBT_STRUCT = True. Before this addition, an array for CS%ebt_struct got allocated and initialized to 0, if KHTH_USE_EBT_STRUCT = True. But this array never got filled (with values other than 0) unless the user selected any of the following options too: 1) KHTH_USE_FGNV_STREAMFUNCTION = True 2) USE_MEKE = True 3) KhTr_passivity_coeff > 0 4) MLE_front_length > 0 5) Output the diagnostic Rd_dx 6) Use resolution scaling for the a) Laplacian viscosity, b) interface height diffusivity, c) tracer diffusivity, OR d) the MEKE viscosity contribution. --- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 47d1cd6eb3..aa561793e0 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1194,7 +1194,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=1.0e-17, units="s-1", scale=US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & default=.false., do_not_log=.true.) - CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn + CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE ! Indicate whether to calculate the Eady growth rate CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) From c6c84c8071a9e3a6b4b288ba4ddc32e128630ad4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 2 Dec 2022 16:04:41 -0500 Subject: [PATCH 074/629] +Add units to 11 log_param calls Add appropriate units arguments to 11 log_param calls that were missing them. All answers are bitwise identical, but the logged output can change in some cases. --- src/core/MOM_PressureForce_FV.F90 | 2 +- src/core/MOM_PressureForce_Montgomery.F90 | 2 +- src/core/MOM_barotropic.F90 | 4 ++-- src/core/MOM_verticalGrid.F90 | 6 +++--- src/framework/testing/MOM_file_parser_tests.F90 | 4 ++-- src/tracer/oil_tracer.F90 | 2 +- 6 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index a35effa5c0..5fdc4a1182 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -857,7 +857,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS CS%GFS_scale = 1.0 if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth - call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim") end subroutine PressureForce_FV_init diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 1ae4a8709a..424e9b1a32 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -874,7 +874,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ CS%GFS_scale = 1.0 if (GV%g_prime(1) /= GV%g_Earth) CS%GFS_scale = GV%g_prime(1) / GV%g_Earth - call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale) + call log_param(param_file, mdl, "GFS / G_EARTH", CS%GFS_scale, units="nondim") end subroutine PressureForce_Mont_init diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 5fd8a97793..105e81732a 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4804,8 +4804,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, endif if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. - call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s) - call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s) + call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s, units="s") + call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s, units="s") ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index e40ab20d5c..41d29488cd 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -176,9 +176,9 @@ subroutine verticalGridInit( param_file, GV, US ) GV%RZ_to_H = GV%kg_m2_to_H * US%R_to_kg_m3 * US%Z_to_m ! Log derivative values. - call log_param(param_file, mdl, "M to THICKNESS", GV%m_to_H*H_rescale_factor) - call log_param(param_file, mdl, "M to THICKNESS rescaled by 2^-n", GV%m_to_H) - call log_param(param_file, mdl, "THICKNESS to M rescaled by 2^n", GV%H_to_m) + 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") allocate( GV%sInterface(nk+1) ) allocate( GV%sLayer(nk) ) diff --git a/src/framework/testing/MOM_file_parser_tests.F90 b/src/framework/testing/MOM_file_parser_tests.F90 index 673cef8c16..c0a31c39c4 100644 --- a/src/framework/testing/MOM_file_parser_tests.F90 +++ b/src/framework/testing/MOM_file_parser_tests.F90 @@ -1277,7 +1277,7 @@ subroutine test_log_param_real call create_test_file(param_filename) call open_param_file(param_filename, param) - call log_param(param, module_name, sample_param_name, sample, desc=desc) + call log_param(param, module_name, sample_param_name, sample, desc=desc, units="") call close_param_file(param) end subroutine test_log_param_real @@ -1290,7 +1290,7 @@ subroutine test_log_param_real_array call create_test_file(param_filename) call open_param_file(param_filename, param) - call log_param(param, module_name, sample_param_name, sample, desc=desc) + call log_param(param, module_name, sample_param_name, sample, desc=desc, units="") call close_param_file(param) end subroutine test_log_param_real_array diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 3fc2537caa..4d828decad 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -165,7 +165,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) endif endif enddo - call log_param(param_file, mdl, "OIL_DECAY_RATE", US%s_to_T*CS%oil_decay_rate(1:CS%ntr)) + call log_param(param_file, mdl, "OIL_DECAY_RATE", US%s_to_T*CS%oil_decay_rate(1:CS%ntr), units="s-1") ! This needs to be changed if the units of tracer are changed above. if (GV%Boussinesq) then ; flux_units = "kg s-1" From 74c0de65e82abe641db85a46f25734877c9203e6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 30 Nov 2022 12:48:03 -0500 Subject: [PATCH 075/629] +Rescaled time variables in all MOM6 drivers Dimensionally rescaled the internal variables with units of time in all of the top-level driver codes, from units of [s] to [T ~> s], including thing valid_time arguments to the various drivers' versions of convert_IOB_to_fluxes. All answers are bitwise identical in all cases that have been tested, although it should be noted that the mct_cap and nuopc_cap are not regularly tested as a part of the GFDL MOM6-examples test suite. These changes only apply to dimensional rescaling of timestep variables and the documentation of units. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 8 +- .../drivers/FMS_cap/ocean_model_MOM.F90 | 67 +++++++-------- .../ice_solo_driver/ice_shelf_driver.F90 | 21 +++-- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 71 ++++++++-------- .../mct_cap/mom_surface_forcing_mct.F90 | 4 +- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 71 ++++++++-------- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 4 +- config_src/drivers/solo_driver/MOM_driver.F90 | 83 ++++++++++--------- src/core/MOM_forcing_type.F90 | 2 +- 9 files changed, 167 insertions(+), 164 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 90797027c6..ccd2183e3c 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -221,7 +221,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. real, intent(in) :: valid_time !< The amount of time over which these fluxes - !! should be applied [s]. + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -333,7 +333,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Indicate that there are new unused fluxes. fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*valid_time + fluxes%dt_buoy_accum = valid_time fluxes%heat_added(:,:) = 0.0 fluxes%salt_flux_added(:,:) = 0.0 @@ -581,7 +581,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo !#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & -!#CTRL# fluxes%vprec, day, US%s_to_T*valid_time, G, US, CS%ctrl_forcing_CSp) +!#CTRL# fluxes%vprec, day, valid_time, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif ! adjust the NET fresh-water flux to zero, if flagged @@ -663,7 +663,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ !! previous call to surface_forcing_init. real, optional, intent(in) :: dt_forcing !< A time interval over which to apply the !! current value of ustar as a weighted running - !! average [s], or if 0 do not average ustar. + !! average [T ~> s], or if 0 do not average ustar. !! Missing is equivalent to 0. logical, optional, intent(in) :: reset_avg !< If true, reset the time average. diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index a12ab35240..f8f7de6eae 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -21,7 +21,7 @@ module ocean_model_mod use MOM_coupler_types, only : coupler_type_spawn, coupler_type_write_chksums use MOM_coupler_types, only : coupler_type_initialized, coupler_type_copy_data use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : MOM_domain_type, domain2d, clone_MOM_domain, get_domain_extent use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE, TO_ALL, Omit_Corners @@ -171,8 +171,8 @@ module ocean_model_mod !! If false, the two phases are advanced with !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. - real :: dt !< (baroclinic) dynamics time step [s] - real :: dt_therm !< thermodynamics time step [s] + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -293,16 +293,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", scale=OS%US%s_to_T, default=OS%US%T_to_s*OS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -462,11 +463,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda type(time_type) :: Time1 ! The value of the ocean model's time at the start of a call to step_MOM. integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocean boundary type. real :: weight ! Flux accumulation weight of the current fluxes. - real :: dt_coupling ! The coupling time step [s]. - real :: dt_therm ! A limited and quantized version of OS%dt_therm [s]. - real :: dt_dyn ! The dynamics time step [s]. - real :: dtdia ! The diabatic time step [s]. - real :: t_elapsed_seg ! The elapsed time in this update segment [s]. + real :: dt_coupling ! The coupling time step [T ~> s]. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s]. + real :: dt_dyn ! The dynamics time step [T ~> s]. + real :: dtdia ! The diabatic time step [T ~> s]. + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s]. integer :: n ! The internal iteration counter. integer :: nts ! The number of baroclinic dynamics time steps in a thermodynamic step. integer :: n_max ! The number of calls to step_MOM dynamics in this call to update_ocean_model. @@ -478,7 +479,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda integer :: is, ie, js, je call callTree_enter("update_ocean_model(), ocean_model_MOM.F90") - dt_coupling = time_type_to_real(Ocean_coupling_time_step) + dt_coupling = OS%US%s_to_T*time_type_to_real(Ocean_coupling_time_step) if (.not.associated(OS)) then call MOM_error(FATAL, "update_ocean_model called with an unassociated "// & @@ -518,7 +519,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) if (OS%icebergs_alter_ocean) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) endif if (do_thermo) then @@ -528,13 +529,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! Add ice shelf fluxes if (OS%use_ice_shelf) & - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, 1.0) ! Here weight=1, so just store the current fluxes call disable_averaging(OS%diag) #endif @@ -546,10 +547,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) if (OS%use_ice_shelf) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) call fluxes_accumulate(OS%flux_tmp, OS%fluxes, OS%grid, weight) #ifdef _USE_GENERIC_TRACER @@ -579,15 +580,15 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda Time1 = Time_seg_start if (OS%offline_tracer_mode .and. do_thermo) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -609,18 +610,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -634,15 +635,15 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. - Time1 = Time1 - real_to_time(dtdia - dt_dyn) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & + Time1 = Time1 - real_to_time(OS%US%T_to_s*(dtdia - dt_dyn)) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) endif endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time1 = Time_seg_start + real_to_time(t_elapsed_seg) + Time1 = Time_seg_start + real_to_time(OS%US%T_to_s*t_elapsed_seg) enddo endif @@ -653,7 +654,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 if (do_dyn) then - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time_dyn, OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, OS%US%T_to_s*dt_coupling, OS%grid, OS%Time_dyn, OS%diag, OS%forcing_CSp%handles) endif if (OS%fluxes%fluxes_used .and. do_thermo) then diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 959e4676d0..8ea0867d03 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -25,8 +25,7 @@ program Shelf_main use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_debugging, only : MOM_debugging_init use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -96,13 +95,13 @@ program Shelf_main type(time_type) :: time_chg ! An amount of time to adjust the segment_start_time ! and elapsed time to avoid roundoff problems. - real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. + real :: elapsed_time = 0.0 ! Elapsed time in this run [T ~> s]. logical :: elapsed_time_master ! If true, elapsed time is used to set the ! model's master clock (Time). This is needed ! if Time_step_shelf is not an exact ! representation of time_step. - real :: time_step ! The time step [s] + real :: time_step ! The time step [T ~> s] ! A pointer to a structure containing metrics and related information. type(ocean_grid_type), pointer :: ocn_grid @@ -232,7 +231,7 @@ program Shelf_main call get_param(param_file, mod_name, "ICE_VELOCITY_TIMESTEP", time_step, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics.", & - units="s", fail_if_missing=.true.) + units="s", scale=US%s_to_T, fail_if_missing=.true.) if (sum(date) >= 0) then ! In this case, the segment starts at a time fixed by ocean_solo.res @@ -282,8 +281,8 @@ program Shelf_main segment_start_time = Time elapsed_time = 0.0 - Time_step_shelf = real_to_time(time_step) - elapsed_time_master = (abs(time_step - time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) + Time_step_shelf = real_to_time(US%T_to_s*time_step) + elapsed_time_master = (abs(time_step - US%s_to_T*time_type_to_real(Time_step_shelf)) > 1.0e-12*time_step) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) @@ -384,18 +383,18 @@ program Shelf_main ! Time = Time + Time_step_shelf ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + time_step - if (elapsed_time > 2e9) then + if (elapsed_time > 2.0e9*US%s_to_T) then ! This is here to ensure that the conversion from a real to an integer can be accurately ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time ! does not lose resolution of order the timetype's resolution, provided that the timestep and ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller ! value would be required. - time_chg = real_to_time(elapsed_time) + time_chg = real_to_time(US%T_to_s*elapsed_time) segment_start_time = segment_start_time + time_chg - elapsed_time = elapsed_time - time_type_to_real(time_chg) + elapsed_time = elapsed_time - US%s_to_T*time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + real_to_time(elapsed_time) + Master_Time = segment_start_time + real_to_time(US%T_to_s*elapsed_time) else Master_Time = Master_Time + Time_step_shelf endif diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index c2ee910dbb..bdcefbc1b2 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -17,7 +17,7 @@ module MOM_ocean_model_mct use MOM, only : get_ocean_stocks, step_offline use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : TO_ALL, Omit_Corners @@ -170,8 +170,8 @@ module MOM_ocean_model_mct !! If false, the two phases are advanced with !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. - real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + real :: dt !< (baroclinic) dynamics time step [T ~> s] + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -285,16 +285,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", scale=OS%US%s_to_T, default=OS%US%T_to_s*OS%dt) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -448,13 +449,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & integer :: index_bnds(4) ! The computational domain index bounds in the ! ice-ocean boundary type. real :: weight ! Flux accumulation weight - real :: dt_coupling ! The coupling time step in seconds. + real :: dt_coupling ! The coupling time step [T ~> s] integer :: nts ! The number of baroclinic dynamics time steps ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s] + real :: dt_dyn ! The dynamics time step [T ~> s] + real :: dtdia ! The diabatic time step [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s] integer :: n, n_max, n_last_thermo type(time_type) :: Time2 ! A temporary time. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans @@ -467,7 +468,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call callTree_enter("update_ocean_model(), MOM_ocean_model_mct.F90") call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) + dt_coupling = OS%US%s_to_T*(86400.0*real(days) + real(secs)) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -501,7 +502,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%fluxes%fluxes_used) then ! GMM, is enable_averaging needed now? - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%fluxes, index_bnds, OS%Time, dt_coupling, & @@ -511,24 +512,24 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! Add ice shelf fluxes if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) endif ! Fields that exist in both the forcing and mech_forcing types must be copied. call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif @@ -542,17 +543,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) endif call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) @@ -581,16 +582,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time if(OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) @@ -614,18 +615,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -639,22 +640,22 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) endif endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + set_time(int(floor(OS%US%T_to_s*t_elapsed_seg + 0.5))) enddo endif OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, OS%US%T_to_s*dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) 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 78f7bad268..8644e85616 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -206,7 +206,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. real, intent(in) :: valid_time !< The amount of time over which these fluxes - !! should be applied [s]. + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -334,7 +334,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Indicate that there are new unused fluxes. fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*valid_time + fluxes%dt_buoy_accum = valid_time if (CS%allow_flux_adjustments) then fluxes%heat_added(:,:) = 0.0 diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1fb35b31a6..640fc32632 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -17,7 +17,7 @@ module MOM_ocean_model_nuopc use MOM, only : get_ocean_stocks, step_offline use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf -use MOM_diag_mediator, only : diag_ctrl, enable_averaging, disable_averaging +use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging use MOM_diag_mediator, only : diag_mediator_close_registration, diag_mediator_end use MOM_domains, only : pass_var, pass_vector, AGRID, BGRID_NE, CGRID_NE use MOM_domains, only : TO_ALL, Omit_Corners @@ -171,7 +171,7 @@ module MOM_ocean_model_nuopc !! separate calls. The default is true. ! The following 3 variables are only used here if single_step_call is false. real :: dt !< (baroclinic) dynamics time step (seconds) - real :: dt_therm !< thermodynamics time step (seconds) + real :: dt_therm !< thermodynamics time step [T ~> s] logical :: thermo_spans_coupling !< If true, thermodynamic and tracer time !! steps can span multiple coupled time steps. logical :: diabatic_first !< If true, apply diabatic and thermodynamic @@ -295,16 +295,17 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i "including both dynamics and thermodynamics. If false, "//& "the two phases are advanced with separate calls.", default=.true.) call get_param(param_file, mdl, "DT", OS%dt, & - "The (baroclinic) dynamics time step. The time-step that "//& - "is actually used will be an integer fraction of the "//& - "forcing time-step.", units="s", fail_if_missing=.true.) + "The (baroclinic) dynamics time step. The time-step that is actually "//& + "used will be an integer fraction of the forcing time-step.", & + units="s", scale=OS%US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mdl, "DT_THERM", OS%dt_therm, & "The thermodynamic and tracer advection time step. "//& "Ideally DT_THERM should be an integer multiple of DT "//& "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=OS%dt) + "default DT_THERM is set to DT.", & + units="s", default=OS%US%T_to_s*OS%dt, scale=OS%US%s_to_T) call get_param(param_file, "MOM", "THERMO_SPANS_COUPLING", OS%thermo_spans_coupling, & "If true, the MOM will take thermodynamic and tracer "//& "timesteps that can be longer than the coupling timestep. "//& @@ -489,13 +490,13 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & integer :: index_bnds(4) ! The computational domain index bounds in the ! ice-ocean boundary type. real :: weight ! Flux accumulation weight - real :: dt_coupling ! The coupling time step in seconds. + real :: dt_coupling ! The coupling time step in rescaled seconds [T ~> s]. integer :: nts ! The number of baroclinic dynamics time steps ! within dt_coupling. - real :: dt_therm ! A limited and quantized version of OS%dt_therm (sec) - real :: dt_dyn ! The dynamics time step in sec. - real :: dtdia ! The diabatic time step in sec. - real :: t_elapsed_seg ! The elapsed time in this update segment, in s. + real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s] + real :: dt_dyn ! The dynamics time step [T ~> s] + real :: dtdia ! The diabatic time step [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this update segment [T ~> s] integer :: n, n_max, n_last_thermo type(time_type) :: Time2 ! A temporary time. logical :: thermo_does_span_coupling ! If true, thermodynamic forcing spans @@ -508,7 +509,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call callTree_enter("update_ocean_model(), MOM_ocean_model_nuopc.F90") call get_time(Ocean_coupling_time_step, secs, days) - dt_coupling = 86400.0*real(days) + real(secs) + dt_coupling = OS%US%s_to_T*(86400.0*real(days) + real(secs)) if (time_start_update /= OS%Time) then call MOM_error(WARNING, "update_ocean_model: internal clock does not "//& @@ -547,45 +548,45 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! Add ice shelf fluxes if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) endif ! Fields that exist in both the forcing and mech_forcing types must be copied. call copy_common_forcing_fields(OS%forces, OS%fluxes, OS%grid, skip_pres=.true.) #ifdef _USE_GENERIC_TRACER - call enable_averaging(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? + call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? call MOM_generic_tracer_fluxes_accumulate(OS%fluxes, weight) !here weight=1, just saving the current fluxes #endif else OS%flux_tmp%C_p = OS%fluxes%C_p if (do_thermo) & call convert_IOB_to_fluxes(Ice_ocean_boundary, OS%flux_tmp, index_bnds, OS%Time, dt_coupling, & - OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity,OS%restore_temp) + OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state, OS%restore_salinity, OS%restore_temp) if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) endif call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) @@ -614,16 +615,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time if (OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) - !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -646,18 +647,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -671,22 +672,22 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. - Time2 = Time2 - set_time(int(floor((dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & + Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) endif endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + set_time(int(floor(t_elapsed_seg + 0.5))) + Time2 = Time1 + set_time(int(floor(OS%US%T_to_s*t_elapsed_seg + 0.5))) enddo endif OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, OS%US%T_to_s*dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then if (cesm_coupled) then 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 738866c8ef..e2710bd18c 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -233,7 +233,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, type(time_type), intent(in) :: Time !< The time of the fluxes, used for interpolating the !! salinity to the right time, when it is being restored. real, intent(in) :: valid_time !< The amount of time over which these fluxes - !! should be applied [s]. + !! should be applied [T ~> s]. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(surface_forcing_CS),pointer :: CS !< A pointer to the control structure returned by a @@ -363,7 +363,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! Indicate that there are new unused fluxes. fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*valid_time + fluxes%dt_buoy_accum = valid_time if (CS%allow_flux_adjustments) then fluxes%heat_added(:,:)=0.0 diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 1d603740a1..565948af8b 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -27,8 +27,7 @@ program MOM6 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_data_override, only : data_override_init - use MOM_diag_mediator, only : enable_averaging, disable_averaging, diag_mediator_end - use MOM_diag_mediator, only : diag_ctrl, diag_mediator_close_registration + use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized @@ -122,20 +121,18 @@ program MOM6 type(time_type) :: Time_step_ocean ! A time_type version of dt_forcing. logical :: segment_start_time_set ! True if segment_start_time has been set to a valid value. - real :: elapsed_time = 0.0 ! Elapsed time in this run [s]. - logical :: elapsed_time_master ! If true, elapsed time is used to set the - ! model's master clock (Time). This is needed - ! if Time_step_ocean is not an exact - ! representation of dt_forcing. - real :: dt_forcing ! The coupling time step [s]. - real :: dt ! The nominal baroclinic dynamics time step [s]. - integer :: ntstep ! The number of baroclinic dynamics time steps - ! within dt_forcing. - real :: dt_therm ! The thermodynamic timestep [s] - real :: dt_dyn ! The actual dynamic timestep used [s]. The value of dt_dyn is - ! chosen so that dt_forcing is an integer multiple of dt_dyn. - real :: dtdia ! The diabatic timestep [s] - real :: t_elapsed_seg ! The elapsed time in this run segment [s] + real :: elapsed_time = 0.0 ! Elapsed time in this run [T ~> s]. + logical :: elapsed_time_master ! If true, elapsed time is used to set the model's master + ! clock (Time). This is needed if Time_step_ocean is not + ! an exact representation of dt_forcing. + real :: dt_forcing ! The coupling time step [T ~> s]. + real :: dt ! The nominal baroclinic dynamics time step [T ~> s]. + integer :: ntstep ! The number of baroclinic dynamics time steps within dt_forcing. + real :: dt_therm ! The thermodynamic timestep [T ~> s] + real :: dt_dyn ! The actual dynamic timestep used [T ~> s]. The value of dt_dyn + ! is chosen so that dt_forcing is an integer multiple of dt_dyn. + real :: dtdia ! The diabatic timestep [T ~> s] + real :: t_elapsed_seg ! The elapsed time in this run segment [T ~> s] integer :: n, ns, n_max, nts, n_last_thermo logical :: diabatic_first, single_step_call type(time_type) :: Time2, time_chg ! Temporary time variables @@ -331,25 +328,28 @@ program MOM6 ! Read all relevant parameters and write them to the model log. call log_version(param_file, mod_name, version, "") - call get_param(param_file, mod_name, "DT", dt, fail_if_missing=.true.) + call get_param(param_file, mod_name, "DT", dt, & + units="s", scale=US%s_to_T, fail_if_missing=.true.) call get_param(param_file, mod_name, "DT_FORCING", dt_forcing, & "The time step for changing forcing, coupling with other "//& "components, or potentially writing certain diagnostics. "//& - "The default value is given by DT.", units="s", default=dt) + "The default value is given by DT.", & + units="s", default=US%T_to_s*dt, scale=US%s_to_T) if (offline_tracer_mode) then call get_param(param_file, mod_name, "DT_OFFLINE", dt_forcing, & "Length of time between reading in of input fields", & - units='s', fail_if_missing=.true.) + units="s", scale=US%s_to_T, fail_if_missing=.true.) dt = dt_forcing endif ntstep = MAX(1,ceiling(dt_forcing/dt - 0.001)) - Time_step_ocean = real_to_time(dt_forcing) - elapsed_time_master = (abs(dt_forcing - time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) + Time_step_ocean = real_to_time(US%T_to_s*dt_forcing) + elapsed_time_master = (abs(dt_forcing - US%s_to_T*time_type_to_real(Time_step_ocean)) > 1.0e-12*dt_forcing) if (elapsed_time_master) & call MOM_mesg("Using real elapsed time for the master clock.", 2) ! Determine the segment end time, either from the namelist file or parsed input file. + ! Note that Time_unit always is in [s]. call get_param(param_file, mod_name, "TIMEUNIT", Time_unit, & "The time unit for DAYMAX, ENERGYSAVEDAYS, and RESTINT.", & units="s", default=86400.0) @@ -384,7 +384,8 @@ program MOM6 "and less than the forcing or coupling time-step, unless "//& "THERMO_SPANS_COUPLING is true, in which case DT_THERM "//& "can be an integer multiple of the coupling timestep. By "//& - "default DT_THERM is set to DT.", units="s", default=dt) + "default DT_THERM is set to DT.", & + units="s", default=US%T_to_s*dt, scale=US%s_to_T) call get_param(param_file, mod_name, "DIABATIC_FIRST", diabatic_first, & "If true, apply diabatic and thermodynamic processes, "//& "including buoyancy forcing and mass gain or loss, "//& @@ -461,11 +462,11 @@ program MOM6 endif if (use_ice_shelf) then - call shelf_calc_flux(sfc_state, fluxes, Time, dt_forcing, ice_shelf_CSp) + call shelf_calc_flux(sfc_state, fluxes, Time, US%T_to_s*dt_forcing, ice_shelf_CSp) call add_shelf_forces(grid, US, Ice_shelf_CSp, forces, external_call=.true.) endif fluxes%fluxes_used = .false. - fluxes%dt_buoy_accum = US%s_to_T*dt_forcing + fluxes%dt_buoy_accum = dt_forcing if (use_waves) then call Update_Surface_Waves(grid, GV, US, time, time_step_ocean, waves_csp) @@ -478,9 +479,9 @@ program MOM6 ! This call steps the model over a time dt_forcing. Time1 = Master_Time ; Time = Master_Time if (offline_tracer_mode) then - call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) + call step_offline(forces, fluxes, sfc_state, Time1, US%T_to_s*dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) + call step_MOM(forces, fluxes, sfc_state, Time1, US%T_to_s*dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -493,51 +494,51 @@ program MOM6 if (diabatic_first) then if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(ntstep,n_max-(n-1)) - call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) + start_cycle=(n==1), end_cycle=.false., cycle_length=US%T_to_s*dt_forcing) endif - call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=US%T_to_s*dt_forcing) else - call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) + start_cycle=(n==1), end_cycle=.false., cycle_length=US%T_to_s*dt_forcing) if ((modulo(n,nts)==0) .or. (n==n_max)) then dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & - Time2 = Time2 - real_to_time(dtdia - dt_dyn) - call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & + Time2 = Time2 - real_to_time(US%T_to_s*(dtdia - dt_dyn)) + call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=US%T_to_s*dt_forcing) n_last_thermo = n endif endif t_elapsed_seg = t_elapsed_seg + dt_dyn - Time2 = Time1 + real_to_time(t_elapsed_seg) + Time2 = Time1 + real_to_time(US%T_to_s*t_elapsed_seg) enddo endif ! Time = Time + Time_step_ocean ! This is here to enable fractional-second time steps. elapsed_time = elapsed_time + dt_forcing - if (elapsed_time > 2e9) then + if (elapsed_time > 2.0e9*US%s_to_T) then ! This is here to ensure that the conversion from a real to an integer can be accurately ! represented in long runs (longer than ~63 years). It will also ensure that elapsed time ! does not lose resolution of order the timetype's resolution, provided that the timestep and ! tick are larger than 10-5 seconds. If a clock with a finer resolution is used, a smaller ! value would be required. - time_chg = real_to_time(elapsed_time) + time_chg = real_to_time(US%T_to_s*elapsed_time) segment_start_time = segment_start_time + time_chg - elapsed_time = elapsed_time - time_type_to_real(time_chg) + elapsed_time = elapsed_time - US%s_to_T*time_type_to_real(time_chg) endif if (elapsed_time_master) then - Master_Time = segment_start_time + real_to_time(elapsed_time) + Master_Time = segment_start_time + real_to_time(US%T_to_s*elapsed_time) else Master_Time = Master_Time + Time_step_ocean endif @@ -547,7 +548,7 @@ program MOM6 call write_cputime(Time, ns+ntstep-1, write_CPU_CSp, nmax) endif ; endif - call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) + call mech_forcing_diags(forces, US%T_to_s*dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) if (.not. offline_tracer_mode) then if (fluxes%fluxes_used) then diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 4365dd6296..ace61b3ed9 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -255,7 +255,7 @@ module MOM_forcing_type rigidity_ice_v => NULL() !< Depth-integrated lateral viscosity of ice shelves or sea ice at !! v-points [L4 Z-1 T-1 ~> m3 s-1] real :: dt_force_accum = -1.0 !< The amount of time over which the mechanical forcing fluxes - !! have been averaged [s]. + !! have been averaged [T ~> s]. logical :: net_mass_src_set = .false. !< If true, an estimate of net_mass_src has been provided. logical :: accumulate_p_surf = .false. !< If true, the surface pressure due to the atmosphere !! and various types of ice needs to be accumulated, and the From 60c1d7b81cd0dca98e1b968c57140f68eda1168c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 30 Nov 2022 15:48:00 -0500 Subject: [PATCH 076/629] +Rescaled real time arguments to step_MOM Rescaled the dimensions of real time arguments to step_MOM and several other MOM routines that are called from the driver code, including shelf_calc_flux, iceberg_forces, iceberg_fluxes and step_offline, along with the routines offline_advection_ale and offline_advection_layer that are called subsequently. As a part of the development of this commit, it was found that one of the scaling factors for setting fluxes%ustar_berg was missing with the mct_cap, and this has been corrected. All answers and output are bitwise identical, but the scaling for several arguments in publicly visible interfaces have changed. --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 42 +++++++++++-------- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 36 ++++++++-------- .../mct_cap/mom_surface_forcing_mct.F90 | 2 +- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 38 ++++++++--------- config_src/drivers/solo_driver/MOM_driver.F90 | 24 +++++------ .../solo_driver/MOM_surface_forcing.F90 | 2 +- src/core/MOM.F90 | 20 ++++----- src/core/MOM_forcing_type.F90 | 6 +-- src/ice_shelf/MOM_ice_shelf.F90 | 22 +++++----- src/ice_shelf/MOM_marine_ice.F90 | 6 +-- src/tracer/MOM_offline_main.F90 | 6 +-- 11 files changed, 105 insertions(+), 99 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index f8f7de6eae..049ae3d3df 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -519,7 +519,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) if (OS%icebergs_alter_ocean) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif if (do_thermo) then @@ -529,10 +529,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! Add ice shelf fluxes if (OS%use_ice_shelf) & - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) #ifdef _USE_GENERIC_TRACER call enable_averages(dt_coupling, OS%Time + Ocean_coupling_time_step, OS%diag) !Is this needed? @@ -547,10 +547,10 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda OS%grid, OS%US, OS%forcing_CSp, OS%sfc_state) if (OS%use_ice_shelf) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time,dt_coupling, OS%Ice_shelf_CSp) if (OS%icebergs_alter_ocean) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) call fluxes_accumulate(OS%flux_tmp, OS%fluxes, OS%grid, weight) #ifdef _USE_GENERIC_TRACER @@ -580,15 +580,21 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda Time1 = Time_seg_start if (OS%offline_tracer_mode .and. do_thermo) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, & + if (present(cycle_length)) then + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & - start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=cycle_length, & + start_cycle=start_cycle, end_cycle=end_cycle, cycle_length=OS%US%s_to_T*cycle_length, & reset_therm=Ocn_fluxes_used) + else + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & + Waves=OS%Waves, do_dynamics=do_dyn, do_thermodynamics=do_thermo, & + start_cycle=start_cycle, end_cycle=end_cycle, reset_therm=Ocn_fluxes_used) + endif elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else ! Step both the dynamics and thermodynamics with separate calls. n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -610,18 +616,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -636,9 +642,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (step_thermo) then ! Back up Time1 to the start of the thermodynamic segment. Time1 = Time1 - real_to_time(OS%US%T_to_s*(dtdia - dt_dyn)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif endif @@ -654,7 +660,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda if (do_thermo) OS%nstep_thermo = OS%nstep_thermo + 1 if (do_dyn) then - call mech_forcing_diags(OS%forces, OS%US%T_to_s*dt_coupling, OS%grid, OS%Time_dyn, OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time_dyn, OS%diag, OS%forcing_CSp%handles) endif if (OS%fluxes%fluxes_used .and. do_thermo) then diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index bdcefbc1b2..1a15760d00 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -512,17 +512,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! Add ice shelf fluxes if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif ! Fields that exist in both the forcing and mech_forcing types must be copied. @@ -543,17 +543,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) @@ -582,16 +582,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time if(OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) @@ -615,18 +615,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -641,9 +641,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif endif @@ -655,7 +655,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call mech_forcing_diags(OS%forces, OS%US%T_to_s*dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then call forcing_diagnostics(OS%fluxes, OS%sfc_state, OS%grid, OS%US, OS%Time, OS%diag, OS%forcing_CSp%handles) 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 8644e85616..b34f1a3b35 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -444,7 +444,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, end if if (associated(IOB%ustar_berg)) & - fluxes%ustar_berg(i,j) = US%m_to_Z * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) + fluxes%ustar_berg(i,j) = US%m_to_Z*US%T_to_s * IOB%ustar_berg(i-i0,j-j0) * G%mask2dT(i,j) if (associated(IOB%area_berg)) & fluxes%area_berg(i,j) = IOB%area_berg(i-i0,j-j0) * G%mask2dT(i,j) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 640fc32632..199ca27b49 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -548,17 +548,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & ! Add ice shelf fluxes if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%fluxes, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%fluxes, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif ! Fields that exist in both the forcing and mech_forcing types must be copied. @@ -576,17 +576,17 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (OS%use_ice_shelf) then if (do_thermo) & - call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, OS%US%T_to_s*dt_coupling, OS%Ice_shelf_CSp) + call shelf_calc_flux(OS%sfc_state, OS%flux_tmp, OS%Time, dt_coupling, OS%Ice_shelf_CSp) if (do_dyn) & call add_shelf_forces(OS%grid, OS%US, OS%Ice_shelf_CSp, OS%forces) endif if (OS%icebergs_alter_ocean) then if (do_dyn) & call iceberg_forces(OS%grid, OS%forces, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) if (do_thermo) & call iceberg_fluxes(OS%grid, OS%US, OS%flux_tmp, OS%use_ice_shelf, & - OS%sfc_state, OS%US%T_to_s*dt_coupling, OS%marine_ice_CSp) + OS%sfc_state, dt_coupling, OS%marine_ice_CSp) endif call forcing_accumulate(OS%flux_tmp, OS%forces, OS%fluxes, OS%grid, weight) @@ -615,16 +615,16 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & Master_time = OS%Time ; Time1 = OS%Time if (OS%offline_tracer_mode) then - call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp) + call step_offline(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp) elseif ((.not.do_thermo) .or. (.not.do_dyn)) then ! The call sequence is being orchestrated from outside of update_ocean_model. - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=do_thermo, do_thermodynamics=do_dyn, & reset_therm=Ocn_fluxes_used) - !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + !### What to do with these? , start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) elseif (OS%single_step_call) then - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, OS%US%T_to_s*dt_coupling, OS%MOM_CSp, Waves=OS%Waves) + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time1, dt_coupling, OS%MOM_CSp, Waves=OS%Waves) else n_max = 1 ; if (dt_coupling > OS%dt) n_max = ceiling(dt_coupling/OS%dt - 0.001) dt_dyn = dt_coupling / real(n_max) @@ -647,18 +647,18 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & "THERMO_SPANS_COUPLING and DIABATIC_FIRST.") if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(nts,n_max-(n-1)) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) endif - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) else - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dt_dyn, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dt_dyn, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_coupling) step_thermo = .false. if (thermo_does_span_coupling) then @@ -673,9 +673,9 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & if (step_thermo) then ! Back up Time2 to the start of the thermodynamic segment. Time2 = Time2 - set_time(int(floor(OS%US%T_to_s*(dtdia - dt_dyn) + 0.5))) - call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, OS%US%T_to_s*dtdia, OS%MOM_CSp, & + call step_MOM(OS%forces, OS%fluxes, OS%sfc_state, Time2, dtdia, OS%MOM_CSp, & Waves=OS%Waves, do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=OS%US%T_to_s*dt_coupling) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_coupling) endif endif @@ -687,7 +687,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & OS%Time = Master_time + Ocean_coupling_time_step OS%nstep = OS%nstep + 1 - call mech_forcing_diags(OS%forces, OS%US%T_to_s*dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) + call mech_forcing_diags(OS%forces, dt_coupling, OS%grid, OS%Time, OS%diag, OS%forcing_CSp%handles) if (OS%fluxes%fluxes_used) then if (cesm_coupled) then diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 565948af8b..974843c10f 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -462,7 +462,7 @@ program MOM6 endif if (use_ice_shelf) then - call shelf_calc_flux(sfc_state, fluxes, Time, US%T_to_s*dt_forcing, ice_shelf_CSp) + call shelf_calc_flux(sfc_state, fluxes, Time, dt_forcing, ice_shelf_CSp) call add_shelf_forces(grid, US, Ice_shelf_CSp, forces, external_call=.true.) endif fluxes%fluxes_used = .false. @@ -479,9 +479,9 @@ program MOM6 ! This call steps the model over a time dt_forcing. Time1 = Master_Time ; Time = Master_Time if (offline_tracer_mode) then - call step_offline(forces, fluxes, sfc_state, Time1, US%T_to_s*dt_forcing, MOM_CSp) + call step_offline(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp) elseif (single_step_call) then - call step_MOM(forces, fluxes, sfc_state, Time1, US%T_to_s*dt_forcing, MOM_CSp, Waves=Waves_CSP) + call step_MOM(forces, fluxes, sfc_state, Time1, dt_forcing, MOM_CSp, Waves=Waves_CSP) else n_max = 1 ; if (dt_forcing > dt) n_max = ceiling(dt_forcing/dt - 0.001) dt_dyn = dt_forcing / real(n_max) @@ -494,27 +494,27 @@ program MOM6 if (diabatic_first) then if (modulo(n-1,nts)==0) then dtdia = dt_dyn*min(ntstep,n_max-(n-1)) - call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=(n==1), end_cycle=.false., cycle_length=US%T_to_s*dt_forcing) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) endif - call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=US%T_to_s*dt_forcing) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) else - call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dt_dyn, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dt_dyn, MOM_CSp, & do_dynamics=.true., do_thermodynamics=.false., & - start_cycle=(n==1), end_cycle=.false., cycle_length=US%T_to_s*dt_forcing) + start_cycle=(n==1), end_cycle=.false., cycle_length=dt_forcing) if ((modulo(n,nts)==0) .or. (n==n_max)) then dtdia = dt_dyn*(n - n_last_thermo) ! Back up Time2 to the start of the thermodynamic segment. if (n > n_last_thermo+1) & Time2 = Time2 - real_to_time(US%T_to_s*(dtdia - dt_dyn)) - call step_MOM(forces, fluxes, sfc_state, Time2, US%T_to_s*dtdia, MOM_CSp, & + call step_MOM(forces, fluxes, sfc_state, Time2, dtdia, MOM_CSp, & do_dynamics=.false., do_thermodynamics=.true., & - start_cycle=.false., end_cycle=(n==n_max), cycle_length=US%T_to_s*dt_forcing) + start_cycle=.false., end_cycle=(n==n_max), cycle_length=dt_forcing) n_last_thermo = n endif endif @@ -548,7 +548,7 @@ program MOM6 call write_cputime(Time, ns+ntstep-1, write_CPU_CSp, nmax) endif ; endif - call mech_forcing_diags(forces, US%T_to_s*dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) + call mech_forcing_diags(forces, dt_forcing, grid, Time, diag, surface_forcing_CSp%handles) if (.not. offline_tracer_mode) then if (fluxes%fluxes_used) then diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 7fab9e5c8c..3ad06ddb8e 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1300,7 +1300,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US !#CTRL# SSS_mean(i,j) = 0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j)) !#CTRL# enddo ; enddo !#CTRL# call apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, fluxes%heat_added, & -!#CTRL# fluxes%vprec, day, US%T_to_s*dt, G, US, CS%ctrl_forcing_CSp) +!#CTRL# fluxes%vprec, day, dt, G, US, CS%ctrl_forcing_CSp) !#CTRL# endif call callTree_leave("buoyancy_forcing_from_data_override") diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b20940aeba..6c978b36f5 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -481,7 +481,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !! tracer and mass exchange forcing fields type(surface), target, intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_int_in !< time interval covered by this run segment [s]. + real, intent(in) :: time_int_in !< time interval covered by this run segment [T ~> s]. type(MOM_control_struct), intent(inout), target :: CS !< control structure from initialize_MOM type(Wave_parameters_CS), & optional, pointer :: Waves !< An optional pointer to a wave property CS @@ -496,7 +496,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !! treated as the last call to step_MOM in a !! time-stepping cycle; missing is like true. real, optional, intent(in) :: cycle_length !< The amount of time in a coupled time - !! stepping cycle [s]. + !! stepping cycle [T ~> s]. logical, optional, intent(in) :: reset_therm !< This indicates whether the running sums of !! thermodynamic quantities should be reset. !! If missing, this is like start_cycle. @@ -566,14 +566,14 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB u => CS%u ; v => CS%v ; h => CS%h - time_interval = US%s_to_T*time_int_in + time_interval = time_int_in do_dyn = .true. ; if (present(do_dynamics)) do_dyn = do_dynamics do_thermo = .true. ; if (present(do_thermodynamics)) do_thermo = do_thermodynamics if (.not.(do_dyn .or. do_thermo)) call MOM_error(FATAL,"Step_MOM: "//& "Both do_dynamics and do_thermodynamics are false, which makes no sense.") cycle_start = .true. ; if (present(start_cycle)) cycle_start = start_cycle cycle_end = .true. ; if (present(end_cycle)) cycle_end = end_cycle - cycle_time = time_interval ; if (present(cycle_length)) cycle_time = US%s_to_T*cycle_length + cycle_time = time_interval ; if (present(cycle_length)) cycle_time = cycle_length therm_reset = cycle_start ; if (present(reset_therm)) therm_reset = reset_therm call cpu_clock_begin(id_clock_ocean) @@ -629,7 +629,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ntstep = floor(dt_therm/dt + 0.001) elseif (.not.do_thermo) then dt_therm = CS%dt_therm - if (present(cycle_length)) dt_therm = min(CS%dt_therm, US%s_to_T*cycle_length) + if (present(cycle_length)) dt_therm = min(CS%dt_therm, cycle_length) ! ntstep is not used. else ntstep = MAX(1, MIN(n_max, floor(CS%dt_therm/dt + 0.001))) @@ -1649,7 +1649,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(surface), intent(inout) :: sfc_state !< surface ocean state type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval [s] + real, intent(in) :: time_interval !< time interval [T ~> s] type(MOM_control_struct), intent(inout) :: CS !< control structure from initialize_MOM ! Local pointers @@ -1695,9 +1695,9 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call cpu_clock_begin(id_clock_offline_tracer) call extract_offline_main(CS%offline_CSp, uhtr, vhtr, eatr, ebtr, h_end, accumulated_time, & vertical_time, dt_offline, dt_offline_vertical, skip_diffusion) - Time_end = increment_date(Time_start, seconds=floor(time_interval+0.001)) + Time_end = increment_date(Time_start, seconds=floor(US%T_to_s*time_interval+0.001)) - call enable_averaging(time_interval, Time_end, CS%diag) + call enable_averages(time_interval, Time_end, CS%diag) ! Check to see if this is the first iteration of the offline interval first_iter = (accumulated_time == real_to_time(0.0)) @@ -1707,7 +1707,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS if (do_vertical) vertical_time = accumulated_time + real_to_time(US%T_to_s*dt_offline_vertical) ! Increment the amount of time elapsed since last read and check if it's time to roll around - accumulated_time = accumulated_time + real_to_time(time_interval) + accumulated_time = accumulated_time + real_to_time(US%T_to_s*time_interval) last_iter = (accumulated_time >= real_to_time(US%T_to_s*dt_offline)) @@ -1814,7 +1814,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! Note that for the layer mode case, the calls to tracer sources and sinks is embedded in ! main_offline_advection_layer. Warning: this may not be appropriate for tracers that ! exchange with the atmosphere - if (abs(time_interval - US%T_to_s*dt_offline) > 1.0e-6) then + if (abs(time_interval - dt_offline) > 1.0e-6*US%s_to_T) then call MOM_error(FATAL, & "For offline tracer mode in a non-ALE configuration, dt_offline must equal time_interval") endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index ace61b3ed9..f005ac1a0e 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -10,7 +10,7 @@ module MOM_forcing_type use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled -use MOM_diag_mediator, only : enable_averages, enable_averaging, disable_averaging +use MOM_diag_mediator, only : enable_averages, disable_averaging use MOM_EOS, only : calculate_density_derivs, EOS_domain use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -2310,7 +2310,7 @@ end subroutine copy_back_forcing_fields !! fields registered as part of register_forcing_type_diags. subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) type(mech_forcing), target, intent(in) :: forces_in !< mechanical forcing input fields - real, intent(in) :: dt !< time step for the forcing [s] + real, intent(in) :: dt !< time step for the forcing [T ~> s] type(ocean_grid_type), intent(in) :: G !< grid type type(time_type), intent(in) :: time_end !< The end time of the diagnostic interval. type(diag_ctrl), intent(inout) :: diag !< diagnostic type @@ -2335,7 +2335,7 @@ subroutine mech_forcing_diags(forces_in, dt, G, time_end, diag, handles) endif is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - call enable_averaging(dt, time_end, diag) + call enable_averages(dt, time_end, diag) ! if (query_averaging_enabled(diag)) then if ((handles%id_taux > 0) .and. associated(forces%taux)) & diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index ab73675bb1..bde8e3e219 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -220,16 +220,16 @@ module MOM_ice_shelf !! formulation (optional to use just two equations). !! See \ref section_ICE_SHELF_equations subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) - type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that - !! describe the surface state of the ocean. The - !! intent is only inout to allow for halo updates. - type(forcing), target, intent(inout) :: fluxes_in !< structure containing pointers to any - !! possible thermodynamic or mass-flux forcing fields. - type(time_type), intent(in) :: Time !< Start time of the fluxes. - real, intent(in) :: time_step_in !< Length of time over which these fluxes - !! will be applied [s]. - type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned - !! by a previous call to initialize_ice_shelf. + type(surface), target, intent(inout) :: sfc_state_in !< A structure containing fields that + !! describe the surface state of the ocean. The + !! intent is only inout to allow for halo updates. + type(forcing), target, intent(inout) :: fluxes_in !< structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. + type(time_type), intent(in) :: Time !< Start time of the fluxes. + real, intent(in) :: time_step_in !< Length of time over which these fluxes + !! will be applied [T ~> s]. + type(ice_shelf_CS), pointer :: CS !< A pointer to the control structure returned + !! by a previous call to initialize_ice_shelf. ! Local variables type(ocean_grid_type), pointer :: G => NULL() !< The grid structure used by the ice shelf. @@ -326,7 +326,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) G => CS%grid ; US => CS%US ISS => CS%ISS - time_step = US%s_to_T*time_step_in + time_step = time_step_in if (CS%data_override_shelf_fluxes .and. CS%active_shelf_dynamics) then call data_override(G%Domain, 'shelf_sfc_mass_flux', fluxes_in%shelf_sfc_mass_flux, CS%Time, & diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index f24f9b1881..2a1b6d799b 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -48,7 +48,7 @@ subroutine iceberg_forces(G, forces, use_ice_shelf, sfc_state, time_step, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. - real, intent(in) :: time_step !< The coupling time step [s]. + real, intent(in) :: time_step !< The coupling time step [T ~> s]. type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: kv_rho_ice ! The viscosity of ice divided by its density [L4 Z-2 T-1 R-1 ~> m5 kg-1 s-1]. @@ -106,7 +106,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the ocean. logical, intent(in) :: use_ice_shelf !< If true, this configuration uses ice shelves. - real, intent(in) :: time_step !< The coupling time step [s]. + real, intent(in) :: time_step !< The coupling time step [T ~> s]. type(marine_ice_CS), pointer :: CS !< Pointer to the control structure for MOM_marine_ice real :: fraz ! refreezing rate [R Z T-1 ~> kg m-2 s-1] @@ -138,7 +138,7 @@ subroutine iceberg_fluxes(G, US, fluxes, use_ice_shelf, sfc_state, time_step, CS !Zero'ing out other fluxes under the tabular icebergs if (CS%berg_area_threshold >= 0.) then - I_dt_LHF = 1.0 / (US%s_to_T*time_step * CS%latent_heat_fusion) + I_dt_LHF = 1.0 / (time_step * CS%latent_heat_fusion) do j=jsd,jed ; do i=isd,ied if (fluxes%frac_shelf_h(i,j) > CS%berg_area_threshold) then ! Only applying for ice shelf covering most of cell. diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index bf06fc294e..2200a28c2b 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -205,7 +205,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C h_pre, uhtr, vhtr, converged) type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< time interval covered by this call [s] + real, intent(in) :: time_interval !< time interval covered by this call [T ~> s] type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -846,7 +846,7 @@ end subroutine offline_fw_fluxes_out_ocean subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, CS, h_pre, eatr, ebtr, uhtr, vhtr) type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type - real, intent(in) :: time_interval !< Offline transport time interval [s] + real, intent(in) :: time_interval !< Offline transport time interval [T ~> s] type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -894,7 +894,7 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - dt_iter = US%s_to_T * time_interval / real(max(1, CS%num_off_iter)) + dt_iter = time_interval / real(max(1, CS%num_off_iter)) x_before_y = CS%x_before_y do iter=1,CS%num_off_iter From 8ddd8543175af95b01d076bc035c5bdea5abe3b4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 2 Dec 2022 07:30:58 -0500 Subject: [PATCH 077/629] +Specify CVMix parameter units and rescale CVMix Specify the units of 5 parameters and applied dimensional rescaling to 14 MIN_THICKNESS or other length or viscosity parameters used in the CVMix code to appropriate units like [Z ~> m] or [Z2 T-1 ~> m2 s-1], with related changes to the rescaled units of several other internal variables. Also added comments describing a number of internal variables and their units in the MOM_CVMix and MOM_tidal_mixing code. The preliminary internal calculations in these routines now work in these [Z ~> m] units a bit longer before being recast into MKS units for the calls to the CVMix routines. The unused KPP runtime parameters CORRECT_SURFACE_LAYER_AVERAGE and FIRST_GUESS_SURFACE_LAYER_DEPTH have been marked as obsolete in comments of the code since 2015, and have now been formally obsoleted. All answers are bitwise identical, but there are changes to some MOM_parameter_doc files. --- src/diagnostics/MOM_obsolete_params.F90 | 3 +- .../vertical/MOM_CVMix_KPP.F90 | 316 +++++++++--------- .../vertical/MOM_CVMix_conv.F90 | 45 +-- .../vertical/MOM_CVMix_ddiff.F90 | 45 +-- .../vertical/MOM_CVMix_shear.F90 | 30 +- .../vertical/MOM_tidal_mixing.F90 | 58 ++-- 6 files changed, 248 insertions(+), 249 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index e686261fdf..19f3d87429 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -83,7 +83,8 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "ETA_TOLERANCE_AUX", only_warn=.true.) call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) - + call obsolete_real(param_file, "FIRST_GUESS_SURFACE_LAYER_DEPTH") + call obsolete_logical(param_file, "CORRECT_SURFACE_LAYER_AVERAGE") call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 1e068509b1..d73bba1551 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -73,10 +73,10 @@ module MOM_CVMix_KPP type, public :: KPP_CS ; private ! Parameters - real :: Ri_crit !< Critical bulk Richardson number (defines OBL depth) - real :: vonKarman !< von Karman constant (dimensionless) - real :: cs !< Parameter for computing velocity scale function (dimensionless) - real :: cs2 !< Parameter for multiplying by non-local term + real :: Ri_crit !< Critical bulk Richardson number (defines OBL depth) [nondim] + real :: vonKarman !< von Karman constant (dimensionless) [nondim] + real :: cs !< Parameter for computing velocity scale function (dimensionless) [nondim] + real :: cs2 !< Parameter for multiplying by non-local term [nondim] ! This is active for NLT_SHAPE_CUBIC_LMD only logical :: enhance_diffusion !< If True, add enhanced diffusivity at base of boundary layer. character(len=32) :: interpType !< Type of interpolation to compute bulk Richardson number @@ -85,12 +85,13 @@ module MOM_CVMix_KPP logical :: computeMoninObukhov !< If True, compute Monin-Obukhov limit for OBLdepth logical :: passiveMode !< If True, makes KPP passive meaning it does NOT alter the diffusivity real :: deepOBLoffset !< If non-zero, is a distance from the bottom that the OBL can not - !! penetrate through [m] - real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL [m] + !! penetrate through [Z ~> m] + real :: minOBLdepth !< If non-zero, is a minimum depth for the OBL [Z ~> m] real :: surf_layer_ext !< Fraction of OBL depth considered in the surface layer [nondim] - real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix calculation [m2 s-2] + real :: minVtsqr !< Min for the squared unresolved velocity used in Rib CVMix + !! calculation [L2 T-2 ~> m2 s-2] logical :: fixedOBLdepth !< If True, will fix the OBL depth at fixedOBLdepth_value - real :: fixedOBLdepth_value !< value for the fixed OBL depth when fixedOBLdepth==True. + real :: fixedOBLdepth_value !< value for the fixed OBL depth when fixedOBLdepth==True [Z ~> m] logical :: debug !< If True, calculate checksums and write debugging information character(len=30) :: MatchTechnique !< Method used in CVMix for setting diffusivity and NLT profile functions integer :: NLT_shape !< MOM6 over-ride of CVMix NLT shape function @@ -103,21 +104,17 @@ module MOM_CVMix_KPP !! If False, will replace initial diffusivity wherever KPP diffusivity !! is non-zero. real :: min_thickness !< A minimum thickness used to avoid division by small numbers - !! in the vicinity of vanished layers. - ! smg: obsolete below - logical :: correctSurfLayerAvg !< If true, applies a correction to the averaging of surface layer properties - real :: surfLayerDepth !< A guess at the depth of the surface layer (which should 0.1 of OBLdepth) [m] - ! smg: obsolete above + !! in the vicinity of vanished layers [Z ~> m] integer :: SW_METHOD !< Sets method for using shortwave radiation in surface buoyancy flux logical :: LT_K_Enhancement !< Flags if enhancing mixing coefficients due to LT integer :: LT_K_Shape !< Integer for constant or shape function enhancement integer :: LT_K_Method !< Integer for mixing coefficients LT method - real :: KPP_K_ENH_FAC !< Factor to multiply by K if Method is CONSTANT + real :: KPP_K_ENH_FAC !< Factor to multiply by K if Method is CONSTANT [nondim] logical :: LT_Vt2_Enhancement !< Flags if enhancing Vt2 due to LT integer :: LT_VT2_METHOD !< Integer for Vt2 LT method - real :: KPP_VT2_ENH_FAC !< Factor to multiply by VT2 if Method is CONSTANT + real :: KPP_VT2_ENH_FAC !< Factor to multiply by VT2 if Method is CONSTANT [nondim] logical :: STOKES_MIXING !< Flag if model is mixing down Stokes gradient - !! This is relavent for which current to use in RiB + !! This is relevant for which current to use in RiB !> CVMix parameters type(CVMix_kpp_params_type), pointer :: KPP_params => NULL() @@ -143,15 +140,15 @@ module MOM_CVMix_KPP !>@} ! Diagnostics arrays - real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of OBL [m] + real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [m] real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [m] without smoothing - real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent + real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent [nondim] real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [m] - real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP + real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP [nondim] real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [m2 s-2] - real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer (dimensionless) - real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) + real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer [nondim] + real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) [nondim] real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [m s-1] real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [s-1] real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] @@ -161,10 +158,10 @@ module MOM_CVMix_KPP real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [m2 s-1] real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [C ~> degC] real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [S ~> ppt] - real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [m s-1] - real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [m s-1] - real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient - real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 + real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [L T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: Vsurf !< j-velocity of surface layer [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: EnhK !< Enhancement for mixing coefficient [nondim] + real, allocatable, dimension(:,:,:) :: EnhVt2 !< Enhancement for Vt2 [nondim] end type KPP_CS @@ -194,8 +191,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) # include "version_variable.h" character(len=40) :: mdl = 'MOM_CVMix_KPP' !< name of this module character(len=20) :: string !< local temporary string - character(len=20) :: langmuir_mixing_opt = 'NONE' !< langmuir mixing opt to be passed to CVMix, e.g., LWF16 - character(len=20) :: langmuir_entrainment_opt = 'NONE' !< langmuir entrainment opt to be passed to CVMix, e.g., LWF16 + character(len=20) :: langmuir_mixing_opt = 'NONE' !< Langmuir mixing option to be passed to CVMix, e.g., LWF16 + character(len=20) :: langmuir_entrainment_opt = 'NONE' !< Langmuir entrainment option to be + !! passed to CVMix, e.g., LWF16 logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local logical :: lnoDGat1=.false. !< True => G'(1) = 0 (shape function) !! False => compute G'(1) as in LMD94 @@ -228,8 +226,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'purely for diagnostic purposes.', & default=.not. CS%passiveMode) call get_param(paramFile, mdl, 'N_SMOOTH', CS%n_smooth, & - 'The number of times the 1-1-4-1-1 Laplacian filter is applied on '// & - 'OBL depth.', & + 'The number of times the 1-1-4-1-1 Laplacian filter is applied on OBL depth.', & default=0) if (CS%n_smooth > G%domain%nihalo) then call MOM_error(FATAL,'KPP smoothing number (N_SMOOTH) cannot be greater than NIHALO.') @@ -277,7 +274,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) call get_param(paramFile, mdl, 'DEEP_OBL_OFFSET', CS%deepOBLoffset, & 'If non-zero, the distance above the bottom to which the OBL is clipped '// & 'if it would otherwise reach the bottom. The smaller of this and 0.1D is used.', & - units='m',default=0.) + units='m', default=0., scale=US%m_to_Z) call get_param(paramFile, mdl, 'FIXED_OBLDEPTH', CS%fixedOBLdepth, & 'If True, fix the OBL depth to FIXED_OBLDEPTH_VALUE '// & 'rather than using the OBL depth from CVMix. '// & @@ -287,32 +284,18 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Value for the fixed OBL depth when fixedOBLdepth==True. '// & 'This parameter is for just for testing purposes. '// & 'It will over-ride the OBLdepth computed from CVMix.', & - units='m',default=30.0) + units='m', default=30.0, scale=US%m_to_Z) call get_param(paramFile, mdl, 'SURF_LAYER_EXTENT', CS%surf_layer_ext, & 'Fraction of OBL depth considered in the surface layer.', & - units='nondim',default=0.10) + units='nondim', default=0.10) call get_param(paramFile, mdl, 'MINIMUM_OBL_DEPTH', CS%minOBLdepth, & 'If non-zero, a minimum depth to use for KPP OBL depth. Independent of '// & 'this parameter, the OBL depth is always at least as deep as the first layer.', & - units='m',default=0.) + units='m', default=0., scale=US%m_to_Z) call get_param(paramFile, mdl, 'MINIMUM_VT2', CS%minVtsqr, & 'Min of the unresolved velocity Vt2 used in Rib CVMix calculation.\n'// & 'Scaling: MINIMUM_VT2 = const1*d*N*ws, with d=1m, N=1e-5/s, ws=1e-6 m/s.', & - units='m2/s2',default=1e-10) - -! smg: for removal below - call get_param(paramFile, mdl, 'CORRECT_SURFACE_LAYER_AVERAGE', CS%correctSurfLayerAvg, & - 'If true, applies a correction step to the averaging of surface layer '// & - 'properties. This option is obsolete.', default=.False.) - if (CS%correctSurfLayerAvg) & - call MOM_error(FATAL,'Correct surface layer average disabled in code. To recover \n'// & - ' feature will require code intervention.') - call get_param(paramFile, mdl, 'FIRST_GUESS_SURFACE_LAYER_DEPTH', CS%surfLayerDepth, & - 'The first guess at the depth of the surface layer used for averaging '// & - 'the surface layer properties. If =0, the top model level properties '// & - 'will be used for the surface layer. If CORRECT_SURFACE_LAYER_AVERAGE=True, a '// & - 'subsequent correction is applied. This parameter is obsolete', units='m', default=0.) -! smg: for removal above + units='m2/s2', default=1e-10, scale=US%m_s_to_L_T**2) call get_param(paramFile, mdl, 'NLT_SHAPE', string, & 'MOM6 method to set nonlocal transport profile. '// & @@ -382,7 +365,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) call get_param(paramFile, mdl, 'CVMix_ZERO_H_WORK_AROUND', CS%min_thickness, & 'A minimum thickness used to avoid division by small numbers in the vicinity '// & 'of vanished layers. This is independent of MIN_THICKNESS used in other parts of MOM.', & - units='m', default=0.) + units='m', default=0., scale=US%m_to_Z) !/BGR: New options for including Langmuir effects !/ 1. Options related to enhancing the mixing coefficient @@ -430,9 +413,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) "Unrecognized KPP_LT_K_METHOD option: "//trim(string)) end select if (CS%LT_K_METHOD==LT_K_MODE_CONSTANT) then - call get_param(paramFile, mdl, "KPP_K_ENH_FAC",CS%KPP_K_ENH_FAC , & - 'Constant value to enhance mixing coefficient in KPP.', & - default=1.0) + call get_param(paramFile, mdl, "KPP_K_ENH_FAC", CS%KPP_K_ENH_FAC, & + 'Constant value to enhance mixing coefficient in KPP.', & + units="nondim", default=1.0) endif endif !/ 2. Options related to enhancing the unresolved Vt2/entrainment in Rib @@ -470,9 +453,9 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) "Unrecognized KPP_LT_VT2_METHOD option: "//trim(string)) end select if (CS%LT_VT2_METHOD==LT_VT2_MODE_CONSTANT) then - call get_param(paramFile, mdl, "KPP_VT2_ENH_FAC",CS%KPP_VT2_ENH_FAC , & + call get_param(paramFile, mdl, "KPP_VT2_ENH_FAC", CS%KPP_VT2_ENH_FAC, & 'Constant value to enhance VT2 in KPP.', & - default=1.0) + units="nondim", default=1.0) endif endif @@ -481,8 +464,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) call CVMix_init_kpp( Ri_crit=CS%Ri_crit, & - minOBLdepth=CS%minOBLdepth, & - minVtsqr=CS%minVtsqr, & + minOBLdepth=US%Z_to_m*CS%minOBLdepth, & + minVtsqr=US%L_T_to_m_s**2*CS%minVtsqr, & vonKarman=CS%vonKarman, & surf_layer_ext=CS%surf_layer_ext, & interp_type=CS%interpType, & @@ -547,13 +530,17 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) CS%id_NLTs = register_diag_field('ocean_model', 'KPP_NLtransport_salt', diag%axesTi, Time, & 'Non-local tranpsort (Cs*G(sigma)) for scalars, as calculated by [CVMix] KPP', 'nondim') CS%id_Tsurf = register_diag_field('ocean_model', 'KPP_Tsurf', diag%axesT1, Time, & - 'Temperature of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'C', conversion=US%C_to_degC) + 'Temperature of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'C', conversion=US%C_to_degC) CS%id_Ssurf = register_diag_field('ocean_model', 'KPP_Ssurf', diag%axesT1, Time, & - 'Salinity of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'ppt', conversion=US%S_to_ppt) + 'Salinity of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'ppt', conversion=US%S_to_ppt) CS%id_Usurf = register_diag_field('ocean_model', 'KPP_Usurf', diag%axesCu1, Time, & - 'i-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') + 'i-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'm/s', conversion=US%L_T_to_m_s) CS%id_Vsurf = register_diag_field('ocean_model', 'KPP_Vsurf', diag%axesCv1, Time, & - 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', 'm/s') + 'j-component flow of surface layer (10% of OBL depth) as passed to [CVMix] KPP', & + 'm/s', conversion=US%L_T_to_m_s) CS%id_EnhK = register_diag_field('ocean_model', 'EnhK', diag%axesTI, Time, & 'Langmuir number enhancement to K as used by [CVMix] KPP','nondim') CS%id_EnhVt2 = register_diag_field('ocean_model', 'EnhVt2', diag%axesTL, Time, & @@ -616,7 +603,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier -! Local variables + ! Local variables integer :: i, j, k ! Loop indices real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) @@ -624,14 +611,16 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & real, dimension( GV%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces [m2 s-1] real, dimension( GV%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] - real :: surfFricVel, surfBuoyFlux - real :: sigma, sigmaRatio + real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] + real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: sigma ! Fractional vertical position within the boundary layer [nondim] + real :: sigmaRatio ! A cubic function of sigma [nondim] real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] - real :: dh ! The local thickness used for calculating interface positions [m] - real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] ! For Langmuir Calculations - real :: LangEnhK ! Langmuir enhancement for mixing coefficient + real :: LangEnhK ! Langmuir enhancement for mixing coefficient [nondim] if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_calculate: The Waves control structure must be associated if STOKES_MIXING is True.") @@ -672,17 +661,17 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo ! k-loop finishes surfBuoyFlux = buoy_scale*buoyFlux(i,j,1) ! This is only used in kpp_compute_OBL_depth to limit - ! h to Monin-Obukov (default is false, ie. not used) + ! h to Monin-Obukhov (default is false, ie. not used) ! Call CVMix/KPP to obtain OBL diffusivities, viscosities and non-local transports @@ -820,8 +809,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! we apply nonLocalTrans in subroutines ! KPP_NonLocalTransport_temp and KPP_NonLocalTransport_saln - nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temp - nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! saln + nonLocalTransHeat(i,j,:) = nonLocalTrans(:,1) ! temperature + nonLocalTransScalar(i,j,:) = nonLocalTrans(:,2) ! salinity ! set the KPP diffusivity and viscosity to zero for testing purposes if (CS%KPPzeroDiffusivity) then @@ -906,48 +895,54 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult!< Langmuir enhancement factor + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor ! Local variables - integer :: i, j, k, km1 ! Loop indices + ! Variables in MKS units for passing to CVMix routines real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [s-2] real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] - real, dimension( GV%ke ) :: surfBuoyFlux2 + real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] + real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] + real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] + real :: Coriolis ! Coriolis parameter at tracer points [s-1] + real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] - ! for EOS calculation + ! Variables for EOS calculations real, dimension( 3*GV%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] real, dimension( 3*GV%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] real, dimension( 3*GV%ke ) :: Temp_1D ! A column of temperatures [C ~> degC] real, dimension( 3*GV%ke ) :: Salt_1D ! A column of salinities [S ~> ppt] - real :: surfFricVel, surfBuoyFlux, Coriolis - real :: GoRho ! Gravitational acceleration divided by density in MKS units [m R-1 s-2 ~> m4 kg-1 s-2] - real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] - real :: Uk, Vk - - real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] - real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth. - real :: hTot ! Running sum of thickness used in the surface layer average [m] - real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] - real :: delH ! Thickness of a layer [m] - real :: surfHtemp, surfTemp ! Integral and average of temp over the surface layer [C ~> degC] - real :: surfHsalt, surfSalt ! Integral and average of saln over the surface layer [S ~> ppt] - real :: surfHu, surfU ! Integral and average of u over the surface layer - real :: surfHv, surfV ! Integral and average of v over the surface layer - real :: dh ! The local thickness used for calculating interface positions [m] - real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] - integer :: kk, ksfc, ktmp + real :: GoRho ! Gravitational acceleration in MKS units divided by density [m s-2 R-1 ~> m4 kg-1 s-2] + real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] + real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] + real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] + real :: hTot ! Running sum of thickness used in the surface layer average [Z ~> m] + real :: buoy_scale ! A unit conversion factor for buoyancy fluxes [m2 T3 L-2 s-3 ~> 1] + real :: delH ! Thickness of a layer [Z ~> m] + real :: surfTemp ! Average of temperature over the surface layer [C ~> degC] + real :: surfHtemp ! Integral of temperature over the surface layer [Z C ~> m degC] + real :: surfSalt ! Average of salinity over the surface layer [S ~> ppt] + real :: surfHsalt ! Integral of salinity over the surface layer [Z S ~> m ppt] + real :: surfHu, surfHv ! Integral of u and v over the surface layer [Z L T-1 ~> m2 s-1] + real :: surfU, surfV ! Average of u and v over the surface layer [Z T-1 ~> m s-1] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] ! For Langmuir Calculations - real :: LangEnhVt2 ! Langmuir enhancement for unresolved shear - real, dimension(GV%ke) :: U_H, V_H - real :: MLD_GUESS, LA - real :: surfHuS, surfHvS, surfUs, surfVs + real :: LangEnhVt2 ! Langmuir enhancement for unresolved shear [nondim] + real, dimension(GV%ke) :: U_H, V_H ! Velocities at tracer points [L T-1 ~> m s-1] + real :: MLD_guess ! A guess at the mixed layer depth for calculating the Langmuir number [Z ~> m] + real :: LA ! The local Langmuir number [nondim] + real :: surfHuS, surfHvS ! Stokes drift velocities integrated over the boundary layer [Z L T-1 ~> m2 s-1] + real :: surfUs, surfVs ! Stokes drift velocities averaged over the boundary layer [Z T-1 ~> m s-1] + + integer :: i, j, k, km1, kk, ksfc, ktmp ! Loop indices if (CS%Stokes_Mixing .and. .not.associated(Waves)) call MOM_error(FATAL, & "KPP_compute_BLD: The Waves control structure must be associated if STOKES_MIXING is True.") @@ -971,7 +966,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & - !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_GUESS, LA, rho_1D, & + !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, & !$OMP BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & @@ -983,8 +978,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (G%mask2dT(i,j)==0.) cycle do k=1,GV%ke - U_H(k) = 0.5 * US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) - V_H(k) = 0.5 * US%L_T_to_m_s*(v(i,j,k)+v(i,j-1,k)) + U_H(k) = 0.5 * (u(i,j,k)+u(i-1,j,k)) + V_H(k) = 0.5 * (v(i,j,k)+v(i,j-1,k)) enddo ! things independent of position within the column @@ -1004,36 +999,36 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh ! find ksfc for cell where "surface layer" sits - SLdepth_0d = CS%surf_layer_ext*max( max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) + SLdepth_0d = CS%surf_layer_ext*max( US%m_to_Z*max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) ksfc = k do ktmp = 1,k - if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then + if (-1.0*iFaceHeight(ktmp+1) >= US%Z_to_m*SLdepth_0d) then ksfc = ktmp exit endif enddo - ! average temp, saln, u, v over surface layer - ! use C-grid average to get u,v on T-points. - surfHtemp=0.0 - surfHsalt=0.0 - surfHu =0.0 - surfHv =0.0 - surfHuS =0.0 - surfHvS =0.0 - hTot =0.0 + ! average temperature, salinity, u and v over surface layer + ! use C-grid average to get u and v on T-points. + surfHtemp = 0.0 + surfHsalt = 0.0 + surfHu = 0.0 + surfHv = 0.0 + surfHuS = 0.0 + surfHvS = 0.0 + hTot = 0.0 do ktmp = 1,ksfc ! SLdepth_0d can be between cell interfaces - delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_m ) + delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_Z ) ! surface layer thickness hTot = hTot + delH @@ -1041,11 +1036,11 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! surface averaged fields surfHtemp = surfHtemp + Temp(i,j,ktmp) * delH surfHsalt = surfHsalt + Salt(i,j,ktmp) * delH - surfHu = surfHu + 0.5*US%L_T_to_m_s*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH - surfHv = surfHv + 0.5*US%L_T_to_m_s*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH + surfHu = surfHu + 0.5*(u(i,j,ktmp)+u(i-1,j,ktmp)) * delH + surfHv = surfHv + 0.5*(v(i,j,ktmp)+v(i,j-1,ktmp)) * delH if (CS%Stokes_Mixing) then - surfHus = surfHus + 0.5*US%L_T_to_m_s*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH - surfHvs = surfHvs + 0.5*US%L_T_to_m_s*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH + surfHus = surfHus + 0.5*(Waves%US_x(i,j,ktmp)+Waves%US_x(i-1,j,ktmp)) * delH + surfHvs = surfHvs + 0.5*(Waves%US_y(i,j,ktmp)+Waves%US_y(i,j-1,ktmp)) * delH endif enddo @@ -1056,23 +1051,22 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl surfUs = surfHus / hTot surfVs = surfHvs / hTot - ! vertical shear between present layer and - ! surface layer averaged surfU,surfV. + ! vertical shear between present layer and surface layer averaged surfU and surfV. ! C-grid average to get Uk and Vk on T-points. - Uk = 0.5*US%L_T_to_m_s*(u(i,j,k)+u(i-1,j,k)) - surfU - Vk = 0.5*US%L_T_to_m_s*(v(i,j,k)+v(i,j-1,k)) - surfV + Uk = 0.5*(u(i,j,k)+u(i-1,j,k)) - surfU + Vk = 0.5*(v(i,j,k)+v(i,j-1,k)) - surfV if (CS%Stokes_Mixing) then ! If momentum is mixed down the Stokes drift gradient, then ! the Stokes drift must be included in the bulk Richardson number ! calculation. - Uk = Uk + (0.5*US%L_T_to_m_s*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) - Vk = Vk + (0.5*US%L_T_to_m_s*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) + Uk = Uk + (0.5*(Waves%Us_x(i,j,k)+Waves%US_x(i-1,j,k)) - surfUs ) + Vk = Vk + (0.5*(Waves%Us_y(i,j,k)+Waves%Us_y(i,j-1,k)) - surfVs ) endif - deltaU2(k) = Uk**2 + Vk**2 + deltaU2(k) = US%L_T_to_m_s**2 * (Uk**2 + Vk**2) - ! pressure, temp, and saln for EOS + ! pressure, temperature, and salinity for calling the equation of state ! kk+1 = surface fields ! kk+2 = k fields ! kk+3 = km1 fields @@ -1098,7 +1092,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl enddo ! k-loop finishes if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then - MLD_GUESS = max( 1.*US%m_to_Z, abs(US%m_to_Z*CS%OBLdepthprev(i,j) ) ) + MLD_guess = max( 1.*US%m_to_Z, abs(US%m_to_Z*CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) CS%La_SL(i,j)=LA @@ -1127,12 +1121,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass ! sigma=CS%surf_layer_ext for this calculation. call CVMix_kpp_compute_turbulent_scales( & - CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext - -cellHeight, & ! (in) Assume here that OBL depth [m] = -cellHeight(k) - surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] - surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] - w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] - CVMix_kpp_params_user=CS%KPP_params ) + CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext + -cellHeight, & ! (in) Assume here that OBL depth [m] = -cellHeight(k) + surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] + surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] + CVMix_kpp_params_user=CS%KPP_params ) ! Determine the enhancement factor for unresolved shear IF (CS%LT_VT2_ENHANCEMENT) then @@ -1172,25 +1166,25 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl call CVMix_kpp_compute_OBL_depth( & - BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces [m] - CS%OBLdepth(i,j), & ! (out) OBL depth [m] - CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers [m] - surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] - surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] - Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] - CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + BulkRi_1d, & ! (in) Bulk Richardson number + iFaceHeight, & ! (in) Height of interfaces [m] + CS%OBLdepth(i,j), & ! (out) OBL depth [m] + CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent + zt_cntr=cellHeight, & ! (in) Height of cell centers [m] + surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] + surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] + Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] + CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters ! A hack to avoid KPP reaching the bottom. It was needed during development ! because KPP was unable to handle vanishingly small layers near the bottom. if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset,-0.1*iFaceHeight(GV%ke+1)) + zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(US%Z_to_m*CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) endif ! apply some constraints on OBLdepth - if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value + if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = US%Z_to_m*CS%fixedOBLdepth_value CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) @@ -1211,14 +1205,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! recompute wscale for diagnostics, now that we in fact know boundary layer depth !BGR consider if LTEnhancement is wanted for diagnostics if (CS%id_Ws > 0) then - call CVMix_kpp_compute_turbulent_scales( & + call CVMix_kpp_compute_turbulent_scales( & -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate CS%OBLdepth(i,j), & ! (in) OBL depth [m] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters - CS%Ws(i,j,:) = Ws_1d(:) + CS%Ws(i,j,:) = Ws_1d(:) endif ! Diagnostics @@ -1229,7 +1223,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU - if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfv + if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV enddo enddo @@ -1252,17 +1246,18 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) ! BLD smoothing: - if (CS%n_smooth > 0) call KPP_smooth_BLD(CS,G,GV,h) + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, h) end subroutine KPP_compute_BLD !> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise -subroutine KPP_smooth_BLD(CS,G,GV,h) +subroutine KPP_smooth_BLD(CS, G, GV, US, h) ! Arguments type(KPP_CS), pointer :: CS !< Control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] ! local @@ -1272,8 +1267,8 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] ! (negative in the ocean) real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] - real :: dh ! The local thickness used for calculating interface positions [m] - real :: hcorr ! A cumulative correction arising from inflation of vanished layers [m] + real :: dh ! The local thickness used for calculating interface positions [Z ~> m] + real :: hcorr ! A cumulative correction arising from inflation of vanished layers [Z ~> m] integer :: i, j, k, s call cpu_clock_begin(id_clock_KPP_smoothing) @@ -1288,7 +1283,7 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) OBLdepth_prev = CS%OBLdepth ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, CS, h, OBLdepth_prev) & + !$OMP parallel do default(none) shared(G, GV, US, CS, h, OBLdepth_prev) & !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1301,12 +1296,12 @@ subroutine KPP_smooth_BLD(CS,G,GV,h) do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo ! compute weights @@ -1347,9 +1342,9 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Boundary layer depth [Z ~> m] or other units real, optional, intent(in) :: m_to_BLD_units !< A conversion factor from meters - !! to the desired units for BLD + !! to the desired units for BLD [various] ! Local variables - real :: scale ! A dimensional rescaling factor + real :: scale ! A dimensional rescaling factor in [Z m-1 ~> 1] or other units. integer :: i,j scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = m_to_BLD_units @@ -1376,11 +1371,12 @@ subroutine KPP_NonLocalTransport(CS, G, GV, h, nonLocalTrans, surfFlux, & type(tracer_type), pointer, intent(in) :: tr_ptr !< tracer_type has diagnostic ids on it real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: scalar !< Scalar (scalar units [conc]) real, optional, intent(in) :: flux_scale !< Scale factor to get surfFlux - !! into proper units + !! into proper units [various] integer :: i, j, k real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dtracer ! Rate of tracer change [conc T-1 ~> conc s-1] - real, dimension(SZI_(G),SZJ_(G)) :: surfFlux_loc + real, dimension(SZI_(G),SZJ_(G)) :: surfFlux_loc ! An optionally rescaled surface flux of the scalar + ! in [conc H T-1 ~> conc m s-1 or conc kg m-2 s-1] or other units ! term used to scale if (present(flux_scale)) then diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index 58d6e3417a..a0b24dee70 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -27,14 +27,14 @@ module MOM_CVMix_conv type, public :: CVMix_conv_cs ; private ! Parameters - real :: kd_conv_const !< diffusivity constant used in convective regime [m2 s-1] - real :: kv_conv_const !< viscosity constant used in convective regime [m2 s-1] + real :: kd_conv_const !< diffusivity constant used in convective regime [Z2 T-1 ~> m2 s-1] + real :: kv_conv_const !< viscosity constant used in convective regime [Z2 T-1 ~> m2 s-1] real :: bv_sqr_conv !< Threshold for squared buoyancy frequency - !! needed to trigger Brunt-Vaisala parameterization [s-2] - real :: min_thickness !< Minimum thickness allowed [m] + !! needed to trigger Brunt-Vaisala parameterization [T-2 ~> s-2] + real :: min_thickness !< Minimum thickness allowed [Z ~> m] logical :: debug !< If true, turn on debugging - ! Daignostic handles and pointers + ! Diagnostic handles and pointers type(diag_ctrl), pointer :: diag => NULL() !< Pointer to diagnostics control structure !>@{ Diagnostics handles integer :: id_N2 = -1, id_kd_conv = -1, id_kv_conv = -1 @@ -55,13 +55,13 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(CVMix_conv_cs), intent(inout) :: CS !< CVMix convetction control struct + type(CVMix_conv_cs), intent(inout) :: CS !< CVMix convection control structure real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities. logical :: useEPBL !< If True, use the ePBL boundary layer scheme. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" ! Read parameters call get_param(param_file, mdl, "USE_CVMix_CONVECTION", CVMix_conv_init, default=.false., do_not_log=.true.) @@ -90,7 +90,8 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", scale=US%m_to_Z, default=0.001, do_not_log=.True.) call openParameterBlock(param_file,'CVMix_CONVECTION') @@ -102,12 +103,12 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'KD_CONV', CS%kd_conv_const, & "Diffusivity used in convective regime. Corresponding viscosity "//& "(KV_CONV) will be set to KD_CONV * PRANDTL_CONV.", & - units='m2/s', default=1.00) + units='m2/s', default=1.00, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, 'BV_SQR_CONV', CS%bv_sqr_conv, & "Threshold for squared buoyancy frequency needed to trigger "//& "Brunt-Vaisala parameterization.", & - units='1/s^2', default=0.0) + units='1/s^2', default=0.0, scale=US%T_to_s**2) call closeParameterBlock(param_file) @@ -123,10 +124,10 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) CS%id_kv_conv = register_diag_field('ocean_model', 'kv_conv', diag%axesTi, Time, & 'Additional viscosity added by MOM_CVMix_conv module', 'm2/s', conversion=US%Z2_T_to_m2_s) - call CVMix_init_conv(convect_diff=CS%kd_conv_const, & - convect_visc=CS%kv_conv_const, & + call CVMix_init_conv(convect_diff=US%Z2_T_to_m2_s*CS%kd_conv_const, & + convect_visc=US%Z2_T_to_m2_s*CS%kv_conv_const, & lBruntVaisala=.true., & - BVsqr_convect=CS%bv_sqr_conv) + BVsqr_convect=US%s_to_T**2*CS%bv_sqr_conv) end function CVMix_conv_init @@ -139,7 +140,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) 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 !< Thermodynamics structure. - type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control struct + type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: Kd !< Diapycnal diffusivity at each interface that @@ -167,14 +168,14 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) kd_conv, & !< Diffusivity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] kv_conv, & !< Viscosity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] N2_3d !< Squared buoyancy frequency for diagnostics [T-2 ~> s-2] - integer :: kOBL !< level of OBL extent - real :: g_o_rho0 ! Gravitational acceleration divided by density times unit convserion factors + integer :: kOBL !< level of ocean boundary layer extent + real :: g_o_rho0 ! Gravitational acceleration divided by density times unit conversion factors ! [Z s-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] real :: hbl_KPP ! The depth of the ocean boundary as used by KPP [m] real :: dz ! A thickness [Z ~> m] - real :: dh, hcorr ! Two thicknesses [m] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] integer :: i, j, k g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 @@ -213,12 +214,12 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, in the units used by CVMix. + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo ! gets index of the level and interface above hbl diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 413b87f631..6e2c76ba8d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -28,14 +28,14 @@ module MOM_CVMix_ddiff ! Parameters real :: strat_param_max !< maximum value for the stratification parameter [nondim] real :: kappa_ddiff_s !< leading coefficient in formula for salt-fingering regime - !! for salinity diffusion [m2 s-1] + !! for salinity diffusion [Z2 T-1 ~> m2 s-1] real :: ddiff_exp1 !< interior exponent in salt-fingering regime formula [nondim] real :: ddiff_exp2 !< exterior exponent in salt-fingering regime formula [nondim] - real :: mol_diff !< molecular diffusivity [m2 s-1] + real :: mol_diff !< molecular diffusivity [Z2 T-1 ~> m2 s-1] real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime [nondim] - real :: min_thickness !< Minimum thickness allowed [m] + real :: min_thickness !< Minimum thickness allowed [Z ~> m] character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") logical :: debug !< If true, turn on debugging @@ -57,8 +57,8 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(CVMix_ddiff_cs), pointer :: CS !< This module's control structure. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" if (associated(CS)) then call MOM_error(WARNING, "CVMix_ddiff_init called with an associated "// & @@ -82,7 +82,8 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, do_not_log=.True.) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", scale=US%m_to_Z, default=0.001, do_not_log=.True.) call openParameterBlock(param_file,'CVMIX_DDIFF') @@ -91,8 +92,8 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) units="nondim", default=2.55) call get_param(param_file, mdl, "KAPPA_DDIFF_S", CS%kappa_ddiff_s, & - "Leading coefficient in formula for salt-fingering regime "//& - "for salinity diffusion.", units="m2 s-1", default=1.0e-4) + "Leading coefficient in formula for salt-fingering regime for salinity diffusion.", & + units="m2 s-1", default=1.0e-4, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DDIFF_EXP1", CS%ddiff_exp1, & "Interior exponent in salt-fingering regime formula.", & @@ -116,7 +117,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "MOL_DIFF", CS%mol_diff, & "Molecular diffusivity used in CVMix double diffusion.", & - units="m2 s-1", default=1.5e-6) + units="m2 s-1", default=1.5e-6, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "DIFF_CONV_TYPE", CS%diff_conv_type, & "type of diffusive convection to use. Options are Marmorino \n" //& @@ -126,10 +127,10 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call closeParameterBlock(param_file) call cvmix_init_ddiff(strat_param_max=CS%strat_param_max, & - kappa_ddiff_s=CS%kappa_ddiff_s, & + kappa_ddiff_s=US%Z2_T_to_m2_s*CS%kappa_ddiff_s, & ddiff_exp1=CS%ddiff_exp1, & ddiff_exp2=CS%ddiff_exp2, & - mol_diff=CS%mol_diff, & + mol_diff=US%Z2_T_to_m2_s*CS%mol_diff, & kappa_ddiff_param1=CS%kappa_ddiff_param1, & kappa_ddiff_param2=CS%kappa_ddiff_param2, & kappa_ddiff_param3=CS%kappa_ddiff_param3, & @@ -160,21 +161,21 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) ! Local variables real, dimension(SZK_(GV)) :: & cellHeight, & !< Height of cell centers [m] - dRho_dT, & !< partial derivatives of density wrt temp [R C-1 ~> kg m-3 degC-1] - dRho_dS, & !< partial derivatives of density wrt saln [R S-1 ~> kg m-3 ppt-1] + dRho_dT, & !< partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & !< partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] temp_int, & !< temp and at interfaces [C ~> degC] salt_int, & !< salt at at interfaces [S ~> ppt] alpha_dT, & !< alpha*dT across interfaces [kg m-3] beta_dS, & !< beta*dS across interfaces [kg m-3] - dT, & !< temp. difference between adjacent layers [C ~> degC] - dS !< salt difference between adjacent layers [S ~> ppt] + dT, & !< temperature difference between adjacent layers [C ~> degC] + dS !< salinity difference between adjacent layers [S ~> ppt] real, dimension(SZK_(GV)+1) :: & Kd1_T, & !< Diapycanal diffusivity of temperature [m2 s-1]. Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - real :: dh, hcorr + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] integer :: i, k ! initialize dummy variables @@ -184,7 +185,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) ! GMM, I am leaving some code commented below. We need to pass BLD to - ! this soubroutine to avoid adding diffusivity above that. This needs + ! this subroutine to avoid adding diffusivity above that. This needs ! to be done once we re-structure the order of the calls. !if (.not. associated(hbl)) then ! allocate(hbl(SZI_(G), SZJ_(G))); @@ -234,16 +235,16 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in height units dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo ! gets index of the level and interface above hbl - !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight,hbl(i,j)) + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & @@ -277,7 +278,7 @@ logical function CVMix_ddiff_is_used(param_file) end function CVMix_ddiff_is_used -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory ! NOTE: Placeholder destructor subroutine CVMix_ddiff_end(CS) type(CVMix_ddiff_cs), pointer :: CS !< Control structure for this module that diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 7ec45dbe11..b69cd2daae 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -28,19 +28,19 @@ module MOM_CVMix_shear ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> Control structure including parameters for CVMix interior shear schemes. -type, public :: CVMix_shear_cs ! TODO: private +type, public :: CVMix_shear_cs ; private logical :: use_LMD94 !< Flags to use the LMD94 scheme logical :: use_PP81 !< Flags to use Pacanowski and Philander (JPO 1981) logical :: smooth_ri !< If true, smooth Ri using a 1-2-1 filter - real :: Ri_zero !< LMD94 critical Richardson number - real :: Nu_zero !< LMD94 maximum interior diffusivity - real :: KPP_exp !< Exponent of unitless factor of diff. - !! for KPP internal shear mixing scheme. + real :: Ri_zero !< LMD94 critical Richardson number [nondim] + real :: Nu_zero !< LMD94 maximum interior diffusivity [Z2 T-1 ~> m2 s-1] + real :: KPP_exp !< Exponent of unitless factor of diffusivities + !! for KPP internal shear mixing scheme [nondim] real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] real, allocatable, dimension(:,:,:) :: S2 !< Squared shear frequency [T-2 ~> s-2] - real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number + real, allocatable, dimension(:,:,:) :: ri_grad !< Gradient Richardson number [nondim] real, allocatable, dimension(:,:,:) :: ri_grad_smooth !< Gradient Richardson number - !! after smoothing + !! after smoothing [nondim] character(10) :: Mix_Scheme !< Mixing scheme name (string) type(diag_ctrl), pointer :: diag => NULL() !< Pointer to the diagnostics control structure @@ -137,7 +137,7 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) S2 = US%L_to_Z**2*(DU*DU+DV*DV)/(DZ*DZ) Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) - ! fill 3d arrays, if user asks for diagsnostics + ! fill 3d arrays, if user asks for diagnostics if (CS%id_N2 > 0) CS%N2(i,j,k) = N2 if (CS%id_S2 > 0) CS%S2(i,j,k) = S2 @@ -264,22 +264,22 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "NU_ZERO", CS%Nu_Zero, & "Leading coefficient in KPP shear mixing.", & - units="nondim", default=5.e-3) + units="m2 s-1", default=5.e-3, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "RI_ZERO", CS%Ri_Zero, & "Critical Richardson for KPP shear mixing, "// & "NOTE this the internal mixing and this is "// & - "not for setting the boundary layer depth." & - ,units="nondim", default=0.8) + "not for setting the boundary layer depth.", & + units="nondim", default=0.8) call get_param(param_file, mdl, "KPP_EXP", CS%KPP_exp, & "Exponent of unitless factor of diffusivities, "// & - "for KPP internal shear mixing scheme." & - ,units="nondim", default=3.0) + "for KPP internal shear mixing scheme.", & + units="nondim", default=3.0) call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & "If true, vertically smooth the Richardson "// & "number by applying a 1-2-1 filter once.", & default = .false.) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & - KPP_nu_zero=CS%Nu_Zero, & + KPP_nu_zero=US%Z2_T_to_m2_s*CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & KPP_exp=CS%KPP_exp) @@ -332,7 +332,7 @@ logical function CVMix_shear_is_used(param_file) CVMix_shear_is_used = (LMD94 .or. PP81) end function CVMix_shear_is_used -!> Clear pointers and dealocate memory +!> Clear pointers and deallocate memory subroutine CVMix_shear_end(CS) type(CVMix_shear_cs), intent(inout) :: CS !< Control structure for this module that !! will be deallocated in this subroutine diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 75798ed466..fa3dbe4b87 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -62,7 +62,7 @@ module MOM_tidal_mixing real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] real, allocatable :: Polzin_decay_scale_scaled(:,:) !< vertical scale of decay for tidal dissipation [Z ~> m] real, allocatable :: Polzin_decay_scale(:,:) !< vertical decay scale for tidal dissipation with Polzin [Z ~> m] - real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient + real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient [nondim] end type !> Control structure with parameters for the tidal mixing module. @@ -129,13 +129,14 @@ module MOM_tidal_mixing logical :: use_CVMix_tidal = .false. !< true if CVMix is to be used for determining !! diffusivity due to tidal mixing - real :: min_thickness !< Minimum thickness allowed [m] + real :: min_thickness !< Minimum thickness allowed [Z ~> m] ! CVMix-specific parameters integer :: CVMix_tidal_scheme = -1 !< 1 for Simmons, 2 for Schmittner type(CVMix_tidal_params_type) :: CVMix_tidal_params !< A CVMix-specific type with parameters for tidal mixing type(CVMix_global_params_type) :: CVMix_glb_params !< CVMix-specific for Prandtl number only - real :: tidal_max_coef !< CVMix-specific maximum allowable tidal diffusivity. [m^2/s] + real :: tidal_max_coef !< CVMix-specific maximum allowable tidal + !! diffusivity. [Z2 T-1 ~> m2 s-1] real :: tidal_diss_lim_tc !< CVMix-specific dissipation limit depth for !! tidal-energy-constituent data [Z ~> m]. type(remapping_CS) :: remap_CS !< The control structure for remapping @@ -443,8 +444,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "INT_TIDE_DECAY_SCALE", CS%Int_tide_decay_scale, & "The decay scale away from the bottom for tidal TKE with "//& "the new coding when INT_TIDE_DISSIPATION is used.", & - !units="m", default=0.0) - units="m", default=500.0, scale=US%m_to_Z) ! TODO: confirm this new default + units="m", default=500.0, scale=US%m_to_Z) call get_param(param_file, mdl, "MU_ITIDES", CS%Mu_itides, & "A dimensionless turbulent mixing efficiency used with "//& "INT_TIDE_DISSIPATION, often 0.2.", units="nondim", default=0.2) @@ -564,12 +564,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "GAMMA_NIKURASHIN",CS%Gamma_lee, & "The fraction of the lee wave energy that is dissipated "//& - "locally with LEE_WAVE_DISSIPATION.", units="nondim", & - default=0.3333) + "locally with LEE_WAVE_DISSIPATION.", units="nondim", default=0.3333) call get_param(param_file, mdl, "DECAY_SCALE_FACTOR_LEE",CS%Decay_scale_factor_lee, & "Scaling for the vertical decay scale of the local "//& - "dissipation of lee wave dissipation.", units="nondim", & - default=1.0) + "dissipation of lee wave dissipation.", units="nondim", default=1.0) else CS%Decay_scale_factor_lee = -9.e99 ! This should never be used if CS%Lee_wave_dissipation = False endif @@ -581,18 +579,17 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di !call openParameterBlock(param_file,'CVMix_TIDAL') call get_param(param_file, mdl, "TIDAL_MAX_COEF", CS%tidal_max_coef, & "largest acceptable value for tidal diffusivity", & - units="m^2/s", default=50e-4) ! the default is 50e-4 in CVMix, 100e-4 in POP. + units="m^2/s", default=50e-4, scale=US%m2_s_to_Z2_T) ! the default is 50e-4 in CVMix, 100e-4 in POP. call get_param(param_file, mdl, "TIDAL_DISS_LIM_TC", CS%tidal_diss_lim_tc, & "Min allowable depth for dissipation for tidal-energy-constituent data. "//& "No dissipation contribution is applied above TIDAL_DISS_LIM_TC.", & units="m", default=0.0, scale=US%m_to_Z) - call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, default=0.001, & - do_not_log=.True.) + call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & + units="m", default=0.001, scale=US%m_to_Z, do_not_log=.True.) call get_param(param_file, mdl, "PRANDTL_TIDAL", prandtl_tidal, & "Prandtl number used by CVMix tidal mixing schemes "//& "to convert vertical diffusivities into viscosities.", & - units="nondim", default=1.0, & - do_not_log=.true.) + units="nondim", default=1.0, do_not_log=.true.) call CVMix_put(CS%CVMix_glb_params,'Prandtl',prandtl_tidal) call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & @@ -615,7 +612,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di mix_scheme = CVMix_tidal_scheme_str, & efficiency = CS%Mu_itides, & vertical_decay_scale = CS%int_tide_decay_scale*US%Z_to_m, & - max_coefficient = CS%tidal_max_coef, & + max_coefficient = CS%tidal_max_coef*US%Z2_T_to_m2_s, & local_mixing_frac = CS%Gamma_itides, & depth_cutoff = CS%min_zbot_itides*US%Z_to_m) @@ -777,19 +774,21 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Local variables real, dimension(SZK_(GV)+1) :: Kd_tidal ! tidal diffusivity [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] - real, dimension(SZK_(GV)+1) :: vert_dep ! vertical deposition + real, dimension(SZK_(GV)+1) :: vert_dep ! vertical deposition [nondim] real, dimension(SZK_(GV)+1) :: iFaceHeight ! Height of interfaces [m] real, dimension(SZK_(GV)+1) :: SchmittnerSocn real, dimension(SZK_(GV)) :: cellHeight ! Height of cell centers [m] real, dimension(SZK_(GV)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input ! to model coordinates real, dimension(SZK_(GV)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] - real, dimension(SZK_(GV)) :: Schmittner_coeff + real, dimension(SZK_(GV)) :: Schmittner_coeff ! A coefficient in the Schmittner et al (2014) mixing + ! parameterization [nondim] real, dimension(SZK_(GV)) :: h_m ! Cell thickness [m] real, allocatable, dimension(:,:) :: exp_hab_zetar + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real :: Simmons_coeff ! A coefficient in the Simmons et al (2004) mixing parameterization [nondim] integer :: i, k, is, ie - real :: dh, hcorr, Simmons_coeff real, parameter :: rho_fw = 1000.0 ! fresh water density [kg m-3] ! TODO: when coupled, get this from CESM (SHR_CONST_RHOFW) @@ -803,14 +802,14 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int iFaceHeight = 0.0 ! BBL is all relative to the surface hcorr = 0.0 + ! Compute cell center depth and cell bottom in meters (negative values in the ocean) do k=1,GV%ke - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_m ! Nominal thickness to use for increment, rescaled to m for use by CVMix. + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo call CVMix_compute_Simmons_invariant( nlev = GV%ke, & @@ -889,16 +888,17 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int if (G%mask2dT(i,j)<1) cycle - iFaceHeight = 0.0 ! BBL is all relative to the surface + iFaceHeight(:) = 0.0 ! BBL is all relative to the surface hcorr = 0.0 + ! Compute heights at cell center and interfaces, and rescale layer thicknesses do k=1,GV%ke h_m(k) = h(i,j,k)*GV%H_to_m ! Rescale thicknesses to m for use by CVmix. - ! cell center and cell bottom in meters (negative values in the ocean) - dh = h_m(k) + hcorr ! Nominal thickness less the accumulated error (could temporarily make dh<0) + dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 - dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * dh - iFaceHeight(k+1) = iFaceHeight(k) - dh + dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness + cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh + iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh enddo SchmittnerSocn = 0.0 ! TODO: compute this From 5ef380c0909d7553bc81658a8ba3c9f6122a5acf Mon Sep 17 00:00:00 2001 From: "Andrew C. Ross" Date: Wed, 16 Nov 2022 10:50:29 -0500 Subject: [PATCH 078/629] Only add runoff tracer flux to surface flux if it has not already been added --- config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 | 1 + src/tracer/MOM_generic_tracer.F90 | 3 ++- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index e0d3b1d6a9..ea9f225a27 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -28,6 +28,7 @@ module g_tracer_utils character(len=fm_string_len) :: obc_src_file_name !< Boundary condition tracer source filename character(len=fm_string_len) :: obc_src_field_name !< Boundary condition tracer source fieldname integer :: src_var_record !< Unknown + logical :: runoff_added_to_stf = .false. !< Has flux in from runoff been added to stf? logical :: requires_src_info = .false. !< Unknown real :: src_var_unit_conversion = 1.0 !< This factor depends on the tracer. Ask Jasmin real :: src_var_valid_min = 0.0 !< Unknown diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 4e88944958..131110e6b2 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -512,7 +512,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! g_tracer=>CS%g_tracer_list do - if (_ALLOCATED(g_tracer%trunoff)) then + if (_ALLOCATED(g_tracer%trunoff) .and. (.NOT. g_tracer%runoff_added_to_stf)) then call g_tracer_get_alias(g_tracer,g_tracer_name) call g_tracer_get_pointer(g_tracer,g_tracer_name,'stf', stf_array) call g_tracer_get_pointer(g_tracer,g_tracer_name,'trunoff',trunoff_array) @@ -521,6 +521,7 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, runoff_tracer_flux_array(:,:) = trunoff_array(:,:) * & US%RZ_T_to_kg_m2s*fluxes%lrunoff(:,:) stf_array = stf_array + runoff_tracer_flux_array + g_tracer%runoff_added_to_stf = .true. endif !traverse the linked list till hit NULL From 717343243f8e4fc80362a422fb71e63d331839c1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 4 Dec 2022 03:10:30 -0500 Subject: [PATCH 079/629] *Fix new scaling bug in ML restrat minimum ustar There are extra US%T_to_s scaling factors in the expressions for ustar_min that were recently introduced with dev/gfdl PR #251; these are duplicative of the scaling factor that is already being applied when the parameter OMEGA is read in. The resulting expressions for ustar_min therefore effectively have units of [Z s T-2 ~> m s-1] when they should have units of [Z T-1 ~> m s-1]. Because ustar_min is a tiny floor on the magnitude of ustar, there is a range of values of T_RESCALE_POWER that will give the same answers as when it is 0, but for large enough values the answers will change, perhaps dramatically. This small commit removes these extra factors. Answers will change for some large values of T_RESCALE_POWER, but they are bitwise identical in the TC testing and in MOM6-examples based regression tests with modest or negative values. --- .../lateral/MOM_mixed_layer_restrat.F90 | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 506046340d..102e2723aa 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -309,7 +309,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - ustar_min = 2e-4 * CS%omega * US%T_to_S * (GV%Angstrom_Z + dz_neglect) + ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + dz_neglect) if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -666,7 +666,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - ustar_min = 2e-4 * CS%omega * US%T_to_S * (GV%Angstrom_Z + dz_neglect) + ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + dz_neglect) if (.not.use_EOS) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") @@ -932,9 +932,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, units="nondim", default=1.0) endif call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", units="s-1", & - default=7.2921e-5, scale=US%T_to_s) - + "The rotation rate of the earth.", & + units="s-1", default=7.2921e-5, scale=US%T_to_s) CS%diag => diag From 8de33f906ffc34ec5dc47e63412ad4f67decc768 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 4 Dec 2022 12:16:14 -0500 Subject: [PATCH 080/629] +Add runtime params KV_RESTRAT & RESTRAT_USTAR_MIN Added the runtime parameters KV_RESTRAT and RESTRAT_USTAR_MIN, to build on the improvements in github.com/NOAA-GFDL/MOM6/pull/251, and to provide run-time physical parameters to avoid the potential division by zero in the mixed_layer_restrat code noted at github.com/mom-ocean/MOM6/issues/1168. Once this PR is merged onto the main branch of MOM6, that issue can be closed. By default, these do not change answers in the MOM6-examples test suite, but the default value for RESTRAT_USTAR_MIN was taken from the hard-coded value in PR that PR. The six copies of the eddy growth rate timescale calculations were consolidated into a new internal function, growth_time, with some other related minor refactoring of the code. Also, mixedlayer_restrat_register_restarts now takes a unit_scale_type arguments like many other analogous routines. All answers are bitwise identical, but there are new runtime parameters or comments that lead to changes in the MOM_parameter_doc files. Also clarified in the comments sent to the MOM_parameter_doc files how VISBECK_L_SCALE works as a dimensional scaling factor when it is given a negative value, and rescaled its units when read as though it were always in m. --- src/core/MOM.F90 | 16 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 20 +- .../lateral/MOM_mixed_layer_restrat.F90 | 201 ++++++++++-------- 3 files changed, 126 insertions(+), 111 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 6c978b36f5..d1fd8619da 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2219,11 +2219,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "A tiny magnitude of temperatures below which they are set to 0.", & units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, "MOM", "C_P", CS%tv%C_p, & - "The heat capacity of sea water, approximated as a "//& - "constant. This is only used if ENABLE_THERMODYNAMICS is "//& - "true. The default value is from the TEOS-10 definition "//& - "of conservative temperature.", units="J kg-1 K-1", & - default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) + "The heat capacity of sea water, approximated as a constant. "//& + "This is only used if ENABLE_THERMODYNAMICS is true. The default "//& + "value is from the TEOS-10 definition of conservative temperature.", & + units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", CS%use_p_surf_in_EOS, & "If true, always include the surface pressure contributions "//& "in equation of state calculations.", default=.true.) @@ -2239,9 +2238,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "The number of sublayers within the mixed layer if "//& "BULKMIXEDLAYER is true.", units="nondim", default=2) call get_param(param_file, "MOM", "NKBL", nkbl, & - "The number of layers that are used as variable density "//& - "buffer layers if BULKMIXEDLAYER is true.", units="nondim", & - default=2) + "The number of layers that are used as variable density buffer "//& + "layers if BULKMIXEDLAYER is true.", units="nondim", default=2) endif call get_param(param_file, "MOM", "GLOBAL_INDEXING", global_indexing, & @@ -2642,7 +2640,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) call set_visc_register_restarts(HI, GV, US, param_file, CS%visc, restart_CSp) - call mixedlayer_restrat_register_restarts(HI, GV, param_file, & + call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) if (CS%rotate_index .and. associated(OBC_in) .and. use_temperature) then diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index aa561793e0..a8928ef06c 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1177,12 +1177,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=.false.) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& - "for the interface depth diffusivity", units="nondim", & - default=0.0) + "for the interface depth diffusivity", units="nondim", default=0.0) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", KhTr_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& - "for the epipycnal tracer diffusivity", units="nondim", & - default=0.0) + "for the epipycnal tracer diffusivity", units="nondim", default=0.0) call get_param(param_file, mdl, "USE_STORED_SLOPES", CS%use_stored_slopes,& "If true, the isopycnal slopes are calculated once and "//& "stored for re-use. This uses more memory but avoids calling "//& @@ -1277,20 +1275,22 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) if (KhTr_Slope_Cff>0. .or. KhTh_Slope_Cff>0.) then in_use = .true. call get_param(param_file, mdl, "VISBECK_L_SCALE", CS%Visbeck_L_scale, & - "The fixed length scale in the Visbeck formula.", units="m", & - default=0.0) + "The fixed length scale in the Visbeck formula, or if negative a nondimensional "//& + "scaling factor relating this length scale squared to the cell areas.", & + units="m or nondim", default=0.0, scale=US%m_to_L) allocate(CS%L2u(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%L2v(isd:ied,JsdB:JedB), source=0.0) if (CS%Visbeck_L_scale<0) then + ! Undo the rescaling of CS%Visbeck_L_scale. do j=js,je ; do I=is-1,Ieq - CS%L2u(I,j) = CS%Visbeck_L_scale**2 * G%areaCu(I,j) + CS%L2u(I,j) = (US%L_to_m*CS%Visbeck_L_scale)**2 * G%areaCu(I,j) enddo ; enddo do J=js-1,Jeq ; do i=is,ie - CS%L2v(i,J) = CS%Visbeck_L_scale**2 * G%areaCv(i,J) + CS%L2v(i,J) = (US%L_to_m*CS%Visbeck_L_scale)**2 * G%areaCv(i,J) enddo ; enddo else - CS%L2u(:,:) = US%m_to_L**2*CS%Visbeck_L_scale**2 - CS%L2v(:,:) = US%m_to_L**2*CS%Visbeck_L_scale**2 + CS%L2u(:,:) = CS%Visbeck_L_scale**2 + CS%L2v(:,:) = CS%Visbeck_L_scale**2 endif CS%id_L2u = register_diag_field('ocean_model', 'L2u', diag%axesCu1, Time, & diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 102e2723aa..08c29c6c9e 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -48,7 +48,7 @@ module MOM_mixed_layer_restrat logical :: MLE_use_PBL_MLD !< If true, use the MLD provided by the PBL parameterization. !! if false, MLE will calculate a MLD based on a density difference !! based on the parameter MLE_DENSITY_DIFF. - real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nomdim] + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] real :: MLE_MLD_decay_time !< Time-scale to use in a running-mean when MLD is retreating [T ~> s]. real :: MLE_MLD_decay_time2 !< Time-scale to use in a running-mean when filtered MLD is retreating [T ~> s]. real :: MLE_density_diff !< Density difference used in detecting mixed-layer depth [R ~> kg m-3]. @@ -61,7 +61,9 @@ module MOM_mixed_layer_restrat 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 - real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. + real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] + real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate + !! during restratification [Z2 T-1 ~> m2 s-1] real, dimension(:,:), allocatable :: & MLD_filtered, & !< Time-filtered MLD [H ~> m or kg m-2] @@ -103,8 +105,8 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, VarMix, G, GV, type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] - type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control struct + !! planetary boundary layer scheme [Z ~> m] + 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: "// & @@ -134,11 +136,12 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the !! PBL scheme [Z ~> m] (not H) - type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control struct + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + ! 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 :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! Restratifying zonal thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! Restratifying meridional thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -156,12 +159,10 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. - real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] - real :: ustar_min ! A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] 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 :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux @@ -169,21 +170,22 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! layer [nondim]. The vertical sum of a() through the pieces of ! the mixed layer must be 0. real :: b(SZK_(GV)) ! As for a(k) but for the slow-filtered MLD [nondim] - real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: uDml_slow(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml_slow(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! restratification timescales in the zonal and - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D arrays - ! for diagnostic purposes. + real :: uDml(SZIB_(G)) ! Zonal volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml(SZI_(G)) ! Meridional volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: uDml_slow(SZIB_(G)) ! Zonal volume fluxes in the upper half of the boundary layer to + ! restratify the time-filtered boundary layer depth [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml_slow(SZI_(G)) ! Meridional volume fluxes in the upper half of the boundary layer to + ! restratify the time-filtered boundary layer depth [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! Zonal restratification timescale [T ~> s], stored for diagnostics. + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! Meridional restratification timescale [T ~> s], stored for diagnostics. 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, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: rhoSurf, deltaRhoAtKm1, deltaRhoAtK ! Densities and density differences [R ~> kg m-3] real, dimension(SZI_(G)) :: dK, dKm1 ! Depths of layer centers [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: pRef_MLD ! A reference pressure for calculating the mixed layer ! densities [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: covTS, & !SGS TS covariance in Stanley param; currently 0 [degC ppt] - varS !SGS S variance in Stanley param; currently 0 [ppt2] + real, dimension(SZI_(G)) :: covTS, & ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + varS ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] real :: aFac, bFac ! Nondimensional ratios [nondim] real :: ddRho ! A density difference [R ~> kg m-3] real :: hAtVel ! Thickness at the velocity points [H ~> m or kg m-2] @@ -191,9 +193,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: zpb ! Fractional position within the mixed layer of the interface below a 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 :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] - real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times - ! pi squared [nondim] + real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -202,10 +202,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. - covTS(:)=0.0 !!Functionality not implemented yet; in future, should be passed in tv - varS(:)=0.0 - - vonKar_x_pi2 = CS%vonKar * 9.8696 + 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: "// & "An equation of state must be used with this module.") @@ -309,7 +307,6 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var g_Rho0 = GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + dz_neglect) if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -319,7 +316,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,timescale, & !$OMP line_is_empty, keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) @@ -381,29 +378,22 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! U - Component !$OMP do do j=js,je ; do I=is-1,ie - u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i+1,j) ) ) - ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) - ! momentum mixing rate: pi^2*visc/h_ml^2 h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z - mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - timescale = timescale * CS%ml_restrat_coef + timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) if (res_upscale) timescale = timescale * res_scaling_fac uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + ! As above but using the slow filtered MLD h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z - mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - timescale = timescale * CS%ml_restrat_coef2 + timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) if (res_upscale) timescale = timescale * res_scaling_fac uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) @@ -456,29 +446,22 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var ! V- component !$OMP do do J=js-1,je ; do i=is,ie - u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( (G%dxCv(i,J))**2 + (G%dyCv(i,J))**2 ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i,j+1) ) ) - ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) - ! momentum mixing rate: pi^2*visc/h_ml^2 h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z - mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - timescale = timescale * CS%ml_restrat_coef + timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) if (res_upscale) timescale = timescale * res_scaling_fac vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + ! As above but using the slow filtered MLD h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z - mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - timescale = timescale * CS%ml_restrat_coef2 + timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) if (res_upscale) timescale = timescale * res_scaling_fac vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) @@ -575,10 +558,11 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var call diag_update_remap_grids(CS%diag) contains - !> Stream function as a function of non-dimensional position within mixed-layer + !> 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, bottop, xp, dd + real :: psi1 ! The streamfunction structure without the tail [nondim] + real :: bottop, xp, dd ! Local work variables used to generate the streamfunction tail [nondim] !psi1 = max(0., (1. - (2.*z + 1.)**2)) psi1 = max(0., (1. - (2.*z + 1.)**2) * (1. + (5./21.)*(2.*z + 1.)**2)) @@ -607,9 +591,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure + ! 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 :: uhml(SZIB_(G),SZJ_(G),SZK_(GV)) ! Restratifying zonal thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vhml(SZI_(G),SZJB_(G),SZK_(GV)) ! Restratifying meridional thickness transports [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -623,14 +608,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. - real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times - ! pi squared [nondim] - real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] - real :: ustar_min ! A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] @@ -638,11 +619,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux magnitudes (uDml & vDml) ! to the realized flux in a layer [nondim]. The vertical sum of a() ! through the pieces of the mixed layer must be 0. - real :: uDml(SZIB_(G)) ! The zonal and meridional volume fluxes in the upper - real :: vDml(SZI_(G)) ! half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! The restratification timescales in the zonal and - real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! meridional directions [T ~> s], stored in 2-D - ! arrays for diagnostic purposes. + real :: uDml(SZIB_(G)) ! Zonal volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vDml(SZI_(G)) ! Meridional volume fluxes in the upper half of the mixed layer [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: utimescale_diag(SZIB_(G),SZJ_(G)) ! Zonal restratification timescale [T ~> s], stored for diagnostics. + real :: vtimescale_diag(SZI_(G),SZJB_(G)) ! Meridional restratification timescale [T ~> s], stored for diagnostics. 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] logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. @@ -662,11 +642,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 - vonKar_x_pi2 = CS%vonKar * 9.8696 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z - ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + dz_neglect) if (.not.use_EOS) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") @@ -679,7 +657,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,timescale, & !$OMP I2htot,z_topx2,hx2,a) & !$OMP firstprivate(uDml,vDml) !$OMP do @@ -710,15 +688,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do j=js,je ; do I=is-1,ie h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) - ! momentum mixing rate: pi^2*visc/h_ml^2 - mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - - timescale = timescale * CS%ml_restrat_coef + timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & @@ -756,15 +728,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do J=js-1,je ; do i=is,ie h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z - u_star = max(ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) - ! momentum mixing rate: pi^2*visc/h_ml^2 - mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) - timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) - - timescale = timescale * CS%ml_restrat_coef + timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & @@ -833,6 +799,43 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) end subroutine mixedlayer_restrat_BML +!> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] +real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) + real, intent(in) :: u_star !< Surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: hBL !< Boundary layer thickness including at least a neglible + !! value to keep it positive definite [Z ~> m] + real, intent(in) :: absf !< Absolute value of the Coriolis parameter [T-1 ~> s-1] + real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] + real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification [Z2 T-1 ~> m2 s-1] + real, intent(in) :: vonKar !< The von Karman constant, used to scale the turbulent limits + !! on the restratification timescales [nondim] + real, intent(in) :: restrat_coef !< An overall scaling factor for the restratification timescale [nondim] + + ! Local variables + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] + real :: Kv_eff ! An effective overall viscosity [Z1 T-1 ~> m2 s-1] + real :: pi2 ! A scaling constant that is approximately pi^2 [nondim] + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + Kv_water + ! momentum mixing rate: pi^2*visc/h_ml^2 + pi2 = 9.8696 ! Approximately pi^2. This is more accurate than the overall uncertainty of the + ! scheme, with a value that is chosen to reproduce previous answers. + if (Kv_rest <= 0.0) then + ! This case reproduces the previous answers, but the extra h_neg is otherwise unnecessary. + mom_mixrate = (pi2*vonKar)*u_star**2 / (absf*hBL**2 + 4.0*(hBL + h_neg)*u_star) + growth_time = restrat_coef * (0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2)) + else + ! Set the mixing rate to the sum of a turbulent mixing rate and a laminar viscous rate. + ! mom_mixrate = pi2*vonKar*u_star**2 / (absf*hBL**2 + 4.0*hBL*u_star) + pi2*Kv_rest / hBL**2 + if (absf*hBL <= 4.0e-16*u_star) then + Kv_eff = pi2 * (Kv_rest + 0.25*vonKar*hBL*u_star) + else + Kv_eff = pi2 * (Kv_rest + vonKar*u_star**2*hBL / (absf*hBL + 4.0*u_star)) + endif + growth_time = (restrat_coef*0.0625) * ((hBL**2*(hBL**2*absf + 2.0*Kv_eff)) / ((hBL**2*absf)**2 + Kv_eff**2)) + endif + +end function growth_time !> Initialize the mixed layer restratification module logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, restart_CS) @@ -843,12 +846,14 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, type(param_file_type), intent(in) :: param_file !< Parameter file to parse type(diag_ctrl), target, intent(inout) :: diag !< Regulate diagnostics type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct + 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. - real :: flux_to_kg_per_s ! A unit conversion factor for fluxes. + ! 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] ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j @@ -931,9 +936,20 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) endif - call get_param(param_file, mdl, "OMEGA", CS%omega, & - "The rotation rate of the earth.", & - units="s-1", default=7.2921e-5, scale=US%T_to_s) + 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, & + "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, & + "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) CS%diag => diag @@ -994,13 +1010,14 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, end function mixedlayer_restrat_init !> Allocate and register fields in the mixed layer restratification structure for restarts -subroutine mixedlayer_restrat_register_restarts(HI, GV, param_file, CS, restart_CS) +subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, restart_CS) ! Arguments type(hor_index_type), intent(in) :: HI !< Horizontal index structure type(verticalGrid_type), intent(in) :: GV !< Ocean 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 to parse type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure ! Local variables logical :: mixedlayer_restrat_init @@ -1011,9 +1028,9 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, param_file, CS, restart_ if (.not. mixedlayer_restrat_init) return call get_param(param_file, mdl, "MLE_MLD_DECAY_TIME", CS%MLE_MLD_decay_time, & - default=0., do_not_log=.true.) + 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, & - default=0., do_not_log=.true.) + 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 ! 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.) From b2ba9d91720fc8868503ae5e95aa0f1ce1940680 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 7 Dec 2022 18:48:39 -0500 Subject: [PATCH 081/629] (*)Correct two rescaling bugs in MOM_EOS Corrected the pressure rescaling in calculate_density_second_derivs_scalar() that had been using an uninitialized variable. Also corrected the dimensional rescaling of dSVdT and dSVdS in calc_spec_vol_derivs_1d when temperature and salinity are being rescaled but density is not. Fortunately these do not seem to impact solutions in any production runs, and there do not appear to be any calls to calculate_density_second_derivs_scalar(). Also added checksum calls for tv%varT, tv%varS and tv%covarTS to MOM_thermo_chksum when these elements of the thermovar type are associated. Comments were also added describing the units of a number of internal variables or conversion factor in the MOM_EOS module. All answers in the MOM6-examples test suite are bitwise identical. --- src/core/MOM_checksum_packages.F90 | 6 ++- src/equation_of_state/MOM_EOS.F90 | 65 ++++++++++++++++++++---------- 2 files changed, 48 insertions(+), 23 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index aa080e1e8e..871de51632 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -92,7 +92,7 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] or [m s-1].. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type, which is + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type, which is !! used to rescale u and v if present. integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully @@ -130,6 +130,10 @@ subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, & scale=US%S_to_ppt*US%RZ_to_kg_m2) + if (associated(tv%varT)) call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, scale=US%C_to_degC**2) + if (associated(tv%varS)) call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, scale=US%S_to_ppt**2) + if (associated(tv%covarTS)) call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, & + scale=US%S_to_ppt*US%C_to_degC) end subroutine MOM_thermo_chksum diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c946ddaff8..27484aa536 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -126,16 +126,18 @@ 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) - real :: m_to_Z = 1. !< A constant that translates distances in meters to the units of depth. - real :: kg_m3_to_R = 1. !< A constant that translates kilograms per meter cubed to the units of density. - real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to kilograms per meter cubed. - real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa. - real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1. - real :: degC_to_C = 1. !< A constant that translates degrees Celsius to the units of temperature. - real :: C_to_degC = 1. !< A constant that translates the units of temperature to degrees Celsius. - real :: ppt_to_S = 1. !< A constant that translates parts per thousand to the units of salinity. - real :: S_to_ppt = 1. !< A constant that translates the units of salinity to parts per thousand. +! 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] + real :: R_to_kg_m3 = 1. !< A constant that translates the units of density to + !! kilograms per meter cubed [kg m-3 R-1 ~> 1] + real :: RL2_T2_to_Pa = 1.!< Convert pressures from R L2 T-2 to Pa [Pa T2 R-1 L-2 ~> 1] + real :: L_T_to_m_s = 1. !< Convert lateral velocities from L T-1 to m s-1 [m T s-1 L-1 ~> 1] + real :: degC_to_C = 1. !< A constant that translates degrees Celsius to the units of temperature [C degC-1 ~> 1] + real :: C_to_degC = 1. !< A constant that translates the units of temperature to degrees Celsius [degC C-1 ~> 1] + real :: ppt_to_S = 1. !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] + real :: S_to_ppt = 1. !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] ! logical :: test_EOS = .true. ! If true, test the equation of state end type EOS_type @@ -219,7 +221,11 @@ 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, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + 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] @@ -309,7 +315,12 @@ subroutine calculate_stanley_density_array(T, S, pressure, Tvar, TScov, Svar, rh 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, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + 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) @@ -423,7 +434,12 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, 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, d2RdST, d2RdSS, d2RdSp, d2RdTp ! Second derivatives of density wrt T,S,p + 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 :: i, is, ie, npts if (present(dom)) then @@ -670,7 +686,7 @@ subroutine calculate_TFreeze_array(S, pressure, T_fr, start, npts, EOS, pres_sca ! Local variables real, dimension(size(pressure)) :: pres ! Pressure converted to [Pa] - real :: p_scale ! A factor to convert pressure to units of Pa. + real :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] integer :: j p_scale = 1.0 ; if (present(pres_scale)) p_scale = pres_scale @@ -1028,7 +1044,6 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr !! 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 :: p_scale ! A factor to convert pressure to units of Pa [Pa T2 R-1 L-2 ~> 1] real :: pres ! Pressure converted to [Pa] real :: Ta ! Temperature converted to [degC] real :: Sa ! Salinity converted to [ppt] @@ -1061,9 +1076,9 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr drho_dT_dP = rho_scale * drho_dT_dP endif - if (p_scale /= 1.0) then - drho_dS_dP = p_scale * drho_dS_dP - drho_dT_dP = p_scale * drho_dT_dP + if (EOS%RL2_T2_to_Pa /= 1.0) then + drho_dS_dP = EOS%RL2_T2_to_Pa * drho_dS_dP + drho_dT_dP = EOS%RL2_T2_to_Pa * drho_dT_dP endif if (EOS%C_to_degC /= 1.0) then @@ -1173,7 +1188,7 @@ subroutine calc_spec_vol_derivs_1d(T, S, pressure, dSV_dT, dSV_dS, EOS, dom, sca if (present(scale)) spv_scale = spv_scale * scale dSVdT_scale = spv_scale * EOS%C_to_degC dSVdS_scale = spv_scale * EOS%S_to_ppt - if (spv_scale /= 1.0) then ; do i=is,ie + if ((dSVdT_scale /= 1.0) .or. (dSVdS_scale /= 1.0)) then ; do i=is,ie dSV_dT(i) = dSVdT_scale * dSV_dT(i) dSV_dS(i) = dSVdS_scale * dSV_dS(i) enddo ; endif @@ -1252,7 +1267,12 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) ! Local variables ! These arrays use the same units as their counterparts in calcluate_compress_1d. - real, dimension(1) :: Ta, Sa, pa, rhoa, drho_dpa + real, dimension(1) :: pa ! Pressure in a size-1 1d array [R L2 T-2 ~> Pa] + real, dimension(1) :: Ta ! Temperature in a size-1 1d array [C ~> degC] + real, dimension(1) :: Sa ! Salinity in a size-1 1d array [S ~> ppt] + real, dimension(1) :: rhoa ! In situ density in a size-1 1d array [R ~> kg m-3] + real, dimension(1) :: drho_dpa ! The partial derivative of density with pressure (also the + ! inverse of the square of sound speed) in a 1d array [T2 L-2 ~> s2 m-2] Ta(1) = T ; Sa(1) = S ; pa(1) = pressure @@ -1629,11 +1649,12 @@ 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(inout) :: S !< Salinity [S ~> ppt] real, dimension(HI%isd:HI%ied,HI%jsd:HI%jed,kd), & - intent(in) :: mask_z !< 3d mask regulating which points to convert. + intent(in) :: mask_z !< 3d mask regulating which points to convert [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure + 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] integer :: i, j, k - real :: gsw_sr_from_sp, gsw_ct_from_pt if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_NEMO)) return From 5db4d0c901951d18426fcb8210b747a42d94128b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Dec 2022 08:54:13 -0500 Subject: [PATCH 082/629] +(*)Fix numerous issues with MOM_stoch_eos Corrected several bugs that would prevent cases with STOCH_EOS = True or that set a non-negative value of STANLEY_COEF from running at all. There was also extensive refactoring of the MOM_stoch_eos.F90 code. Specifically this commit makes the following changes: - The new routine stoch_eos_register_restarts was added to register the restart field associated with the MOM_stoch_EOS module before the restarts are read and before restart_registry_lock is called, which was causing any test case with STOCH_EOS=True or a positive value of STANLEY_COEF to have a fatal error. - Added a missing dimensional rescaling factor in the get_param call for KD_SMOOTH in MOM_stoch_eos_init, which would have caused cases exercising the MOM_stoch_eos options to fail the dimensional consistency tests. - MOM_stoch_eos_init was changed from a subroutine into a function that returns a logical value indicating whether this routine is used further. The order of the arguments was modified to match the order used in every other init call. - The new routine post_stoch_eos_diags was added to write diagnostics associated with the stoch_eos module. - The MOM_stoch_eos_CS type was made opaque. - The unused diag argument was removed from MOM_stoch_eos_run. - Unit arguments were added to the get_param calls for STANLEY_COEFF and STANLEY_A. - Four arrays in the MOM_stoch_eos_CS type that had been declared to optionally use static memory allocation were modified to be simple allocatables, as they are not used in the vast majority of MOM6 cases, and there is no reason to always assign memory to them. - The register_restart_field call for "stoch_eos_pattern" was revised to use the newer, more direct form rather than working via a vardesc type. - Return statements were added to several of the MOM_stoch_eos routines in the cases where they are not supposed to do anything. - The comments describing several real variables in the MOM_stoch_eos module were added or modified to describe their units using the standard format. - The module use statements at the start of the MOM_stoch_eos module were updated to reflect these changes. There were also parallel changes in MOM.F90: - Added use_stochastic_EOS element to the MOM_control_struct to indicate whether the stoch_eos calls are to be used. - MOM_stoch_eos_init is only called if temperature and salinities are state variables, as it makes no sense to call it otherwise. - Calls to stoch_eos routines were updates to reflect the new interfaces. - The contents of the MOM_stoch_eos_CS type are no longer used in MOM.F90. All answers are bitwise identical in cases that do not use dimensional rescaling, but answers will change (be corrected) in some cases that do use dimensional consistency tests. Several public interfaces to MOM_stoch_eos routines were altered, and there are changes to multiple MOM_parameter_doc files due to the new units, and due to the fact that stoch_EOS parameters are no longer being logged in cases where they are meaningless. --- src/core/MOM.F90 | 26 +++-- src/core/MOM_stoch_eos.F90 | 191 ++++++++++++++++++++++--------------- 2 files changed, 132 insertions(+), 85 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d1fd8619da..8d7caf83ed 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -114,7 +114,8 @@ module MOM use MOM_shared_initialization, only : write_ocean_geometry_file use MOM_sponge, only : init_sponge_diags, sponge_CS use MOM_state_initialization, only : MOM_initialize_state -use MOM_stoch_eos, only : MOM_stoch_eos_init,MOM_stoch_eos_run,MOM_stoch_eos_CS,mom_calc_varT +use MOM_stoch_eos, only : MOM_stoch_eos_init, MOM_stoch_eos_run, MOM_stoch_eos_CS +use MOM_stoch_eos, only : stoch_EOS_register_restarts, post_stoch_EOS_diags, mom_calc_varT use MOM_sum_output, only : write_energy, accumulate_net_input use MOM_sum_output, only : MOM_sum_output_init, MOM_sum_output_end use MOM_sum_output, only : sum_output_CS @@ -288,6 +289,7 @@ module MOM logical :: thickness_diffuse_first !< If true, diffuse thickness before dynamics. logical :: mixedlayer_restrat !< If true, use submesoscale mixed layer restratifying scheme. logical :: useMEKE !< If true, call the MEKE parameterization. + logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations. logical :: useWaves !< If true, update Stokes drift logical :: use_p_surf_in_EOS !< If true, always include the surface pressure contributions !! in equation of state calculations. @@ -1079,12 +1081,12 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_begin(id_clock_dynamics) call cpu_clock_begin(id_clock_stoch) - if (CS%stoch_eos_CS%use_stoch_eos) call MOM_stoch_eos_run(G,u,v,dt,Time_local,CS%stoch_eos_CS,CS%diag) + if (CS%use_stochastic_EOS) call MOM_stoch_eos_run(G, u, v, dt, Time_local, CS%stoch_eos_CS) call cpu_clock_end(id_clock_stoch) call cpu_clock_begin(id_clock_varT) - if (CS%stoch_eos_CS%stanley_coeff >= 0.0) then - call MOM_calc_varT(G,GV,h,CS%tv,CS%stoch_eos_CS,dt) - call pass_var(CS%tv%varT, G%Domain,clock=id_clock_pass,halo=1) + if (CS%use_stochastic_EOS) then + call MOM_calc_varT(G, GV, h, CS%tv, CS%stoch_eos_CS, dt) + if (associated(CS%tv%varT)) call pass_var(CS%tv%varT, G%Domain, clock=id_clock_pass, halo=1) endif call cpu_clock_end(id_clock_varT) @@ -1297,9 +1299,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & if (IDs%id_u > 0) call post_data(IDs%id_u, u, CS%diag) if (IDs%id_v > 0) call post_data(IDs%id_v, v, CS%diag) if (IDs%id_h > 0) call post_data(IDs%id_h, h, CS%diag) - if (CS%stoch_eos_CS%id_stoch_eos > 0) call post_data(CS%stoch_eos_CS%id_stoch_eos, CS%stoch_eos_CS%pattern, CS%diag) - if (CS%stoch_eos_CS%id_stoch_phi > 0) call post_data(CS%stoch_eos_CS%id_stoch_phi, CS%stoch_eos_CS%phi, CS%diag) - if (CS%stoch_eos_CS%id_tvar_sgs > 0) call post_data(CS%stoch_eos_CS%id_tvar_sgs, CS%tv%varT, CS%diag) + if (CS%use_stochastic_EOS) call post_stoch_EOS_diags(CS%stoch_eos_CS, CS%tv, CS%diag) call disable_averaging(CS%diag) call cpu_clock_end(id_clock_diagnostics) ; call cpu_clock_end(id_clock_other) @@ -2679,6 +2679,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call waves_register_restarts(waves_CSp, HI, GV, param_file, restart_CSp) endif + if (use_temperature) then + call stoch_EOS_register_restarts(HI, param_file, CS%stoch_eos_CS, restart_CSp) + endif + call callTree_waypoint("restart registration complete (initialize_MOM)") call restart_registry_lock(restart_CSp) @@ -2964,7 +2968,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call interface_filter_init(Time, G, GV, US, param_file, diag, CS%CDp, CS%interface_filter_CSp) new_sim = is_new_run(restart_CSp) - call MOM_stoch_eos_init(G,Time,param_file,CS%stoch_eos_CS,restart_CSp,diag) + if (use_temperature) then + CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) + else + CS%use_stochastic_EOS = .false. + endif if (CS%use_porbar) & call porous_barriers_init(Time, US, param_file, diag, CS%por_bar_CS) diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index 2f67077f1e..deb878e99c 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -2,46 +2,44 @@ module MOM_stoch_eos ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_file_parser, only : get_param, param_file_type -use MOM_random, only : PRNG,random_2d_constructor,random_2d_norm -use MOM_time_manager, only : time_type -use MOM_io, only : vardesc, var_desc -use MOM_restart, only : MOM_restart_CS,is_new_run -use MOM_diag_mediator, only : register_diag_field,post_data,diag_ctrl,safe_alloc_ptr -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_restart, only : register_restart_field -use MOM_isopycnal_slopes,only : vert_fill_TS -!use random_numbers_mod, only : getRandomNumbers,initializeRandomNumberStream,randomNumberStream +use MOM_diag_mediator, only : register_diag_field, post_data, diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL +use MOM_file_parser, only : get_param, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_random, only : PRNG, random_2d_constructor, random_2d_norm +use MOM_restart, only : MOM_restart_CS, register_restart_field, is_new_run, query_initialized +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +!use random_numbers_mod, only : getRandomNumbers, initializeRandomNumberStream, randomNumberStream implicit none; private #include public MOM_stoch_eos_init public MOM_stoch_eos_run +public stoch_EOS_register_restarts +public post_stoch_EOS_diags public MOM_calc_varT !> Describes parameters of the stochastic component of the EOS !! correction, described in Stanley et al. JAMES 2020. -type, public :: MOM_stoch_eos_CS - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: l2_inv - !< One over sum of the T cell side side lengths squared - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: rgauss - !< nondimensional random Gaussian - real :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 - real :: amplitude=0.624499 !< Nondimensional std dev of Gaussian +type, public :: MOM_stoch_eos_CS ; private + real, allocatable :: l2_inv(:,:) !< One over sum of the T cell side side lengths squared [L-2 ~> m-2] + real, allocatable :: rgauss(:,:) !< nondimensional random Gaussian [nondim] + real :: tfac=0.27 !< Nondimensional decorrelation time factor, ~1/3.7 [nondim] + real :: amplitude=0.624499 !< Nondimensional standard deviation of Gaussian [nondim] integer :: seed !< PRNG seed type(PRNG) :: rn_CS !< PRNG control structure - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: pattern - !< Random pattern for stochastic EOS [nondim] - real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: phi - !< temporal correlation stochastic EOS [nondim] + real, allocatable :: pattern(:,:) !< Random pattern for stochastic EOS [nondim] + real, allocatable :: phi(:,:) !< temporal correlation stochastic EOS [nondim] logical :: use_stoch_eos!< If true, use the stochastic equation of state (Stanley et al. 2020) real :: stanley_coeff !< Coefficient correlating the temperature gradient - !! and SGS T variance; if <0, turn off scheme in all codes - real :: stanley_a !< a in exp(aX) in stochastic coefficient + !! and SGS T variance [nondim]; if <0, turn off scheme in all codes + real :: stanley_a !< a in exp(aX) in stochastic coefficient [nondim] real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] !>@{ Diagnostic IDs @@ -52,61 +50,64 @@ module MOM_stoch_eos contains -!> Initializes MOM_stoch_eos module. -subroutine MOM_stoch_eos_init(G, Time, param_file, CS, restart_CS, diag) - type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< Time for stochastic process - type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure - type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics +!> Initializes MOM_stoch_eos module, returning a logical indicating whether this module will be used. +logical function MOM_stoch_eos_init(Time, G, US, param_file, diag, CS, restart_CS) + type(time_type), intent(in) :: Time !< Time for stochastic process + 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(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Structure used to control diagnostics + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. ! local variables integer :: i,j - type(vardesc) :: vd - CS%seed=0 - ! contants - !pi=2*acos(0.0) + + MOM_stoch_eos_init = .false. + + CS%seed = 0 + call get_param(param_file, "MOM_stoch_eos", "STOCH_EOS", CS%use_stoch_eos, & "If true, stochastic perturbations are applied "//& "to the EOS in the PGF.", default=.false.) call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & "Coefficient correlating the temperature gradient "//& - "and SGS T variance.", default=-1.0) + "and SGS T variance.", units="nondim", default=-1.0) call get_param(param_file, "MOM_stoch_eos", "STANLEY_A", CS%stanley_a, & "Coefficient a which scales chi in stochastic perturbation of the "//& - "SGS T variance.", default=1.0) + "SGS T variance.", units="nondim", default=1.0, & + do_not_log=((CS%stanley_coeff<0.0) .or. .not.CS%use_stoch_eos)) call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6) + units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s, & + do_not_log=(CS%stanley_coeff<0.0)) - !don't run anything if STANLEY_COEFF < 0 + ! Don't run anything if STANLEY_COEFF < 0 if (CS%stanley_coeff >= 0.0) then + if (.not.allocated(CS%pattern)) call MOM_error(FATAL, & + "MOM_stoch_eos_CS%pattern is not allocated when it should be, suggesting that "//& + "stoch_EOS_register_restarts() has not been called before MOM_stoch_eos_init().") - ALLOC_(CS%pattern(G%isd:G%ied,G%jsd:G%jed)) ; CS%pattern(:,:) = 0.0 - vd = var_desc("stoch_eos_pattern","nondim","Random pattern for stoch EOS",'h','1') - call register_restart_field(CS%pattern, vd, .false., restart_CS) - ALLOC_(CS%phi(G%isd:G%ied,G%jsd:G%jed)) ; CS%phi(:,:) = 0.0 - ALLOC_(CS%l2_inv(G%isd:G%ied,G%jsd:G%jed)) - ALLOC_(CS%rgauss(G%isd:G%ied,G%jsd:G%jed)) + allocate(CS%phi(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%l2_inv(G%isd:G%ied,G%jsd:G%jed), source=0.0) + allocate(CS%rgauss(G%isd:G%ied,G%jsd:G%jed), source=0.0) call get_param(param_file, "MOM_stoch_eos", "SEED_STOCH_EOS", CS%seed, & "Specfied seed for random number sequence ", default=0) call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) - ! fill array with approximation of grid area needed for decorrelation - ! time-scale calculation + ! fill array with approximation of grid area needed for decorrelation time-scale calculation do j=G%jsc,G%jec do i=G%isc,G%iec - CS%l2_inv(i,j)=1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) + CS%l2_inv(i,j) = 1.0/(G%dxT(i,j)**2+G%dyT(i,j)**2) enddo enddo - if (is_new_run(restart_CS)) then - do j=G%jsc,G%jec - do i=G%isc,G%iec - CS%pattern(i,j)=CS%amplitude*CS%rgauss(i,j) - enddo - enddo + + if (.not.query_initialized(CS%pattern, "stoch_eos_pattern", restart_CS) .or. & + is_new_run(restart_CS)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec + CS%pattern(i,j) = CS%amplitude*CS%rgauss(i,j) + enddo ; enddo endif !register diagnostics @@ -120,10 +121,32 @@ subroutine MOM_stoch_eos_init(G, Time, param_file, CS, restart_CS, diag) endif endif -end subroutine MOM_stoch_eos_init + ! This module is only used if explicitly enabled or a positive correlation coefficient is set. + MOM_stoch_eos_init = CS%use_stoch_eos .or. (CS%stanley_coeff >= 0.0) + +end function MOM_stoch_eos_init + +!> Register fields related to the stoch_EOS module for resarts +subroutine stoch_EOS_register_restarts(HI, param_file, CS, restart_CS) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse + type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure + type(MOM_restart_CS), pointer :: restart_CS !< A pointer to the restart control structure. + + call get_param(param_file, "MOM_stoch_eos", "STANLEY_COEFF", CS%stanley_coeff, & + "Coefficient correlating the temperature gradient "//& + "and SGS T variance.", units="nondim", default=-1.0, do_not_log=.true.) + + if (CS%stanley_coeff >= 0.0) then + allocate(CS%pattern(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.0) + call register_restart_field(CS%pattern, "stoch_eos_pattern", .false., restart_CS, & + "Random pattern for stoch EOS", "nondim") + endif + +end subroutine stoch_EOS_register_restarts !> Generates a pattern in space and time for the ocean stochastic equation of state -subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS, diag) +subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: u !< The zonal velocity [L T-1 ~> m s-1]. @@ -132,12 +155,14 @@ subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS, diag) real, intent(in) :: delt !< Time step size for AR1 process [T ~> s]. type(time_type), intent(in) :: Time !< Time for stochastic process type(MOM_stoch_eos_CS), intent(inout) :: CS !< Stochastic control structure - type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics ! local variables - integer :: i,j - integer :: yr,mo,dy,hr,mn,sc - real :: phi,ubar,vbar + real :: ubar, vbar ! Averaged velocities [L T-1 ~> m s-1] + real :: phi ! A temporal correlation factor [nondim] + integer :: i, j + + ! Return without doing anything if this capability is not enabled. + if (.not.CS%use_stoch_eos) return call random_2d_constructor(CS%rn_CS, G%HI, Time, CS%seed) call random_2d_norm(CS%rn_CS, G%HI, CS%rgauss) @@ -145,16 +170,28 @@ subroutine MOM_stoch_eos_run(G, u, v, delt, Time, CS, diag) ! advance AR(1) do j=G%jsc,G%jec do i=G%isc,G%iec - ubar=0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) - vbar=0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) - phi=exp(-delt*CS%tfac*sqrt((ubar**2+vbar**2)*CS%l2_inv(i,j))) - CS%pattern(i,j)=phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j) - CS%phi(i,j)=phi + ubar = 0.5*(u(I,j,1)*G%mask2dCu(I,j)+u(I-1,j,1)*G%mask2dCu(I-1,j)) + vbar = 0.5*(v(i,J,1)*G%mask2dCv(i,J)+v(i,J-1,1)*G%mask2dCv(i,J-1)) + phi = exp(-delt*CS%tfac*sqrt((ubar**2+vbar**2)*CS%l2_inv(i,j))) + CS%pattern(i,j) = phi*CS%pattern(i,j) + CS%amplitude*sqrt(1-phi**2)*CS%rgauss(i,j) + CS%phi(i,j) = phi enddo enddo end subroutine MOM_stoch_eos_run +!> Write out any diagnostics related to this module. +subroutine post_stoch_EOS_diags(CS, tv, diag) + type(MOM_stoch_eos_CS), intent(in) :: CS !< Stochastic control structure + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(diag_ctrl), intent(inout) :: diag !< Structure to control diagnostics + + if (CS%id_stoch_eos > 0) call post_data(CS%id_stoch_eos, CS%pattern, diag) + if (CS%id_stoch_phi > 0) call post_data(CS%id_stoch_phi, CS%phi, diag) + if (CS%id_tvar_sgs > 0) call post_data(CS%id_tvar_sgs, tv%varT, diag) + +end subroutine post_stoch_EOS_diags + !> Computes a parameterization of the SGS temperature variance subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -171,15 +208,17 @@ subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) !! in massless layers filled vertically by diffusion. S !> The filled salinity [S ~> ppt], with the values in !! in massless layers filled vertically by diffusion. - integer :: i, j, k real :: hl(5) !> Copy of local stencil of H [H ~> m] real :: dTdi2, dTdj2 !> Differences in T variance [C2 ~> degC2] + integer :: i, j, k + + ! Nothing happens if a negative correlation coefficient is set. + if (CS%stanley_coeff < 0.0) return ! This block does a thickness weighted variance calculation and helps control for ! extreme gradients along layers which are vanished against topography. It is ! still a poor approximation in the interior when coordinates are strongly tilted. - if (.not. associated(tv%varT)) call safe_alloc_ptr(tv%varT, G%isd, G%ied, G%jsd, G%jed, GV%ke) - + if (.not. associated(tv%varT)) allocate(tv%varT(G%isd:G%ied, G%jsd:G%jed, GV%ke), source=0.0) call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) do k=1,G%ke @@ -193,12 +232,12 @@ subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) ! SGS variance in i-direction [C2 ~> degC2] dTdi2 = ( ( G%mask2dCu(I ,j) * G%IdxCu(I ,j) * ( T(i+1,j,k) - T(i,j,k) ) & - + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & - ) * G%dxT(i,j) * 0.5 )**2 + + G%mask2dCu(I-1,j) * G%IdxCu(I-1,j) * ( T(i,j,k) - T(i-1,j,k) ) & + ) * G%dxT(i,j) * 0.5 )**2 ! SGS variance in j-direction [C2 ~> degC2] dTdj2 = ( ( G%mask2dCv(i,J ) * G%IdyCv(i,J ) * ( T(i,j+1,k) - T(i,j,k) ) & - + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & - ) * G%dyT(i,j) * 0.5 )**2 + + G%mask2dCv(i,J-1) * G%IdyCv(i,J-1) * ( T(i,j,k) - T(i,j-1,k) ) & + ) * G%dyT(i,j) * 0.5 )**2 tv%varT(i,j,k) = CS%stanley_coeff * ( dTdi2 + dTdj2 ) ! Turn off scheme near land tv%varT(i,j,k) = tv%varT(i,j,k) * (minval(hl) / (maxval(hl) + GV%H_subroundoff)) @@ -210,7 +249,7 @@ subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) do k=1,G%ke do j=G%jsc,G%jec do i=G%isc,G%iec - tv%varT(i,j,k) = exp (CS%stanley_a * CS%pattern(i,j)) * tv%varT(i,j,k) + tv%varT(i,j,k) = exp(CS%stanley_a * CS%pattern(i,j)) * tv%varT(i,j,k) enddo enddo enddo From 73add03eb913467cf8aa6baa1262a3671a995998 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Dec 2022 08:55:49 -0500 Subject: [PATCH 083/629] (*)Correct USE_STANLEY domain extents in EOS calls Corrected the domain extents used in EOS calls that are triggered with USE_STANLEY_GM and USE_STANLEY_ISO. These bugs were accidentally introduced when the changes adding the MOM_stoch_eos code to the main branch of MOM6 were merged with changes on the dev/gfdl branch. Also added a test for cases when USE_STANLEY_GM is set to true but STANLEY_COEF is negative to reset the internal versions of this flag to false with a sensible warning message rather than encountering segmentation faults. All solutions are bitwise identical in cases that worked before. --- src/core/MOM_isopycnal_slopes.F90 | 92 +++++++++---------- .../lateral/MOM_thickness_diffuse.F90 | 38 +++++--- 2 files changed, 71 insertions(+), 59 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index b5bd51d75a..07dd19b0a6 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -3,12 +3,12 @@ module MOM_isopycnal_slopes ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs -use MOM_EOS, only : calculate_density_second_derivs +use MOM_debugging, only : hchksum, uvchksum +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, calculate_density_second_derivs, EOS_domain use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE use MOM_open_boundary, only : OBC_DIRECTION_E, OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S @@ -28,13 +28,12 @@ module MOM_isopycnal_slopes !> Calculate isopycnal slopes, and optionally return other stratification dependent functions such as N^2 !! and dz*S^2*g-prime used, or calculable from factors used, during the calculation. subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stanley, & - slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) !, eta_to_m) + slope_x, slope_y, N2_u, N2_v, dzu, dzv, dzSxN, dzSyN, halo, OBC) 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] or units - !! given by 1/eta_to_m) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables real, intent(in) :: dt_kappa_smooth !< A smoothing vertical diffusivity @@ -61,15 +60,12 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan integer, optional, intent(in) :: halo !< Halo width over which to compute type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. - ! real, optional, intent(in) :: eta_to_m !< The conversion factor from the units - ! (This argument has been tested but for now serves no purpose.) !! of eta to m; US%Z_to_m by default. ! Local variables real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & T, & ! The temperature [C ~> degC], with the values in ! in massless layers filled vertically by diffusion. - S !, & ! The filled salinity [S ~> ppt], with the values in + S ! The filled salinity [S ~> ppt], with the values in ! in massless layers filled vertically by diffusion. -! Rho ! Density itself, when a nonlinear equation of state is not in use [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & pres ! The pressure at an interface [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. @@ -96,15 +92,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan T_hr, & ! Temperature on the interface at the h (+1) point [C ~> degC]. S_hr, & ! Salinity on the interface at the h (+1) point [S ~> ppt] pres_hr ! Pressure on the interface at the h (+1) point [R L2 T-2 ~> Pa]. - real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density - real :: drdjA, drdjB ! gradients in the layers above (A) and below (B) the - ! interface times the grid spacing [R ~> kg m-3]. + real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdjA, drdjB ! Along layer meridional potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: hg2A, hg2B ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. real :: dzaL, dzaR ! Temporary thicknesses in eta units [Z ~> m]. - real :: wtA, wtB, wtL, wtR ! Unscaled weights, with various units. + real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] + real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. real :: slope ! The slope of density surfaces, calculated in a way @@ -117,33 +115,34 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! in roundoff and can be neglected [Z ~> m]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. real :: G_Rho0 ! The gravitational acceleration divided by density [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] - real :: Z_to_L ! A conversion factor between from units for e to the - ! units for lateral distances [L Z-1 ~> 1] - real :: L_to_Z ! A conversion factor between from units for lateral distances - ! to the units for e [Z L-1 ~> 1] - real :: H_to_Z ! A conversion factor from thickness units to the units of e [Z H-1 ~> 1 or m3 kg-1] logical :: present_N2_u, present_N2_v - integer, dimension(2) :: EOSdom_u, EOSdom_v ! Domains for the equation of state calculations at u and v points + logical :: local_open_u_BC, local_open_v_BC ! True if u- or v-face OBCs exist anywhere in the global domain. + integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of + ! state calculations at u-points. + integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of + ! state calculations at v-points. + integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of + ! state calculations at h points with 1 extra halo point integer :: is, ie, js, je, nz, IsdB integer :: i, j, k integer :: l_seg - logical :: local_open_u_BC, local_open_v_BC if (present(halo)) then is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + EOSdom_h1(:) = EOS_domain(G%HI, halo=halo+1) else is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + EOSdom_h1(:) = EOS_domain(G%HI, halo=1) endif + EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + EOSdom_v(:) = EOS_domain(G%HI, halo=halo) + nz = GV%ke ; IsdB = G%IsdB + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - Z_to_L = US%Z_to_L ; H_to_Z = GV%H_to_Z - ! if (present(eta_to_m)) then - ! Z_to_L = eta_to_m*US%m_to_L ; H_to_Z = GV%H_to_m / eta_to_m - ! endif - L_to_Z = 1.0 / Z_to_L - dz_neglect = GV%H_subroundoff * H_to_Z + dz_neglect = GV%H_subroundoff * GV%H_to_Z local_open_u_BC = .false. local_open_v_BC = .false. @@ -221,12 +220,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo ; enddo enddo - EOSdom_u(1) = is-1 - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) - !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv,h,e, & - !$OMP h_neglect,dz_neglect,Z_to_L,L_to_Z,H_to_Z,h_neglect2, & - !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,local_open_u_BC, & - !$OMP dzu,OBC,use_stanley) & + !$OMP h_neglect,dz_neglect,h_neglect2, & + !$OMP present_N2_u,G_Rho0,N2_u,slope_x,dzSxN,EOSdom_u,EOSdom_h1, & + !$OMP local_open_u_BC,dzu,OBC,use_stanley) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & @@ -259,7 +256,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_h, S_h, pres_h, & scrap, scrap, drho_dT_dT_h, scrap, scrap, & - tv%eqn_of_state, dom=[is-1,ie-is+3]) + tv%eqn_of_state, dom=EOSdom_h1) endif do I=is-1,ie @@ -294,7 +291,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect @@ -318,7 +315,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = (Z_to_L*drdx)**2 + drdz**2 + mag_grad2 = (US%Z_to_L*drdx)**2 + drdz**2 if (mag_grad2 > 0.0) then slope = drdx / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. @@ -351,11 +348,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo ! I enddo ; enddo ! end of j-loop - EOSdom_v(1) = is - (G%isd-1) ; EOSdom_v(2) = ie - (G%isd-1) - ! Calculate the meridional isopycnal slope. !$OMP parallel do default(none) shared(nz,is,ie,js,je,IsdB,use_EOS,G,GV,US,pres,T,S,tv, & - !$OMP h,h_neglect,e,dz_neglect,Z_to_L,L_to_Z,H_to_Z, & + !$OMP h,h_neglect,e,dz_neglect, & !$OMP h_neglect2,present_N2_v,G_Rho0,N2_v,slope_y,dzSyN,EOSdom_v, & !$OMP dzv,local_open_v_BC,OBC,use_stanley) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & @@ -393,10 +388,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_h, S_h, pres_h, & scrap, scrap, drho_dT_dT_h, scrap, scrap, & - tv%eqn_of_state, dom=[is,ie-is+1]) + tv%eqn_of_state, dom=EOSdom_v) call calculate_density_second_derivs(T_hr, S_hr, pres_hr, & scrap, scrap, drho_dT_dT_hr, scrap, scrap, & - tv%eqn_of_state, dom=[is,ie-is+1]) + tv%eqn_of_state, dom=EOSdom_v) endif do i=is,ie if (use_EOS) then @@ -430,7 +425,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect if (GV%Boussinesq) then - dzaL = haL * H_to_Z ; dzaR = haR * H_to_Z + dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z else dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect @@ -454,7 +449,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! This estimate of slope is accurate for small slopes, but bounded ! to be between -1 and 1. - mag_grad2 = (Z_to_L*drdy)**2 + drdz**2 + mag_grad2 = (US%Z_to_L*drdy)**2 + drdz**2 if (mag_grad2 > 0.0) then slope = drdy / sqrt(mag_grad2) else ! Just in case mag_grad2 = 0 ever. @@ -513,8 +508,9 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar ! Local variables real :: ent(SZI_(G),SZK_(GV)+1) ! The diffusive entrainment (kappa*dt)/dz ! between layers in a timestep [H ~> m or kg m-2]. - real :: b1(SZI_(G)), d1(SZI_(G)) ! b1, c1, and d1 are variables used by the - real :: c1(SZI_(G),SZK_(GV)) ! tridiagonal solver. + real :: b1(SZI_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1] + real :: d1(SZI_(G)) ! A variable used by the tridiagonal solver [nondim], d1 = 1 - c1. + real :: c1(SZI_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: kap_dt_x2 ! The 2*kappa_dt converted to H units [H2 ~> m2 or kg2 m-4]. real :: h_neglect ! A negligible thickness [H ~> m or kg m-2], to allow for zero thicknesses. real :: h0 ! A negligible thickness to allow for zero thickness layers without @@ -541,7 +537,7 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar T_f(i,j,k) = T_in(i,j,k) ; S_f(i,j,k) = S_in(i,j,k) enddo ; enddo ; enddo else - !$OMP parallel do default(shared) private(ent,b1,d1,c1,h_tr) + !$OMP parallel do default(shared) private(ent,b1,d1,c1,h_tr) do j=js,je do i=is,ie ent(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b30d24eeaf..b8d5e4c89c 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -637,7 +637,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R C-1 ~> kg m-3 degC-1] drho_dS_u ! The derivative of density with salinity at u points [R S-1 ~> kg m-3 ppt-1]. - real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ignored. + real, dimension(SZIB_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() + ! with various units that will be ignored [various] real, dimension(SZI_(G)) :: & drho_dT_v, & ! The derivative of density with temperature at v points [R C-1 ~> kg m-3 degC-1] drho_dS_v, & ! The derivative of density with salinity at v points [R S-1 ~> kg m-3 ppt-1]. @@ -665,9 +666,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] ! The calculation is equal to h * S^2 * N^2 * kappa_GM. real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. - real :: drdiA, drdiB ! Along layer zonal- and meridional- potential density - real :: drdjA, drdjB ! gradients in the layers above (A) and below(B) the - ! interface times the grid spacing [R ~> kg m-3]. + real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. + real :: drdjA, drdjB ! Along layer meridional potential density gradients in the layers above (A) + ! and below (B) the interface times the grid spacing [R ~> kg m-3]. real :: drdkL, drdkR ! Vertical density differences across an interface [R ~> kg m-3]. real :: drdi_u(SZIB_(G),SZK_(GV)) ! Copy of drdi at u-points [R ~> kg m-3]. real :: drdj_v(SZI_(G),SZK_(GV)) ! Copy of drdj at v-points [R ~> kg m-3]. @@ -729,10 +731,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] logical :: present_slope_x, present_slope_y, calc_derivatives - integer, dimension(2) :: EOSdom_u ! The shifted i-computational domain to use for equation of + integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of ! state calculations at u-points. - integer, dimension(2) :: EOSdom_v ! The shifted I-computational domain to use for equation of + integer, dimension(2) :: EOSdom_v ! The shifted i-computational domain to use for equation of ! state calculations at v-points. + integer, dimension(2) :: EOSdom_h1 ! The shifted i-computational domain to use for equation of + ! state calculations at h points with 1 extra halo point logical :: use_stanley integer :: is, ie, js, je, nz, IsdB, halo integer :: i, j, k @@ -809,12 +813,14 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%id_sfn_unlim_y > 0) then ; diag_sfn_unlim_y(:,:,1) = 0.0 ; diag_sfn_unlim_y(:,:,nz+1) = 0.0 ; endif EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) + EOSdom_v(:) = EOS_domain(G%HI) + EOSdom_h1(:) = EOS_domain(G%HI, halo=1) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & !$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & - !$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,use_stanley, Tsgs2, & + !$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1,use_stanley,Tsgs2, & !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & @@ -855,7 +861,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_h, S_h, pres_h, & scrap, scrap, drho_dT_dT_h, scrap, scrap, & - tv%eqn_of_state, dom=[is-1,ie-is+3]) + tv%eqn_of_state, EOSdom_h1) endif do I=is-1,ie @@ -1085,7 +1091,6 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ! end of j-loop ! Calculate the meridional fluxes and gradients. - EOSdom_v(:) = EOS_domain(G%HI) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & @@ -1134,10 +1139,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, & call calculate_density_second_derivs(T_h, S_h, pres_h, & scrap, scrap, drho_dT_dT_h, scrap, scrap, & - tv%eqn_of_state, dom=[is,ie-is+1]) + tv%eqn_of_state, EOSdom_v) call calculate_density_second_derivs(T_hr, S_hr, pres_hr, & scrap, scrap, drho_dT_dT_hr, scrap, scrap, & - tv%eqn_of_state, dom=[is,ie-is+1]) + tv%eqn_of_state, EOSdom_v) endif do i=is,ie if (calc_derivatives) then @@ -1971,6 +1976,8 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) real :: strat_floor ! A floor for buoyancy frequency in the Ferrari et al. 2010, ! streamfunction formulation, expressed as a fraction of planetary ! rotation [nondim]. + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [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 :: MEKE_GEOM_answers_2018 ! If true, use expressions in the MEKE_GEOMETRIC calculation @@ -2096,6 +2103,15 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "USE_STANLEY_GM", CS%use_stanley_gm, & "If true, turn on Stanley SGS T variance parameterization "// & "in GM code.", default=.false.) + if (CS%use_stanley_gm) 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) then + call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_GM is true.") + CS%use_stanley_gm = .false. + endif + endif call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s, do_not_log=.not.CS%use_FGNV_streamfn) From 50a22788215ef530e388e38d39e5c91d3b9eaace Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Dec 2022 08:56:22 -0500 Subject: [PATCH 084/629] (*)Correct scaling of USE_STANLEY_PGF diagnostics Corrected the diagnostics rho_pgf, rho_stanley_pgf and p_stanley to only be calculated if they would be written, give identical output when dimensional rescaling is applied, and be documented with the right units. Also added a test for cases when USE_STANLEY_GM is set to true but STANLEY_COEF is negative to reset the internal versions of this flag to false with a sensible warning message rather than encountering segmentation faults. All solutions are bitwise identical in cases that worked before, but there are changes in some diagnostics when they are dimensionally rescaled. --- src/core/MOM_PressureForce_FV.F90 | 86 +++++++++++++++++++++---------- 1 file changed, 59 insertions(+), 27 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 5fdc4a1182..854b6b788c 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -13,7 +13,7 @@ module MOM_PressureForce_FV use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain use MOM_density_integrals, only : int_density_dz, int_specific_vol_dp use MOM_density_integrals, only : int_density_dz_generic_plm, int_density_dz_generic_ppm use MOM_density_integrals, only : int_spec_vol_dp_generic_plm @@ -477,12 +477,11 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm T_t, T_b ! Top and bottom edge values for linear reconstructions ! of temperature within each layer [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - rho_pgf, rho_stanley_pgf ! Density [kg m-3] from EOS with and without SGS T variance - ! in Stanley parameterization. + rho_pgf, rho_stanley_pgf ! Density [R ~> kg m-3] from EOS with and without SGS T variance + ! in Stanley parameterization. real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: & - p_stanley ! Pressure [Pa] estimated with Rho_0 - real :: rho_stanley_scalar ! Scalar quantity to hold density [kg m-3] in Stanley diagnostics. - real :: p_stanley_scalar ! Scalar quantity to hold pressure [Pa] in Stanley diagnostics. + p_stanley ! Pressure [R L2 T-2 ~> Pa] estimated with Rho_0 + real :: zeros(SZI_(G)) ! An array of zero values that can be used as an argument [various] real :: rho_in_situ(SZI_(G)) ! The in situ density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density, [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). @@ -493,12 +492,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real :: G_Rho0 ! G_Earth / Rho0 in [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: rho_ref ! The reference density [R ~> kg m-3]. real :: dz_neglect ! A minimal thickness [Z ~> m], like e. + real :: H_to_RL2_T2 ! A factor to convert from thickness units (H) to pressure + ! units [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_ALE ! If true, use an ALE pressure reconstruction. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. type(thermo_var_ptrs) :: tv_tmp! A structure of temporary T & S. real, parameter :: C1_6 = 1.0/6.0 ! [nondim] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h ! The i-computational domain for the equation of state at tracer points integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, nkmb integer :: i, j, k @@ -759,25 +761,43 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (CS%use_stanley_pgf) then - do j=js,je ; do i=is,ie ; - p_stanley_scalar=0.0 - do k=1, nz - p_stanley_scalar = p_stanley_scalar + 0.5 * h(i,j,k) * GV%H_to_Pa !Pressure at mid-point of layer - call calculate_density(tv%T(i,j,k), tv%S(i,j,k), p_stanley_scalar, 0.0, 0.0, 0.0, & - rho_stanley_scalar, tv%eqn_of_state) - rho_pgf(i,j,k) = rho_stanley_scalar - call calculate_density(tv%T(i,j,k), tv%S(i,j,k), p_stanley_scalar, tv%varT(i,j,k), 0.0, 0.0, & - rho_stanley_scalar, tv%eqn_of_state) - rho_stanley_pgf(i,j,k) = rho_stanley_scalar - p_stanley(i,j,k) = p_stanley_scalar - p_stanley_scalar = p_stanley_scalar + 0.5 * h(i,j,k) * GV%H_to_Pa !Pressure at bottom of layer - enddo; enddo; enddo - endif + ! Calculated diagnostics related to the Stanley parameterization + zeros(:) = 0.0 + EOSdom_h(:) = EOS_domain(G%HI) + if ((CS%id_p_stanley>0) .or. (CS%id_rho_pgf>0) .or. (CS%id_rho_stanley_pgf>0)) then + ! Find the pressure at the mid-point of each layer. + H_to_RL2_T2 = GV%g_Earth*GV%H_to_RZ + if (use_p_atm) then + do j=js,je ; do i=is,ie + p_stanley(i,j,1) = 0.5*h(i,j,1) * H_to_RL2_T2 + p_atm(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + p_stanley(i,j,1) = 0.5*h(i,j,1) * H_to_RL2_T2 + enddo ; enddo + endif + do k=2,nz ; do j=js,je ; do i=is,ie + p_stanley(i,j,k) = p_stanley(i,j,k-1) + 0.5*(h(i,j,k-1) + h(i,j,k)) * H_to_RL2_T2 + enddo ; enddo ; enddo + endif + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) + if (CS%id_rho_pgf>0) then + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_stanley(:,j,k), zeros, & + zeros, zeros, rho_pgf(:,j,k), tv%eqn_of_state, EOSdom_h) + enddo ; enddo + call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + endif + if (CS%id_rho_stanley_pgf>0) then + do k=1,nz ; do j=js,je + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p_stanley(:,j,k), tv%varT(:,j,k), & + zeros, zeros, rho_stanley_pgf(:,j,k), tv%eqn_of_state, EOSdom_h) + enddo ; enddo + call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) + endif + endif if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) - if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) - if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) - if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) end subroutine PressureForce_FV_Bouss @@ -791,10 +811,14 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_FV_CS), intent(inout) :: CS !< Finite volume PGF control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure + + ! Local variables + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. - logical :: use_ALE + logical :: use_ALE ! If true, use the Vertical Lagrangian Remap algorithm CS%initialized = .true. CS%diag => diag ; CS%Time => Time @@ -842,12 +866,20 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS "If true, turn on Stanley SGS T variance parameterization "// & "in PGF code.", default=.false.) if (CS%use_stanley_pgf) 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) then + call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_PGF is true.") + CS%use_stanley_pgf = .false. + endif + CS%id_rho_pgf = register_diag_field('ocean_model', 'rho_pgf', diag%axesTL, & - Time, 'rho in PGF', 'kg m3') + Time, 'rho in PGF', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_rho_stanley_pgf = register_diag_field('ocean_model', 'rho_stanley_pgf', diag%axesTL, & - Time, 'rho in PGF with Stanley correction', 'kg m3') + Time, 'rho in PGF with Stanley correction', 'kg m-3', conversion=US%R_to_kg_m3) CS%id_p_stanley = register_diag_field('ocean_model', 'p_stanley', diag%axesTL, & - Time, 'p in PGF with Stanley correction', 'Pa') + Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) endif if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & From 73b4ff91855e734151bc0187e6f2afad722e92aa Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Dec 2022 08:57:43 -0500 Subject: [PATCH 085/629] (*)Test for inconsistent USE_STANLEY flags Also added tests for cases when USE_STANLEY_ISO or USE_STANLEY_ML are set to true but STANLEY_COEF is negative to reset the internal versions of these flags to false with a sensible warning message rather than encountering segmentation faults. All solutions are bitwise identical in cases that worked before. --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 11 +++++++++++ .../lateral/MOM_mixed_layer_restrat.F90 | 11 +++++++++++ 2 files changed, 22 insertions(+) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index a8928ef06c..1aede30a74 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1114,6 +1114,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! scaled by the resolution function. logical :: better_speed_est ! If true, use a more robust estimate of the first ! mode wave speed as the starting point for iterations. + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_lateral_mixing_coeffs" ! This module's name. @@ -1208,6 +1210,15 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "USE_STANLEY_ISO", CS%use_stanley_iso, & "If true, turn on Stanley SGS T variance parameterization "// & "in isopycnal slope code.", default=.false.) + if (CS%use_stanley_iso) 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) then + call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") + CS%use_stanley_iso = .false. + endif + endif if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then in_use = .true. diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 08c29c6c9e..5d87761363 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -854,6 +854,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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] + real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale + ! temperature variance [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j @@ -891,6 +893,15 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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) then + call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") + CS%use_stanley_ml = .false. + endif + 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) From 5a8c3334d1e1ff7be5ee1a3671b8d682f3982f20 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Dec 2022 09:13:07 -0500 Subject: [PATCH 086/629] (*)Correct scaling of DT_OBC_SEG_UPDATE_OBGC Added a missing dimensional rescaling factor in the get_param call for the recently added variable DT_OBC_SEG_UPDATE_OBGC in initialize_MOM, which would have caused certain cases to fail the dimensional consistency tests. All answers are bitwise identical in cases that do not use dimensional rescaling, but answers will change (and be corrected) in some cases that use dimensional consistency tests. --- src/core/MOM.F90 | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 8d7caf83ed..2288c007c8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -300,7 +300,10 @@ module MOM !! calculated, and if it is 0, dtbt is calculated every step. type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. - real :: dt_obc_seg_period !< The time interval between OBC segment updates for OBGC tracers + real :: dt_obc_seg_period !< The time interval between OBC segment updates for OBGC + !! tracers [T ~> s], or a negative value if the segment + !! data are time-invarant, or zero to update the OBGC + !! segment data with every call to update_OBC_segment_data. type(time_type) :: dt_obc_seg_interval !< A time_time representation of dt_obc_seg_period. type(time_type) :: dt_obc_seg_time !< The next time OBC segment update is applied to OBGC tracers. @@ -2186,12 +2189,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & units="s", default=default_val, do_not_read=(dtbt > 0.0)) endif - CS%dt_obc_seg_period = -1.0 call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & "The time between OBC segment data updates for OBGC tracers. "//& "This must be an integer multiple of DT and DT_THERM. "//& "The default is set to DT.", & - units="s", default=US%T_to_s*CS%dt, do_not_log=.not.associated(CS%OBC)) + units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(CS%OBC)) ! This is here in case these values are used inappropriately. use_frazil = .false. ; bound_salinity = .false. From 674687cd25c2b3843f6101ecf15e8c962e1302b1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Dec 2022 10:08:02 -0500 Subject: [PATCH 087/629] Rescale interface heights for MOM_IC Use dimensionally rescaled units when preparing fields to write to the MOM_IC, and then use the conversion argument to the register_restart_field call to undue this scaling, following the pattern for other calls. All answers and output are bitwise identical. --- src/core/MOM.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2288c007c8..9d0701ec2a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3217,7 +3217,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors type(MOM_restart_CS), pointer :: restart_CSp_tmp => NULL() - real, allocatable :: z_interface(:,:,:) ! Interface heights [m] + real, allocatable :: z_interface(:,:,:) ! Interface heights [Z ~> m] call cpu_clock_begin(id_clock_init) call callTree_enter("finish_MOM_initialization()") @@ -3240,9 +3240,9 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) restart_CSp_tmp = restart_CSp call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) - call find_eta(CS%h, CS%tv, G, GV, US, z_interface, eta_to_m=1.0, dZref=G%Z_ref) + call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) call register_restart_field(z_interface, "eta", .true., restart_CSp_tmp, & - "Interface heights", "meter", z_grid='i') + "Interface heights", "meter", z_grid='i', conversion=US%Z_to_m) ! NOTE: write_ic=.true. routes routine to fms2 IO write_initial_conditions interface call save_restart(dirs%output_directory, Time, CS%G_in, & restart_CSp_tmp, filename=CS%IC_file, GV=GV, write_ic=.true.) From 52e0152d9b9746e421577d2e19be59fba7d152d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 9 Dec 2022 04:44:46 -0500 Subject: [PATCH 088/629] Unit descriptions in MOM_spherical_harmonics Altered the unit descriptions in comments in the new MOM_spherical_harmonics module to use standard syntax or to indicate the relationship between the units of this input and output variables. Only comments are changed, and all answers are bitwise identical. --- .../lateral/MOM_spherical_harmonics.F90 | 50 +++++++++---------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 54b441fa8b..95a9df808c 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -18,9 +18,9 @@ module MOM_spherical_harmonics !> Control structure for spherical harmonic transforms type, public :: sht_CS ; private logical :: initialized = .False. !< True if this control structure has been initialized. - integer :: ndegree !< Maximum degree of the spherical harmonics [nodim]. + integer :: ndegree !< Maximum degree of the spherical harmonics [nondim]. integer :: lmax !< Number of associated Legendre polynomials of nonnegative m - !! [lmax=(ndegree+1)*(ndegree+2)/2] [nodim]. + !! [lmax=(ndegree+1)*(ndegree+2)/2] [nondim]. real, allocatable :: cos_clatT(:,:) !< Precomputed cosine of colatitude at the t-cells [nondim]. real, allocatable :: Pmm(:,:,:) !< Precomputed associated Legendre polynomials (m=n) at the t-cells [nondim]. real, allocatable :: cos_lonT(:,:,:), & !< Precomputed cosine factors at the t-cells [nondim]. @@ -46,18 +46,18 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(sht_CS), intent(inout) :: CS !< Control structure for SHT real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: var !< Input 2-D variable [] - real, intent(out) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) - real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) + intent(in) :: var !< Input 2-D variable [A] + real, intent(out) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) [A] + real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics !! overriding ndegree in the CS [nondim] ! local variables - integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nodim] - integer :: Ltot ! Local copy of the number of spherical harmonics [nodim] + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nondim] + integer :: Ltot ! Local copy of the number of spherical harmonics [nondim] real, dimension(SZI_(G),SZJ_(G)) :: & - pmn, & ! Current associated Legendre polynomials of degree n and order m [nodim] - pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nodim] - pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nodim] + pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] + pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] + pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] integer :: i, j, k integer :: is, ie, js, je, isd, ied, jsd, jed integer :: m, n, l @@ -143,19 +143,19 @@ end subroutine spherical_harmonics_forward subroutine spherical_harmonics_inverse(G, CS, Snm_Re, Snm_Im, var, Nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(sht_CS), intent(in) :: CS !< Control structure for SHT - real, intent(in) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) - real, intent(in) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) + real, intent(in) :: Snm_Re(:) !< SHT coefficients for the real modes (cosine) [A] + real, intent(in) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] real, dimension(SZI_(G),SZJ_(G)), & - intent(out) :: var !< Output 2-D variable [] + intent(out) :: var !< Output 2-D variable [A] integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics !! overriding ndegree in the CS [nondim] ! local variables - integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nodim] - real :: mFac ! A constant multiplier. mFac = 1 (if m==0) or 2 (if m>0) [nodim] + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nondim] + real :: mFac ! A constant multiplier. mFac = 1 (if m==0) or 2 (if m>0) [nondim] real, dimension(SZI_(G),SZJ_(G)) :: & - pmn, & ! Current associated Legendre polynomials of degree n and order m [nodim] - pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nodim] - pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nodim] + pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] + pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] + pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] integer :: i, j, k integer :: is, ie, js, je, isd, ied, jsd, jed integer :: m, n, l @@ -210,7 +210,7 @@ subroutine spherical_harmonics_init(G, param_file, CS) type(sht_CS), intent(inout) :: CS !< Control structure for spherical harmonic transforms ! local variables - real, parameter :: PI = 4.0*atan(1.0) ! 3.1415926... calculated as 4*atan(1) [nodim] + real, parameter :: PI = 4.0*atan(1.0) ! 3.1415926... calculated as 4*atan(1) [nondim] real, parameter :: RADIAN = PI / 180.0 ! Degree to Radian constant [rad/degree] real, dimension(SZI_(G),SZJ_(G)) :: sin_clatT ! sine of colatitude at the t-cells [nondim]. real :: Pmm_coef ! = sqrt{ 1.0/(4.0*PI) * prod[(2k+1)/2k)] } [nondim]. @@ -305,8 +305,8 @@ end subroutine spherical_harmonics_end !> Calculates the number of real elements (cosine) of spherical harmonics given maximum degree Nd. function calc_lmax(Nd) result(lmax) - integer :: lmax !< Number of real spherical harmonic modes [nodim] - integer, intent(in) :: Nd !< Maximum degree [nodim] + integer :: lmax !< Number of real spherical harmonic modes [nondim] + integer, intent(in) :: Nd !< Maximum degree [nondim] lmax = (Nd+2) * (Nd+1) / 2 end function calc_lmax @@ -314,9 +314,9 @@ end function calc_lmax !> Calculates the one-dimensional index number at (n=0, m=m), given order m and maximum degree Nd. !! It is sequenced with degree (n) changing first and order (m) changing second. function order2index(m, Nd) result(l) - integer :: l !< One-dimensional index number [nodim] - integer, intent(in) :: m !< Current order number [nodim] - integer, intent(in) :: Nd !< Maximum degree [nodim] + integer :: l !< One-dimensional index number [nondim] + integer, intent(in) :: m !< Current order number [nondim] + integer, intent(in) :: Nd !< Maximum degree [nondim] l = ((Nd+1) + (Nd+1-(m-1)))*m/2 + 1 end function order2index @@ -379,4 +379,4 @@ end function order2index !! Schaeffer, N., 2013. Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations. !! Geochemistry, Geophysics, Geosystems, 14(3), pp.751-758. !! https://doi.org/10.1002/ggge.20071 -end module MOM_spherical_harmonics \ No newline at end of file +end module MOM_spherical_harmonics From bc28a1345b94c655bc9007a517f04224a2bf53a6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 9 Dec 2022 05:08:33 -0500 Subject: [PATCH 089/629] Correct scattered unit description syntax Corrected the syntax of the unit descriptions of 6 internal variables scattered around the code. Only comments are changed, and all answers are bitwise identical. --- src/core/MOM_open_boundary.F90 | 4 ++-- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 2 +- src/parameterizations/vertical/MOM_vert_friction.F90 | 2 +- src/user/Rossby_front_2d_initialization.F90 | 2 +- src/user/user_change_diffusivity.F90 | 4 ++-- 5 files changed, 7 insertions(+), 7 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 47d6953ce1..9bd292e796 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -5324,11 +5324,11 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) integer :: i, j, k, m, n, ntr, nz integer :: ishift, idir, jshift, jdir real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs - ! 1 if the length scale of reservoir is zero [nodim] + ! 1 if the length scale of reservoir is zero [nondim] real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights ! e.g. a_in is -1 only if b_in ==1 and uhr or vhr is inward ! e.g. a_out is 1 only if b_out==1 and uhr or vhr is outward - ! It's clear that a_in and a_out cannot be both non-zero [nodim] + ! It's clear that a_in and a_out cannot be both non-zero [nondim] nz = GV%ke ntr = Reg%ntr diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 8257d19bd3..bb159b2199 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1993,7 +1993,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. - real :: vonKar ! The von Karman constant as used for mixed layer viscosity [nomdim] + real :: vonKar ! The von Karman constant as used for mixed layer viscosity [nondim] real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate ! that is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index dff879d83e..af7ceef46a 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -51,7 +51,7 @@ module MOM_vert_friction real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. real :: Kv_extra_bbl !< An extra vertical viscosity in the bottom boundary layer of thickness !! Hbbl when there is not a bottom drag law in use [Z2 T-1 ~> m2 s-1]. - real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nomdim] + real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1]. real :: vel_underflow !< Velocity components smaller than vel_underflow diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index d3d1ad2368..da18a7341c 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -257,7 +257,7 @@ real function dTdy( G, dT, lat, US ) real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real :: dHML ! The range of the mixed layer depths [Z ~> m] real :: dHdy ! The mixed layer depth gradient [Z L-1 ~> m m-1] - real :: km_to_L ! Horizontal axis unit conversion factor when AXIS_UNITS = 'k' (1000 m) [L km-1] + real :: km_to_L ! Horizontal axis unit conversion factor when AXIS_UNITS = 'k' (1000 m) [L km-1 ~> 1000] PI = 4.0 * atan(1.0) km_to_L = 1.0e3*US%m_to_L diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 762cee5446..8ed691cc87 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -7,7 +7,7 @@ module user_change_diffusivity use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d use MOM_verticalGrid, only : verticalGrid_type use MOM_EOS, only : calculate_density, EOS_domain @@ -29,7 +29,7 @@ module user_change_diffusivity real :: Kd_add !< The scale of a diffusivity that is added everywhere !! without any filtering or scaling [Z2 T-1 ~> m2 s-1]. real :: lat_range(4) !< 4 values that define the latitude range over which - !! a diffusivity scaled by Kd_add is added [degLat]. + !! a diffusivity scaled by Kd_add is added [degrees_N]. real :: rho_range(4) !< 4 values that define the coordinate potential !! density range over which a diffusivity scaled by !! Kd_add is added [R ~> kg m-3]. From 46a61590e5c054b0dedda3195d5a8eeb49d9a4e0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 9 Dec 2022 06:10:19 -0500 Subject: [PATCH 090/629] +Correct MOM_wave_interface unit descriptions Corrected the descriptions of 12 subroutine argument and internal variables in MOM_wave_interface, including those of 4 arguments to Stokes_PGF, and those of 8 variables related to the Waves%ddt_Us_[xy] diagnostics, which are only enabled with the STOKES_DDT flag that is labeled in the code as "developmental". This commit also includes the addition of the correct conversion arguments to the register_diag_field calls for dudt_Stokes and dvdt_Stokes diagnostics, and to the register_restart calls for Us_x_prev and Us_y_prev. This also required the addition of a unit_scale_type argument to waves_register_restarts. All solutions are bitwise identical, and the dimensional rescaling of two diagnostics are corrected. --- src/core/MOM.F90 | 2 +- src/user/MOM_wave_interface.F90 | 56 ++++++++++++++++----------------- 2 files changed, 29 insertions(+), 29 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9d0701ec2a..3cac9583cb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2678,7 +2678,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif if (present(waves_CSp)) then - call waves_register_restarts(waves_CSp, HI, GV, param_file, restart_CSp) + call waves_register_restarts(waves_CSp, HI, GV, US, param_file, restart_CSp) endif if (use_temperature) then diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 6676addc56..1a1c06018e 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -20,7 +20,7 @@ module MOM_wave_interface use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, surface use MOM_verticalgrid, only : verticalGrid_type -use MOM_restart, only : register_restart_field, MOM_restart_CS +use MOM_restart, only : register_restart_pair, MOM_restart_CS implicit none ; private @@ -73,27 +73,27 @@ module MOM_wave_interface !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - ddt_Us_x !< 3d time tendency of zonal Stokes drift profile [m s-1] + ddt_Us_x !< 3d time tendency of zonal Stokes drift profile [L T-2 ~> m s-2] !! Horizontal -> U points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - ddt_Us_y !< 3d time tendency of meridional Stokes drift profile [m s-1] + ddt_Us_y !< 3d time tendency of meridional Stokes drift profile [L T-2 ~> m s-2] !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_x_from_ddt !< Check of 3d zonal Stokes drift profile [m s-1] + Us_x_from_ddt !< Check of 3d zonal Stokes drift profile [L T-1 ~> m s-1] !! Horizontal -> U points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_y_from_ddt !< Check of 3d meridional Stokes drift profile [m s-1] + Us_y_from_ddt !< Check of 3d meridional Stokes drift profile [L T-1 ~> m s-1] !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_x_prev !< 3d zonal Stokes drift profile, previous dynamics call [m s-1] + Us_x_prev !< 3d zonal Stokes drift profile, previous dynamics call [L T-1 ~> m s-1] !! Horizontal -> U points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - Us_y_prev !< 3d meridional Stokes drift profile, previous dynamics call [m s-1] + Us_y_prev !< 3d meridional Stokes drift profile, previous dynamics call [L T-1 ~> m s-1] !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & @@ -450,8 +450,8 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& "but is likely only encountered when the wind is very small and "//& - "therefore its effects should be mostly benign.", units="nondim", & - default=0.05) + "therefore its effects should be mostly benign.", & + units="nondim", default=0.05) ! Allocate and initialize ! a. Stokes driftProfiles @@ -487,9 +487,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar CS%diag%axesCuL,Time,'3d Stokes drift (x)', 'm s-1', conversion=US%L_T_to_m_s) if (CS%Stokes_DDT) then CS%id_ddt_3dstokes_y = register_diag_field('ocean_model','dvdt_Stokes', & - CS%diag%axesCvL,Time,'d/dt Stokes drift (meridional)','m s-2') + CS%diag%axesCvL,Time,'d/dt Stokes drift (meridional)', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ddt_3dstokes_x = register_diag_field('ocean_model','dudt_Stokes', & - CS%diag%axesCuL,Time,'d/dt Stokes drift (zonal)','m s-2') + CS%diag%axesCuL,Time,'d/dt Stokes drift (zonal)', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_3dstokes_y_from_ddt = register_diag_field('ocean_model','3d_stokes_y_from_ddt', & CS%diag%axesCvL,Time,'3d Stokes drift from ddt (y)', 'm s-1', conversion=US%L_T_to_m_s) CS%id_3dstokes_x_from_ddt = register_diag_field('ocean_model','3d_stokes_x_from_ddt', & @@ -614,7 +614,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) intent(in) :: h !< Thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. - real, intent(in) :: dt !< Time-step for computing Stokes-tendency + real, intent(in) :: dt !< Time-step for computing Stokes-tendency [T ~> s] logical, intent(in) :: dynamics_step !< True if this call is on a dynamics step ! Local Variables @@ -629,7 +629,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) real :: PI ! 3.1415926535... real :: La ! The local Langmuir number [nondim] integer :: ii, jj, kk, b, iim1, jjm1 - real :: idt ! 1 divided by the time step + real :: idt ! 1 divided by the time step [T-1 ~> s-1] if (CS%WaveMethod==EFACTOR) return @@ -1564,13 +1564,13 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(in) :: u !< Lagrangian Velocity i-component [m s-1] + intent(in) :: u !< Lagrangian Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: v !< Lagrangian Velocity j-component [m s-1] + intent(in) :: v !< Lagrangian Velocity j-component [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & - intent(out) :: PFu_Stokes !< PGF Stokes-shear i-component [L T-2] + intent(out) :: PFu_Stokes !< PGF Stokes-shear i-component [L T-2 ~> m s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(out) :: PFv_Stokes !< PGF Stokes-shear j-component [m s-1] + intent(out) :: PFv_Stokes !< PGF Stokes-shear j-component [L T-2 ~> m s-2] type(Wave_parameters_CS), & pointer :: CS !< Surface wave related control structure. @@ -1889,10 +1889,11 @@ subroutine Waves_end(CS) end subroutine Waves_end !> Register wave restart fields. To be called before MOM_wave_interface_init -subroutine waves_register_restarts(CS, HI, GV, param_file, restart_CSp) +subroutine waves_register_restarts(CS, HI, GV, US, param_file, restart_CSp) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(hor_index_type), intent(inout) :: HI !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Input parameter structure type(MOM_restart_CS), pointer :: restart_CSp !< Restart structure, data intent(inout) ! Local variables @@ -1916,21 +1917,20 @@ subroutine waves_register_restarts(CS, HI, GV, param_file, restart_CSp) if (.not.(use_waves .or. StatisticalWaves)) return - call get_param(param_file,mdl,"STOKES_DDT",time_tendency_term, do_not_log=.true., default=.false.) + call get_param(param_file, mdl, "STOKES_DDT", time_tendency_term, do_not_log=.true., default=.false.) if (time_tendency_term) then ! Allocate wave fields needed for restart file - allocate(CS%Us_x_prev(HI%isdB:HI%IedB,HI%jsd:HI%jed,GV%ke)) - CS%Us_x_prev(:,:,:) = 0.0 - allocate(CS%Us_y_prev(HI%isd:HI%Ied,HI%jsdB:HI%jedB,GV%ke)) - CS%Us_y_prev(:,:,:) = 0.0 - ! Register to restart + allocate(CS%Us_x_prev(HI%isdB:HI%IedB,HI%jsd:HI%jed,GV%ke), source=0.0) + allocate(CS%Us_y_prev(HI%isd:HI%Ied,HI%jsdB:HI%jedB,GV%ke), source=0.0) + + ! Register to restart files. If these are not found in a restart file, they stay 0. vd(1) = var_desc("Us_x_prev", "m s-1", "3d zonal Stokes drift profile",& - hor_grid='u',z_grid='L') + hor_grid='u', z_grid='L') vd(2) = var_desc("Us_y_prev", "m s-1", "3d meridional Stokes drift profile",& - hor_grid='v',z_grid='L') - call register_restart_field(CS%US_x_prev(:,:,:), vd(1), .false., restart_CSp) - call register_restart_field(CS%US_y_prev(:,:,:), vd(2), .false., restart_CSp) + hor_grid='v', z_grid='L') + call register_restart_pair(CS%US_x_prev, CS%US_y_prev, vd(1), vd(2), .false., & + restart_CSp, conversion=US%L_T_to_m_s) endif end subroutine waves_register_restarts From 92a1c3c2cc36550070ca664a81603e25da62363d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 2 Dec 2022 10:38:25 -0500 Subject: [PATCH 091/629] (+)Correct units of INTERNAL_TIDE_SOURCE_X params Corrected and documents the units for the INTERNAL_TIDE_SOURCE_[XY] runtime parameters, and corrected the (unused) INTERNAL_TIDE_SOURCE_[XY] parameters as read by wave_structure_init to INTERNAL_TIDE_SOURCE_[IJ] and then commented this unused debugging code out. All answers are bitwise identical, but the MOM_parameter_doc files could change in cases that call int_tide_input_init or wave_structure_init. --- src/diagnostics/MOM_wave_structure.F90 | 24 +++++++++++-------- .../vertical/MOM_internal_tide_input.F90 | 15 ++++++------ 2 files changed, 21 insertions(+), 18 deletions(-) diff --git a/src/diagnostics/MOM_wave_structure.F90 b/src/diagnostics/MOM_wave_structure.F90 index 0f97b560db..80d23eeb75 100644 --- a/src/diagnostics/MOM_wave_structure.F90 +++ b/src/diagnostics/MOM_wave_structure.F90 @@ -57,10 +57,9 @@ module MOM_wave_structure !< Squared buoyancy frequency at each interface [T-2 ~> s-2]. integer, allocatable, dimension(:,:):: num_intfaces !< Number of layer interfaces (including surface and bottom) [nondim]. - real :: int_tide_source_x !< X Location of generation site - !! for internal tide for testing (BDM) - real :: int_tide_source_y !< Y Location of generation site - !! for internal tide for testing (BDM) + ! 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 @@ -143,7 +142,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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 + 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)) @@ -281,7 +280,7 @@ subroutine wave_structure(h, tv, G, GV, US, cn, ModeNum, freq, CS, En, full_halo 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_x .and. jg == CS%int_tide_source_y) then + !if (ig == CS%int_tide_source_i .and. jg == CS%int_tide_source_j) then !----------------------------------- if (G%mask2dT(i,j) > 0.0) then @@ -762,10 +761,15 @@ subroutine wave_structure_init(Time, G, GV, param_file, diag, CS) CS%initialized = .true. - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & - "X Location of generation site for internal tide", default=1.) - call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & - "Y Location of generation site for internal tide", default=1.) + ! 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.) diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 9ec4c073f0..7ec612f141 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -48,13 +48,12 @@ module MOM_int_tide_input character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site - !! for internal tide testing (BDM) + !! for internal tide testing type(time_type) :: time_max_source !< A time for use in testing internal tides real :: int_tide_source_x !< X Location of generation site - !! for internal tide for testing (BDM) - !! for internal tide for testing (BDM) + !! for internal tide for testing [degrees_E] or [km] real :: int_tide_source_y !< Y Location of generation site - !! for internal tide for testing (BDM) + !! for internal tide for testing [degrees_N] or [km] integer :: int_tide_source_i !< I Location of generation site integer :: int_tide_source_j !< J Location of generation site logical :: int_tide_use_glob_ij !< Use global indices for generation site @@ -417,11 +416,11 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "INTERNAL_TIDE_USE_GLOB_IJ", CS%int_tide_use_glob_ij, & "Use global IJ for internal tide generation source test", default=.false.) call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_X", CS%int_tide_source_x, & - "X Location of generation site for internal tide", default=1., & - do_not_log=CS%int_tide_use_glob_ij) + "X Location of generation site for internal tide", & + units=G%x_ax_unit_short, default=1.0, do_not_log=CS%int_tide_use_glob_ij) call get_param(param_file, mdl, "INTERNAL_TIDE_SOURCE_Y", CS%int_tide_source_y, & - "Y Location of generation site for internal tide", default=1., & - do_not_log=CS%int_tide_use_glob_ij) + "Y Location of generation site for internal tide", & + units=G%y_ax_unit_short, default=1.0, do_not_log=CS%int_tide_use_glob_ij) 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, & do_not_log=.not.CS%int_tide_use_glob_ij) From 92af13feab5f04cba2934cda5b3850beab43e4fe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:27:52 -0500 Subject: [PATCH 092/629] +Standardize user module axis unit documentation Standardized documentation of axis-related variable units in user modules. Some of these use the new G%x_ax_unit_short elements to automatically write the AXIS_UNITS-dependent units into the MOM_parameter_doc files. All answers are bitwise identical but there are minor changes in some MOM_parameter_doc files. --- src/tracer/oil_tracer.F90 | 4 ++-- src/user/BFB_surface_forcing.F90 | 8 ++++---- src/user/basin_builder.F90 | 2 +- src/user/external_gwave_initialization.F90 | 10 +++++----- src/user/user_change_diffusivity.F90 | 2 +- 5 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 4d828decad..544188bb7a 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -126,10 +126,10 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) "found in the restart files of a restarted run.", & default=.false.) call get_param(param_file, mdl, "OIL_SOURCE_LONGITUDE", CS%oil_source_longitude, & - "The geographic longitude of the oil source.", units="degrees E", & + "The geographic longitude of the oil source.", units="degrees_E", & fail_if_missing=.true.) call get_param(param_file, mdl, "OIL_SOURCE_LATITUDE", CS%oil_source_latitude, & - "The geographic latitude of the oil source.", units="degrees N", & + "The geographic latitude of the oil source.", units="degrees_N", & fail_if_missing=.true.) call get_param(param_file, mdl, "OIL_SOURCE_LAYER", CS%oil_source_k, & "The layer into which the oil is introduced, or a "//& diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 38361ab070..818fa63659 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -31,8 +31,8 @@ module BFB_surface_forcing real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: SST_s !< SST at the southern edge of the linear forcing ramp [C ~> degC] real :: SST_n !< SST at the northern edge of the linear forcing ramp [C ~> degC] - real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degLat] - real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degLat] + real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degrees_N] or [km] + real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degrees_N] or [km] real :: drho_dt !< Rate of change of density with temperature [R C-1 ~> kg m-3 degC-1]. !! Note that temperature is being used as a dummy variable here. !! All temperatures are converted into density. @@ -206,10 +206,10 @@ subroutine BFB_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, "LFR_SLAT", CS%lfrslat, & "Southern latitude where the linear forcing ramp begins.", & - units="degrees", default=20.0) + units=G%y_ax_unit_short, default=20.0) call get_param(param_file, mdl, "LFR_NLAT", CS%lfrnlat, & "Northern latitude where the linear forcing ramp ends.", & - units="degrees", default=40.0) + units=G%y_ax_unit_short, default=40.0) call get_param(param_file, mdl, "SST_S", CS%SST_s, & "SST at the southern edge of the linear forcing ramp.", & units="degC", default=20.0, scale=US%degC_to_C) diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index 9a4974807f..42083b2672 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -34,7 +34,7 @@ subroutine basin_builder_topography(D, G, param_file, max_depth) character(len=17) :: pname1, pname2 ! For construction of parameter names character(len=20) :: funcs ! Basin build function real, dimension(20) :: pars ! Parameters for each function - real :: lon ! Longitude [degrees_E} + real :: lon ! Longitude [degrees_E] real :: lat ! Latitude [degrees_N] integer :: i, j, n, n_funcs diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index ec507e181b..554440dbcb 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -39,7 +39,7 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: ssh_anomaly_height ! Vertical height of ssh anomaly [Z ~> m] - real :: ssh_anomaly_width ! Lateral width of anomaly [degrees] + real :: ssh_anomaly_width ! Lateral width of anomaly, often in [km] or [degrees_E] character(len=40) :: mdl = "external_gwave_initialize_thickness" ! This subroutine's name. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -53,11 +53,11 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "SSH_ANOMALY_HEIGHT", ssh_anomaly_height, & - "The vertical displacement of the SSH anomaly. ", units="m", scale=US%m_to_Z, & - fail_if_missing=.not.just_read, do_not_log=just_read) + "The vertical displacement of the SSH anomaly. ", & + units="m", scale=US%m_to_Z, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "SSH_ANOMALY_WIDTH", ssh_anomaly_width, & - "The lateral width of the SSH anomaly. ", units="coordinate", & - fail_if_missing=.not.just_read, do_not_log=just_read) + "The lateral width of the SSH anomaly. ", & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index 8ed691cc87..f125da0a25 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -230,7 +230,7 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) "applied. The four values specify the latitudes at "//& "which the extra diffusivity starts to increase from 0, "//& "hits its full value, starts to decrease again, and is "//& - "back to 0.", units="degree", default=-1.0e9) + "back to 0.", units="degrees_N", default=-1.0e9) call get_param(param_file, mdl, "USER_KD_ADD_RHO_RANGE", CS%rho_range(:), & "Four successive values that define a range of potential "//& "densities over which the user-given extra diffusivity "//& From e410a937f3879352f4468e780e096e139078d00d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:28:18 -0500 Subject: [PATCH 093/629] +Document and rescale ISOMIP parameters Made 6 of the parameters describing the ISOMIP configuration into runtime parameters that are read in and rescaled via get_param calls to read ISOMIP_MAX_BEDROCK, ISOMIP_TROUGH_DEPTH, ISOMIP_BEDROCK_LENGTH, ISOMIP_TROUGH_WIDTH, ISOMIP_DOMAIN_WIDTH and ISOMIP_SIDE_WIDTH. Several of the internal variables in ISOMIP_initialize_topography were also rescaled for dimensional consistency testing, and the units of the internal variables in this same routine were documented. In addition, the default values for the ISOMIP temperatures and salinities were also rescaled. All answers are bitwise identical, but there are 6 new runtime parameters in the MOM_input files for the ISOMIP test cases. --- src/user/ISOMIP_initialization.F90 | 120 ++++++++++++++++------------- 1 file changed, 68 insertions(+), 52 deletions(-) diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index ac586a02f6..bba357f490 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -48,19 +48,20 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: min_depth ! The minimum depth of the ocean [Z ~> m]. ! The following variables are used to set up the bathymetry in the ISOMIP example. - real :: bmax ! max depth of bedrock topography [Z ~> m] - real :: b0,b2,b4,b6 ! first, second, third and fourth bedrock topography coeffs [Z ~> m] - real :: xbar ! characteristic along-flow length scale of the bedrock + real :: bmax ! maximum depth of bedrock topography [Z ~> m] + real :: b0, b2, b4, b6 ! first, second, third and fourth bedrock topography coeffs [Z ~> m] + real :: xbar ! characteristic along-flow length scale of the bedrock [L ~> m] real :: dc ! depth of the trough compared with side walls [Z ~> m]. - real :: fc ! characteristic width of the side walls of the channel - real :: wc ! half-width of the trough - real :: ly ! domain width (across ice flow) - real :: bx, by ! dummy vatiables [Z ~> m]. - real :: xtil ! dummy vatiable - logical :: is_2D ! If true, use 2D setup -! This include declares and sets the variable "version". + real :: fc ! characteristic width of the side walls of the channel [L ~> m] + real :: wc ! half-width of the trough [L ~> m] + real :: ly ! domain width (across ice flow) [L ~> m] + real :: bx, by ! The x- and y- contributions to the bathymetric profiles at a point [Z ~> m] + real :: xtil ! x-positon normalized by the characteristic along-flow length scale [nondim] + real :: km_to_L ! The conversion factor from the axis units to L [L km-1 ~> 1e3] + logical :: is_2D ! If true, use a 2D setup + ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "ISOMIP_initialize_topography" ! This subroutine's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed @@ -72,27 +73,39 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & "The minimum depth of the ocean.", units="m", default=0.0, scale=US%m_to_Z) - call get_param(param_file, mdl, "ISOMIP_2D",is_2D,'If true, use a 2D setup.', default=.false.) - - ! The following variables should be transformed into runtime parameters? - bmax = 720.0*US%m_to_Z ; dc = 500.0*US%m_to_Z + call get_param(param_file, mdl, "ISOMIP_2D", is_2D, 'If true, use a 2D setup.', default=.false.) + call get_param(param_file, mdl, "ISOMIP_MAX_BEDROCK", bmax, & + "Maximum depth of bedrock topography in the ISOMIP configuration.", & + units="m", default=720.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_TROUGH_DEPTH", dc, & + "Depth of the trough compared with side walls in the ISOMIP configuration.", & + units="m", default=500.0, scale=US%m_to_Z) + call get_param(param_file, mdl, "ISOMIP_BEDROCK_LENGTH", xbar, & + "Characteristic along-flow length scale of the bedrock in the ISOMIP configuration.", & + units="m", default=300.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_TROUGH_WIDTH", wc, & + "Half-width of the trough in the ISOMIP configuration.", & + units="m", default=24.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_DOMAIN_WIDTH", ly, & + "Domain width (across ice flow) in the ISOMIP configuration.", & + units="m", default=80.0e3, scale=US%m_to_L) + call get_param(param_file, mdl, "ISOMIP_SIDE_WIDTH", fc, & + "Characteristic width of the side walls of the channel in the ISOMIP configuration.", & + units="m", default=4.0e3, scale=US%m_to_L) + + km_to_L = 1.0e3*US%m_to_L + + ! The following variables should be transformed into runtime parameters. b0 = -150.0*US%m_to_Z ; b2 = -728.8*US%m_to_Z ; b4 = 343.91*US%m_to_Z ; b6 = -50.57*US%m_to_Z - xbar = 300.0e3 ; fc = 4.0e3 ; wc = 24.0e3 ; ly = 80.0e3 - bx = 0.0 ; by = 0.0 ; xtil = 0.0 - if (is_2D) then do j=js,je ; do i=is,ie - ! 2D setup - xtil = G%geoLonT(i,j)*1.0e3/xbar - !xtil = 450*1.0e3/xbar + ! For the 2D setup take a slice through the middle of the domain + xtil = G%geoLonT(i,j)*km_to_L / xbar + !xtil = 450.*km_to_L / xbar bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 - !by = (dc/(1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & - ! (dc/(1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) - ! slice at y = 40 km - by = (dc / (1.+exp(-2.*(40.0*1.0e3- ly/2. - wc)/fc))) + & - (dc / (1.+exp(2.*(40.0*1.0e3- ly/2. + wc)/fc))) + by = 2.0 * dc / (1.0 + exp(2.0*wc / fc)) D(i,j) = -max(bx+by, -bmax) if (D(i,j) > max_depth) D(i,j) = max_depth @@ -104,17 +117,17 @@ subroutine ISOMIP_initialize_topography(D, G, param_file, max_depth, US) ! 3D setup ! ===== TEST ===== !if (G%geoLonT(i,j)<500.) then - ! xtil = 500.*1.0e3/xbar + ! xtil = 500.*km_to_L / xbar !else - ! xtil = G%geoLonT(i,j)*1.0e3/xbar + ! xtil = G%geoLonT(i,j)*km_to_L / xbar !endif ! ===== TEST ===== - xtil = G%geoLonT(i,j)*1.0e3/xbar + xtil = G%geoLonT(i,j)*km_to_L / xbar bx = b0 + b2*xtil**2 + b4*xtil**4 + b6*xtil**6 - by = (dc / (1.+exp(-2.*(G%geoLatT(i,j)*1.0e3- ly/2. - wc)/fc))) + & - (dc / (1.+exp(2.*(G%geoLatT(i,j)*1.0e3- ly/2. + wc)/fc))) + by = (dc / (1.0 + exp(-2.*(G%geoLatT(i,j)*km_to_L - 0.5*ly - wc) / fc))) + & + (dc / (1.0 + exp(2.*(G%geoLatT(i,j)*km_to_L - 0.5*ly + wc) / fc))) D(i,j) = -max(bx+by, -bmax) if (D(i,j) > max_depth) D(i,j) = max_depth @@ -264,17 +277,12 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. ! Local variables - integer :: i, j, k, is, ie, js, je, nz, itt real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: xi0, xi1 ! Heights in depth units [Z ~> m]. real :: S_sur, S_bot ! Salinity at the surface and bottom [S ~> ppt] real :: T_sur, T_bot ! Temperature at the surface and bottom [C ~> degC] real :: dT_dz ! Vertical gradient of temperature [C Z-1 ~> degC m-1]. real :: dS_dz ! Vertical gradient of salinity [S Z-1 ~> ppt m-1]. - !character(len=256) :: mesg ! The text of an error message - character(len=40) :: verticalCoordinate - !real :: rho_tmp - logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. real :: T0(SZK_(GV)) ! A profile of temperatures [C ~> degC] real :: S0(SZK_(GV)) ! A profile of salinities [S ~> ppt] real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. @@ -283,7 +291,14 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U real :: pres(SZK_(GV)) ! An array of the reference pressure [R L2 T-2 ~> Pa]. (zero here) real :: drho_dT1 ! A prescribed derivative of density with temperature [R C-1 ~> kg m-3 degC-1] real :: drho_dS1 ! A prescribed derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. - real :: T_Ref, S_Ref + real :: T_ref ! Default value for other temperatures [C ~> degC] + real :: S_ref ! Default value for other salinities [S ~> ppt] + logical :: fit_salin ! If true, accept the prescribed temperature and fit the salinity. + !real :: rho_tmp ! A temporary density used for debugging [R ~> kg m-3] + !character(len=256) :: mesg ! The text of an error message + character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz, itt + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pres(:) = 0.0 @@ -343,8 +358,8 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U "A reference temperature used in initialization.", & units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_Ref, & - "A reference salinity used in initialization.", units="PSU", & - default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + "A reference salinity used in initialization.", & + units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. ! write(mesg,*) 'read drho_dS, drho_dT', drho_dS1, drho_dT1 @@ -450,7 +465,8 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, real :: TNUDG ! Nudging time scale [T ~> s] real :: S_sur, S_bot ! Surface and bottom salinities in the sponge region [S ~> ppt] real :: T_sur, T_bot ! Surface and bottom temperatures in the sponge region [C ~> degC] - real :: t_ref, s_ref ! reference (default) T [degC] and S [ppt] + real :: T_ref ! Default value for other temperatures [C ~> degC] + real :: S_ref ! Default value for other salinities [S ~> ppt] real :: rho_sur, rho_bot ! Surface and bottom densities [R ~> kg m-3] real :: rho_range ! The range of densities [R ~> kg m-3] real :: dT_dz ! Vertical gradient of temperature [C Z-1 ~> degC m-1] @@ -460,9 +476,10 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m]. real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. - real :: min_depth, dummy1 - real :: min_thickness, xi0 - !real :: rho_tmp + real :: min_depth ! The minimum depth of the ocean [Z ~> m] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: xi0 ! Interface heights in depth units [Z ~> m], usually negative. + !real :: rho_tmp ! A temporary density used for debugging [R ~> kg m-3] character(len=40) :: verticalCoordinate, filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir @@ -481,27 +498,27 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, call get_param(PF, mdl, "ISOMIP_TNUDG", TNUDG, "Nudging time scale for sponge layers", & units="days", default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mdl, "T_REF", t_ref, "Reference temperature", & - units="degC", default=10.0, scale=1.0, do_not_log=.true.) + call get_param(PF, mdl, "T_REF", T_ref, "Reference temperature", & + units="degC", default=10.0, scale=US%degC_to_C, do_not_log=.true.) call get_param(PF, mdl, "S_REF", s_ref, "Reference salinity", & - units="ppt", default=35.0, scale=1.0, do_not_log=.true.) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(PF, mdl, "ISOMIP_S_SUR_SPONGE", s_sur, & "Surface salinity in sponge layer.", & - units="ppt", default=s_ref, scale=US%ppt_to_S) + units="ppt", default=US%S_to_ppt*S_ref, scale=US%ppt_to_S) call get_param(PF, mdl, "ISOMIP_S_BOT_SPONGE", s_bot, & "Bottom salinity in sponge layer.", & - units="ppt", default=s_ref, scale=US%ppt_to_S) + units="ppt", default=US%S_to_ppt*S_ref, scale=US%ppt_to_S) call get_param(PF, mdl, "ISOMIP_T_SUR_SPONGE", t_sur, & "Surface temperature in sponge layer.", & - units="degC", default=t_ref, scale=US%degC_to_C) + units="degC", default=US%C_to_degC*T_ref, scale=US%degC_to_C) call get_param(PF, mdl, "ISOMIP_T_BOT_SPONGE", t_bot, & "Bottom temperature in sponge layer.", & - units="degC", default=t_ref, scale=US%degC_to_C) + units="degC", default=US%C_to_degC*T_ref, scale=US%degC_to_C) T(:,:,:) = 0.0 ; S(:,:,:) = 0.0 ; Idamp(:,:) = 0.0 !; RHO(:,:,:) = 0.0 @@ -523,8 +540,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, if (depth_tot(i,j) <= min_depth) then Idamp(i,j) = 0.0 elseif (G%geoLonT(i,j) >= 790.0 .AND. G%geoLonT(i,j) <= 800.0) then - dummy1 = (G%geoLonT(i,j)-790.0)/(800.0-790.0) - Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) + Idamp(i,j) = (1.0/TNUDG) * max(0.0, (G%geoLonT(i,j)-790.0) / (800.0-790.0)) else Idamp(i,j) = 0.0 endif From 12fba70abfe7e8d4f7c3b93e6f3d064fbe74b15c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:28:34 -0500 Subject: [PATCH 094/629] +Standard seamount_initialization axis unit docs Standardized documentation of axis-related variable units and applied dimensional scaling factors to parameters that are read in for use as defaults for other variables in seamount_initialization, including using the new G%x_ax_unit_short elements to automatically write the AXIS_UNITS-dependent units into the MOM_parameter_doc files. Also added comments describing the internal variables in the same module. All answers are bitwise identical but there are minor changes in some MOM_parameter_doc files. --- src/user/seamount_initialization.F90 | 45 +++++++++++++++------------- 1 file changed, 24 insertions(+), 21 deletions(-) diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index dd2e50fcae..a1f978a784 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -40,25 +40,28 @@ module seamount_initialization subroutine seamount_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables + real :: delta ! Height of the seamount as a fraction of the maximum ocean depth [nondim] + real :: x, y ! Normalized positions relative to the domain center [nondim] + real :: Lx, Ly ! Seamount length scales normalized by the relevant domain sizes [nondim] + real :: rLx, rLy ! The Adcroft reciprocals of Lx and Ly [nondim] integer :: i, j - real :: x, y, delta, Lx, rLx, Ly, rLy - call get_param(param_file, mdl,"SEAMOUNT_DELTA",delta, & + call get_param(param_file, mdl,"SEAMOUNT_DELTA", delta, & "Non-dimensional height of seamount.", & - units="non-dim", default=0.5) - call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE",Lx, & + units="nondim", default=0.5) + call get_param(param_file, mdl,"SEAMOUNT_X_LENGTH_SCALE", Lx, & "Length scale of seamount in x-direction. "//& "Set to zero make topography uniform in the x-direction.", & - units="Same as x,y", default=20.) - call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE",Ly, & + units=G%x_ax_unit_short, default=20.) + call get_param(param_file, mdl,"SEAMOUNT_Y_LENGTH_SCALE", Ly, & "Length scale of seamount in y-direction. "//& "Set to zero make topography uniform in the y-direction.", & - units="Same as x,y", default=0.) + units=G%y_ax_unit_short, default=0.) Lx = Lx / G%len_lon Ly = Ly / G%len_lat @@ -93,7 +96,7 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j ! negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface, positive upward [Z ~> m] real :: min_thickness ! The minimum layer thicknesses [Z ~> m]. - real :: S_ref ! A default value for salinities [ppt]. + real :: S_ref ! A default value for salinities [S ~> ppt]. real :: S_surf, S_range, S_light, S_dense ! Various salinities [S ~> ppt]. real :: eta_IC_quanta ! The granularity of quantization of intial interface heights [Z-1 ~> m-1]. character(len=20) :: verticalCoordinate @@ -129,11 +132,11 @@ subroutine seamount_initialize_thickness (h, depth_tot, G, GV, US, param_file, j call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, & - units="ppt", default=35.0, scale=1.0, do_not_log=.true.) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & - units="ppt", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & - units="ppt", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & @@ -208,8 +211,8 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi ! Local variables real :: xi0, xi1 ! Fractional positions within the depth range [nondim] real :: r ! A nondimensional sharpness parameter with an exponetial profile [nondim] - real :: S_Ref ! Default salinity range parameters [ppt]. - real :: T_Ref ! Default temperature range parameters [degC]. + real :: S_Ref ! Default salinity range parameters [S ~> ppt]. + real :: T_Ref ! Default temperature range parameters [C ~> degC]. real :: S_Light, S_Dense, S_surf, S_range ! Salinity range parameters [S ~> ppt]. real :: T_Light, T_Dense, T_surf, T_range ! Temperature range parameters [C ~> degC]. real :: res_rat ! The ratio of density space resolution in the denser part @@ -245,17 +248,17 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi case ( REGRIDDING_LAYER ) ! Initial thicknesses for layer isopycnal coordinates ! These parameters are used in MOM_fixed_initialization.F90 when CONFIG_COORD="ts_range" call get_param(param_file, mdl, "T_REF", T_ref, & - units="degC", default=10.0, do_not_log=.true.) + units="degC", default=10.0, scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_T_LIGHT", T_light, & - units="degC", default=T_Ref, scale=US%degC_to_C, do_not_log=.true.) + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_dense, & - units="degC", default=T_Ref, scale=US%degC_to_C, do_not_log=.true.) + units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, & - units="1e-3", default=35.0, scale=1.0, do_not_log=.true.) + units="1e-3", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & - units="1e-3", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="1e-3", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & - units="1e-3", default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="1e-3", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & units="nondim", default=1.0, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. From 595c8b0ec3e704766f7a1b37f3177c5ac0a2cf5a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:28:57 -0500 Subject: [PATCH 095/629] +Document units in Neverworld_initialization Added units arguments to 2 get_param calls in Neverworld_initialization. This commit also adds comments describing many internal real variables and their units in this same module. All answers and output are bitwise identical, but there are minor changes in the MOM_parameter_doc files. --- src/user/Neverworld_initialization.F90 | 42 +++++++++++++++----------- 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 0ba2cbba01..fcd40cf8da 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -40,12 +40,13 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) ! Local variables real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: x, y + real :: x, y ! Lateral positions normalized by the domain size [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "Neverworld_initialize_topography" ! This subroutine's name. + real :: nl_top_amp ! Amplitude of large-scale topographic features as a fraction of the maximum depth [nondim] + real :: nl_roughness_amp ! Amplitude of topographic roughness as a fraction of the maximum depth [nondim] integer :: i, j, is, ie, js, je, isd, ied, jsd, jed - real :: nl_roughness_amp, nl_top_amp is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -53,16 +54,16 @@ subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "NL_ROUGHNESS_AMP", nl_roughness_amp, & - "Amplitude of wavy signal in bathymetry.", default=0.05) + "Amplitude of wavy signal in bathymetry.", units="nondim", default=0.05) call get_param(param_file, mdl, "NL_CONTINENT_AMP", nl_top_amp, & - "Scale factor for topography - 0.0 for no continents.", default=1.0) + "Scale factor for topography - 0.0 for no continents.", units="nondim", default=1.0) PI = 4.0*atan(1.0) ! Calculate the depth of the bottom. do j=js,je ; do i=is,ie x = (G%geoLonT(i,j)-G%west_lon) / G%len_lon - y =( G%geoLatT(i,j)-G%south_lat) / G%len_lat + y = (G%geoLatT(i,j)-G%south_lat) / G%len_lat ! This sets topography that has a reentrant channel to the south. D(i,j) = 1.0 - 1.1 * spike(y-1,0.12) - 1.1 * spike(y,0.12) - & !< The great northern wall and Antarctica nl_top_amp*( & @@ -83,8 +84,8 @@ end subroutine Neverworld_initialize_topography !> Returns the value of a cosine-bell function evaluated at x/L real function cosbell(x, L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width + real , intent(in) :: x !< non-dimensional position [nondim] + real , intent(in) :: L !< non-dimensional width [nondim] real :: PI !< 3.1415926... calculated as 4*atan(1) PI = 4.0*atan(1.0) @@ -94,8 +95,8 @@ end function cosbell !> Returns the value of a sin-spike function evaluated at x/L real function spike(x, L) - real , intent(in) :: x !< non-dimensional position - real , intent(in) :: L !< non-dimensional width + real , intent(in) :: x !< non-dimensional position [nondim] + real , intent(in) :: L !< non-dimensional width [nondim] real :: PI !< 3.1415926... calculated as 4*atan(1) PI = 4.0*atan(1.0) @@ -127,6 +128,8 @@ real function scurve(x, x0, L) scurve = ( 3. - 2.*s ) * ( s * s ) end function scurve +! None of the following 7 functions appear to be used. + !> Returns a "coastal" profile. real function cstprof(x, x0, L, lf, bf, sf, sh) real, intent(in) :: x !< non-dimensional coordinate [nondim] @@ -228,7 +231,7 @@ real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridg r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height - circ_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 + circ_ridge = 1. - r ! Fractional depths (1-frac_ridge_height) .. 1 end function circ_ridge !> This subroutine initializes layer thicknesses for the Neverworld test case, @@ -253,10 +256,13 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, ! usually negative because it is positive upward. real, dimension(SZK_(GV)) :: h_profile ! Vector of initial thickness profile [Z ~> m]. real :: e_interface ! Current interface position [Z ~> m]. - real :: x,y,r1,r2 ! x,y and radial coordinates for computation of initial pert. - real :: pert_amp ! Amplitude of perturbations measured in Angstrom_H - real :: h_noise ! Amplitude of noise to scale h by - real :: noise ! Noise + real :: x, y ! horizontal coordinates for computation of the initial perturbation normalized + ! by the domain sizes [nondim] + real :: r1, r2 ! radial coordinates for computation of initial perturbation, normalized + ! by the domain sizes [nondim] + real :: pert_amp ! Amplitude of perturbations as a fraction of layer thicknesses [nondim] + real :: h_noise ! Amplitude of noise to scale h by [nondim] + real :: noise ! Fractional noise in the layer thicknesses [nondim] type(randomNumberStream) :: rns ! Random numbers for stochastic tidal parameterization character(len=40) :: mdl = "Neverworld_initialize_thickness" ! This subroutine's name. integer :: i, j, k, is, ie, js, je, nz @@ -283,10 +289,10 @@ subroutine Neverworld_initialize_thickness(h, depth_tot, G, GV, US, param_file, 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 - 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) + 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 * & (spike(r1,0.15)-spike(r2,0.15)) ! Prescribed perturbation if (h_noise /= 0.) then From 17def80b7c816a4309e9ff80008c1f2b535554fc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:29:23 -0500 Subject: [PATCH 096/629] +Document units in RGC_initialization & RGC_tracer Added units arguments to 3 get_param calls in the two RGC modules. Also use elements of the ocean_grid_type to specify the units of some horizontal position related variables and to determine the domain size, rather than using separate get_param calls for LENLAT or LENLAT. This commit also adds comments describing many internal real variables and their units in RGC_tracer.F90. All answers and output are bitwise identical, but there are minor changes in the MOM_parameter_doc files for cases that use the RGC routines. --- src/tracer/RGC_tracer.F90 | 56 ++++++++++++++------------------- src/user/RGC_initialization.F90 | 19 +++-------- 2 files changed, 28 insertions(+), 47 deletions(-) diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 9ceadc602d..7c9b52b66e 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -47,13 +47,11 @@ module RGC_tracer character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry. - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package. - real, pointer :: tr_aux(:,:,:,:) => NULL() !< The masked tracer concentration. - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. - real :: lenlat !< the latitudinal or y-direction length of the domain. - real :: lenlon !< the longitudinal or x-direction length of the domain. - real :: CSL !< The length of the continental shelf (x dir, km) - real :: lensponge !< the length of the sponge layer. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [kg kg-1] + real, pointer :: tr_aux(:,:,:,:) => NULL() !< The masked tracer concentration [kg kg-1] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [kg kg-1] + real :: CSL !< The length of the continental shelf (x direction) [km] + real :: lensponge !< the length of the sponge layer [km] logical :: mask_tracers !< If true, tracers are masked out in massless layers. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the timing of diagnostic output. @@ -72,14 +70,14 @@ function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(RGC_tracer_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). type(tracer_registry_type), pointer :: tr_Reg !< A pointer to the tracer registry. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure character(len=80) :: name, longname ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "RGC_tracer" ! This module's name. character(len=200) :: inputdir - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers in this module [kg kg-1] logical :: register_RGC_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -108,21 +106,15 @@ function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) "The exact location and properties of those sponges are \n"//& "specified from MOM_initialization.F90.", default=.false.) - call get_param(param_file, mdl, "LENLAT", CS%lenlat, & - "The latitudinal or y-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - - call get_param(param_file, mdl, "LENLON", CS%lenlon, & - "The longitudinal or x-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - call get_param(param_file, mdl, "CONT_SHELF_LENGTH", CS%CSL, & "The length of the continental shelf (x dir, km).", & - default=15.0) + units="km", default=15.0) + ! units=G%x_ax_unit_short, default=15.0) call get_param(param_file, mdl, "LENSPONGE", CS%lensponge, & "The length of the sponge layer (km).", & - default=10.0) + units="km", default=10.0) + ! units=G%x_ax_unit_short, default=10.0) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) if (CS%mask_tracers) then @@ -153,13 +145,13 @@ end function register_RGC_tracer subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & layer_CSp, sponge_CSp) - type(ocean_grid_type), intent(in) :: G !< Grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. logical, intent(in) :: restart !< .true. if the fields have already !! been read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness, in m or kg m-2. + intent(in) :: h !< Layer thickness [H ~> m or kg m-2] type(diag_ctrl), target, intent(in) :: diag !< Structure used to regulate diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies !! whether, where, and what open boundary @@ -170,9 +162,9 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & type(ALE_sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure for the !! sponges, if they are in use. Otherwise this may be unassociated. - real, allocatable :: temp(:,:,:) + real, allocatable :: temp(:,:,:) ! A temporary array used for several sponge target values [various] character(len=16) :: name ! A variable's name in a NetCDF file. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers in this module [kg kg-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m @@ -224,7 +216,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (nzdata>0) then allocate(temp(G%isd:G%ied,G%jsd:G%jed,nzdata)) do k=1,nzdata ; do j=js,je ; do i=is,ie - if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then + if (G%geoLonT(i,j) >= (G%len_lon - CS%lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then temp(i,j,k) = 0.0 endif enddo ; enddo ; enddo @@ -240,7 +232,7 @@ subroutine initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS, & if (nz>0) then allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) do k=1,nz ; do j=js,je ; do i=is,ie - if (G%geoLonT(i,j) >= (CS%lenlon - CS%lensponge) .AND. G%geoLonT(i,j) <= CS%lenlon) then + if (G%geoLonT(i,j) >= (G%len_lon - CS%lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then temp(i,j,k) = 0.0 endif enddo ; enddo ; enddo @@ -263,8 +255,8 @@ end subroutine initialize_RGC_tracer !! This is a simple example of a set of advected passive tracers. subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + 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_old !< Layer thickness before entrainment [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -283,22 +275,20 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(RGC_tracer_CS), pointer :: CS !< The control structure returned by a previous call. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can be - !! fluxed out of the top layer in a timestep [nondim]. + !! fluxed out of the top layer in a timestep [nondim]. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes - !! can be applied [H ~> m or kg m-2]. + !! can be applied [H ~> m or kg m-2]. ! The arguments to this subroutine are redundant in that ! h_new[k] = h_old[k] + ea[k] - eb[k-1] + eb[k] - ea[k+1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: in_flux(SZI_(G),SZJ_(G),2) ! total amount of tracer to be injected integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return - in_flux(:,:,:) = 0.0 m=1 do j=js,je ; do i=is,ie ! set tracer to 1.0 in the surface of the continental shelf @@ -313,7 +303,7 @@ subroutine RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo; call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m) , dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth, in_flux(:,:,m)) + evap_CFL_limit, minimum_forcing_depth) call tracer_vertdiff(h_work, ea, eb, dt, CS%tr(:,:,:,m), G, GV) enddo diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index b56e0b895a..e918342d42 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -45,7 +45,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C !! to any available thermodynamic !! fields, potential temperature and !! salinity or mixed layer density. - !! Absent fields have NULL ptrs. + !! Absent fields have NULL pointers. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(in) :: u !< Array with the u velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -72,7 +72,6 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C real :: min_depth ! The minimum depth of the ocean [Z ~> m] real :: dummy1 ! The position relative to the sponge width [nondim] real :: min_thickness ! A minimum layer thickness [H ~> m or kg m-2] (unused) - real :: lenlat, lenlon ! The sizes of the domain [km] real :: lensponge ! The width of the sponge [km] character(len=40) :: filename, state_file character(len=40) :: temp_var, salt_var, eta_var, inputdir, h_var @@ -92,17 +91,9 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C call get_param(PF, mdl, "RGC_TNUDG", TNUDG, 'Nudging time scale for sponge layers', & units='days', default=0.0, scale=86400.0*US%s_to_T) - call get_param(PF, mdl, "LENLAT", lenlat, & - "The latitudinal or y-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - - call get_param(PF, mdl, "LENLON", lenlon, & - "The longitudinal or x-direction length of the domain", & - fail_if_missing=.true., do_not_log=.true.) - call get_param(PF, mdl, "LENSPONGE", lensponge, & - "The length of the sponge layer (km).", & - default=10.0) + "The length of the sponge layer.", & + units=G%x_ax_unit_short, default=10.0) call get_param(PF, mdl, "SPONGE_UV", sponge_uv, & "Nudge velocities (u and v) towards zero in the sponge layer.", & @@ -126,8 +117,8 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C do i=is,ie ; do j=js,je if ((depth_tot(i,j) <= min_depth) .or. (G%geoLonT(i,j) <= lensponge)) then Idamp(i,j) = 0.0 - elseif (G%geoLonT(i,j) >= (lenlon - lensponge) .AND. G%geoLonT(i,j) <= lenlon) then - dummy1 = (G%geoLonT(i,j)-(lenlon - lensponge))/(lensponge) + elseif (G%geoLonT(i,j) >= (G%len_lon - lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then + dummy1 = (G%geoLonT(i,j)-(G%len_lon - lensponge))/(lensponge) Idamp(i,j) = (1.0/TNUDG) * max(0.0,dummy1) else Idamp(i,j) = 0.0 From 1b00485a2655d49492a1017a8f348d5f56684a07 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:29:58 -0500 Subject: [PATCH 097/629] +Document units in adjustment_initialization Add units arguments to 3 get_param calls and modified them in 4 others in adjustment_initialization, using elements of the ocean_grid_type to specify the units of some horizontal position related variables. This commit also adds comments describing many internal real variables and their units in this same file. All answers and output are bitwise identical, but there are minor changes in the MOM_parameter_doc files. --- src/user/adjustment_initialization.F90 | 147 +++++++++++++------------ 1 file changed, 79 insertions(+), 68 deletions(-) diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 3509ef69d3..92a7faf29e 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -46,18 +46,23 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read ! 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 :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. - ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. - real :: x, y, yy - real :: S_ref ! Reference salinity within surface layer [S ~> ppt] - real :: S_range ! Range of salinities in the vertical [S ~> ppt] - real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] - real :: delta_S ! The local salinity perturbation [S ~> ppt] - real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] - real :: min_thickness, adjustment_width, adjustment_delta - real :: adjustment_deltaS - real :: front_wave_amp, front_wave_length, front_wave_asym - real :: target_values(SZK_(GV)+1) ! Target densities or density anomalies [R ~> kg m-3] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. + ! In this subroutine it is hard coded at 1.0 kg m-3 ppt-1. + real :: x, y, yy ! Fractional positions in the x- and y-directions [nondim] + real :: y_lat ! y-positions in the units of latitude [m] or [km] or [degrees] + real :: S_ref ! Reference salinity within surface layer [S ~> ppt] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] + real :: delta_S ! The local salinity perturbation [S ~> ppt] + real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] + real :: min_thickness ! The minimum layer thickness [Z ~> m] + real :: adjustment_delta ! Interface height anomalies, positive downward [Z ~> m] + real :: adjustment_width ! Width of the frontal zone [m] or [km] or [degrees] + real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] + real :: front_wave_amp ! Amplitude of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_length ! Wave-length of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_asym ! Amplitude of frontal asymmetric perturbation [m] or [km] or [degrees] + real :: target_values(SZK_(GV)+1) ! Target densities or density anomalies [R ~> kg m-3] character(len=20) :: verticalCoordinate ! This include declares and sets the variable "version". # include "version_variable.h" @@ -72,30 +77,30 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"MIN_THICKNESS",min_thickness,'Minimum layer thickness', & + call get_param(param_file, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) ! Parameters specific to this experiment configuration - call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"ADJUSTMENT_WIDTH",adjustment_width, & + call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & "Width of frontal zone", & - units="same as x,y", fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"DELTA_S_STRAT",delta_S_strat, & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) + call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & "Top-to-bottom salinity difference of stratification", & units="1e-3", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"ADJUSTMENT_DELTAS",adjustment_deltaS, & + call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & "Salinity difference across front", & units="1e-3", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"FRONT_WAVE_AMP",front_wave_amp, & + call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & "Amplitude of trans-frontal wave perturbation", & - units="same as x,y", default=0., do_not_log=just_read) - call get_param(param_file, mdl,"FRONT_WAVE_LENGTH",front_wave_length, & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & "Wave-length of trans-frontal wave perturbation", & - units="same as x,y", default=0., do_not_log=just_read) - call get_param(param_file, mdl,"FRONT_WAVE_ASYM",front_wave_asym, & + units=G%x_ax_unit_short, default=0., do_not_log=just_read) + call get_param(param_file, mdl, "FRONT_WAVE_ASYM", front_wave_asym, & "Amplitude of frontal asymmetric perturbation", & - units="same as x,y", default=0., do_not_log=just_read) + units=G%x_ax_unit_short, default=0., do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -142,11 +147,11 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / adjustment_width yy = min(1.0, yy); yy = max(-1.0, yy) yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy) else - y = 0. + y_lat = 0. endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width x = min(1.0, x); x = max(-1.0, x) x = x * acos( 0. ) delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) @@ -185,7 +190,7 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read enddo ; enddo case default - call MOM_error(FATAL,"adjustment_initialize_thickness: "// & + call MOM_error(FATAL, "adjustment_initialize_thickness: "// & "Unrecognized i.c. setup - set ADJUSTMENT_IC") end select @@ -197,57 +202,63 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T !< The temperature that is being initialized [C ~> degC] - 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]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: T !< The temperature that is being initialized [C ~> degC] + 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]. 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. - logical, intent(in) :: just_read !< If true, this call will only read - !! parameters without changing T & S. - - integer :: i, j, k, is, ie, js, je, nz - real :: x, y, yy - real :: S_ref ! Reference salinity within surface layer [S ~> ppt] - real :: T_ref ! Reference temperature within surface layer [C ~> degC] - real :: S_range ! Range of salinities in the vertical [S ~> ppt] - real :: T_range ! Range of temperatures in the vertical [C ~> degC] - real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] - real :: delta_S ! The local salinity perturbation [S ~> ppt] - real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] - real :: adjustment_width - real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] - real :: front_wave_amp, front_wave_length, front_wave_asym - real :: eta1d(SZK_(GV)+1) ! Interface heights [Z ~> m] + 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. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + + real :: x, y, yy ! Fractional positions in the x- and y-directions [nondim] + real :: y_lat ! y-position in the units of latitude [m] or [km] or [degrees] + real :: S_ref ! Reference salinity within surface layer [S ~> ppt] + real :: T_ref ! Reference temperature within surface layer [C ~> degC] + real :: S_range ! Range of salinities in the vertical [S ~> ppt] + real :: T_range ! Range of temperatures in the vertical [C ~> degC] + real :: dSdz ! Vertical salinity gradient [S Z-1 ~> ppt m-1] + real :: delta_S ! The local salinity perturbation [S ~> ppt] + real :: delta_S_strat ! Top-to-bottom salinity difference of stratification [S ~> ppt] + real :: adjustment_width ! Width of the frontal zone [m] or [km] or [degrees] + real :: adjustment_deltaS ! Salinity difference across front [S ~> ppt] + real :: front_wave_amp ! Amplitude of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_length ! Wave-length of trans-frontal wave perturbation [m] or [km] or [degrees] + real :: front_wave_asym ! Amplitude of frontal asymmetric perturbation [m] or [km] or [degrees] + real :: eta1d(SZK_(GV)+1) ! Interface heights [Z ~> m] character(len=20) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! Parameters used by main model initialization call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', & + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"S_RANGE", S_range, 'Initial salinity range', & + call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range', & default=2.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', & + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & default=0.0, units='C', scale=US%degC_to_C, do_not_log=just_read) ! Parameters specific to this experiment configuration BUT logged in previous s/r - call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE",verticalCoordinate, & + call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) - call get_param(param_file, mdl,"ADJUSTMENT_WIDTH", adjustment_width, & - fail_if_missing=.not.just_read, do_not_log=.true.) - call get_param(param_file, mdl,"ADJUSTMENT_DELTAS", adjustment_deltaS, & + call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & + units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & units='1e-3', scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) - call get_param(param_file, mdl,"DELTA_S_STRAT", delta_S_strat, & + call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & units='1e-3', scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) - call get_param(param_file, mdl,"FRONT_WAVE_AMP", front_wave_amp, default=0., & - do_not_log=.true.) - call get_param(param_file, mdl,"FRONT_WAVE_LENGTH",front_wave_length, & - default=0., do_not_log=.true.) - call get_param(param_file, mdl,"FRONT_WAVE_ASYM", front_wave_asym, default=0., & - do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) + call get_param(param_file, mdl, "FRONT_WAVE_ASYM", front_wave_asym, & + units=G%x_ax_unit_short, default=0., do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. @@ -269,11 +280,11 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, yy = 2. * ( G%geoLatT(i,j) - 0.5 * G%len_lat ) / front_wave_length yy = min(1.0, yy); yy = max(-1.0, yy) yy = yy * 2. * acos( 0. ) - y = front_wave_amp*sin(y) + front_wave_asym*sin(yy) + y_lat = front_wave_amp*sin(y) + front_wave_asym*sin(yy) else - y = 0. + y_lat = 0. endif - x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y ) / adjustment_width + x = ( ( G%geoLonT(i,j) - 0.5 * G%len_lon ) + y_lat ) / adjustment_width x = min(1.0, x); x = max(-1.0, x) x = x * acos( 0. ) delta_S = adjustment_deltaS * 0.5 * (1. - sin( x ) ) @@ -296,7 +307,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, enddo case default - call MOM_error(FATAL,"adjustment_initialize_temperature_salinity: "// & + call MOM_error(FATAL, "adjustment_initialize_temperature_salinity: "// & "Unrecognized i.c. setup - set ADJUSTMENT_IC") end select From 09d2adfdeeebf4aa6c145ddc527b6aba7f2b25c6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:30:31 -0500 Subject: [PATCH 098/629] +Rescale default salinity in dumbbell_initialization Added an argument documenting the units of S_REF and another rescaling it in dumbbell_initialize_thickness. The units of several other arguments or internal variables in this same file were also described in revised comments. All answers and output are bitwise identical. --- src/user/dumbbell_initialization.F90 | 54 +++++++++++++++------------- 1 file changed, 30 insertions(+), 24 deletions(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 90d745004b..26b382b94c 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -41,18 +41,21 @@ module dumbbell_initialization subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables - integer :: i, j - real :: x, y, dblen, dbfrac - logical :: dbrotate + real :: x, y ! Fractional x- and y- positions [nondim] + real :: dblen ! Lateral length scale for dumbbell [km] or [m] + real :: dbfrac ! Meridional fraction for narrow part of dumbbell [nondim] + logical :: dbrotate ! If true, rotate this configuration + integer :: i, j call get_param(param_file, mdl, "DUMBBELL_LEN",dblen, & 'Lateral Length scale for dumbbell.', & units='km', default=600., do_not_log=.false.) + ! units=G%x_ax_unit_short, default=600., do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_FRACTION",dbfrac, & 'Meridional fraction for narrow part of dumbbell.', & units='nondim', default=0.5, do_not_log=.false.) @@ -60,8 +63,8 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) 'Logical for rotation of dumbbell domain.', & default=.false., do_not_log=.false.) - if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 endif if (dbrotate) then @@ -107,11 +110,12 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward [Z ~> m]. real :: min_thickness ! The minimum layer thicknesses [Z ~> m]. - real :: S_ref ! A default value for salinities [ppt]. + real :: S_ref ! A default value for salinities [S ~> ppt]. real :: S_surf ! The surface salinity [S ~> ppt] real :: S_range ! The range of salinities in this test case [S ~> ppt] real :: S_light, S_dense ! The lightest and densest salinities in the sponges [S ~> ppt]. - real :: eta_IC_quanta ! The granularity of quantization of intial interface heights [Z-1 ~> m-1]. + real :: eta_IC_quanta ! The granularity of quantization of initial interface heights [Z-1 ~> m-1]. + real :: x ! Along-channel position in the axis units [m] or [km] or [deg] logical :: dbrotate ! If true, rotate the domain. logical :: use_ALE ! True if ALE is being used, False if in layered mode @@ -119,7 +123,6 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, # include "version_variable.h" character(len=20) :: verticalCoordinate integer :: i, j, k, is, ie, js, je, nz - real :: x, y is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -153,7 +156,7 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, default=.false., do_not_log=just_read) do j=js,je do i=is,ie - ! Compute normalized zonal coordinates (x,y=0 at center of domain) + ! Compute normalized zonal coordinates (x,y=0 at center of domain) if (dbrotate) then ! This is really y in the rotated case x = G%geoLatT(i,j) @@ -174,18 +177,20 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, do k=1,nz h(i,j,k) = GV%Z_to_H * (eta1D(k) - eta1D(k+1)) enddo - enddo; enddo + enddo + enddo case ( REGRIDDING_RHO, REGRIDDING_HYCOM1) ! Initial thicknesses for isopycnal coordinates call get_param(param_file, mdl, "INITIAL_SSS", S_surf, & units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INITIAL_S_RANGE", S_range, & units='1e-3', default=2., scale=US%ppt_to_S, do_not_log=.true.) - call get_param(param_file, mdl, "S_REF", S_ref, default=35.0, do_not_log=.true.) + call get_param(param_file, mdl, "S_REF", S_ref, & + units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & - units='1e-3', default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units='1e-3', default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & - units='1e-3', default=S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units='1e-3', default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & @@ -263,9 +268,9 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ real :: S_range ! The range of salinities in this test case [S ~> ppt] real :: T_surf ! The surface temperature [C ~> degC] real :: x ! The fractional position in the domain [nondim] - real :: dblen ! The size of the dumbbell test case [axis_units] + real :: dblen ! The size of the dumbbell test case [km] or [m] logical :: dbrotate ! If true, rotate the domain. - logical :: use_ALE ! If false, use layer mode. + logical :: use_ALE ! If false, use layer mode. character(len=20) :: verticalCoordinate, density_profile is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -291,11 +296,12 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & 'Lateral Length scale for dumbbell ', & units='km', default=600., do_not_log=just_read) + ! units=G%x_ax_unit_short, default=600., do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.', & default=.false., do_not_log=just_read) - if (G%x_axis_units == 'm') then + if (G%x_axis_units(1:1) == 'm') then dblen = dblen*1.e3 endif @@ -346,12 +352,12 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil 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, dimension(SZK_(GV)+1) :: eta1D ! interface positions for ALE sponge + 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]. integer :: i, j, k, nz real :: x ! The fractional position in the domain [nondim] - real :: dblen ! The size of the dumbbell test case [axis_units] + 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] logical :: dbrotate ! If true, rotate the domain. @@ -363,8 +369,8 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil 'Logical for rotation of dumbbell domain.', & default=.false., do_not_log=.true.) - if (G%x_axis_units == 'm') then - dblen=dblen*1.e3 + if (G%x_axis_units(1:1) == 'm') then + dblen = dblen*1.e3 endif nz = GV%ke @@ -448,7 +454,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil enddo ; enddo 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 + else do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,1) = 0.0 do k=2,nz @@ -466,7 +472,7 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil ! The remaining calls to set_up_sponge_field can be in any order. ! if ( associated(tv%S) ) call set_up_sponge_field(S, tv%S, G, GV, nz, CSp) - endif + endif end subroutine dumbbell_initialize_sponges From e306cbb88211eb420acd1fdd07521785a2b65aed Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:31:25 -0500 Subject: [PATCH 099/629] +Document variable units in shelfwave_initialization Added or modified units arguments for 4 get_param calls in shelfwave_initialization, although until a full grid_type is provided to the various register OBC calls, the axis units will have to be hard-coded rather than using the fields from the grid_type. Also added or revised comments documenting various internal or control structure variables and their units. All answers and output are bitwise identical, but there are minor changes in the MOM_parameter_doc files. --- src/user/shelfwave_initialization.F90 | 47 ++++++++++++++++----------- 1 file changed, 28 insertions(+), 19 deletions(-) diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index a9c1914356..7d588c49a0 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -31,10 +31,10 @@ module shelfwave_initialization real :: Lx = 100.0 !< Long-shore length scale of bathymetry [km] real :: Ly = 50.0 !< Cross-shore length scale [km] real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] - real :: jj = 1 !< Cross-shore wave mode. - real :: kk !< Parameter. - real :: ll !< Longshore wavenumber. - real :: alpha !< 1/Ly. + real :: jj = 1.0 !< Cross-shore wave mode [nondim] + real :: kk !< Cross-shore wavenumber [km-1] + real :: ll !< Longshore wavenumber [km-1] + real :: alpha !< Exponential decay rate in the y-direction [km-1] real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] end type shelfwave_OBC_CS @@ -45,10 +45,11 @@ function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(OBC_registry_type), pointer :: OBC_Reg !< OBC registry. + type(OBC_registry_type), pointer :: OBC_Reg !< Open boundary condition registry. logical :: register_shelfwave_OBC ! Local variables - real :: PI, len_lat + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: len_lat ! Y-direction size of the domain [km] character(len=32) :: casename = "shelfwave" !< This case's name. @@ -61,21 +62,24 @@ function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) endif allocate(CS) + !### Revise these parameters once the ocean_grid_type is available. + ! Register the tracer for horizontal advection & diffusion. call register_OBC(casename, param_file, OBC_Reg) call get_param(param_file, mdl, "F_0", CS%f0, & default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) call get_param(param_file, mdl, "LENLAT", len_lat, & - do_not_log=.true., fail_if_missing=.true.) - call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH",CS%Lx, & + units="km", do_not_log=.true., fail_if_missing=.true.) + call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH", CS%Lx, & "Length scale of shelfwave in x-direction.",& - units="Same as x,y", default=100.) + units="km", default=100.) ! units="km", default=100.0, scale=1.0e3*US%m_to_L) + ! units=G%x_ax_unit_short, default=100.) call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & - "Length scale of exponential dropoff of topography "//& - "in the y-direction.", & - units="Same as x,y", default=50.) + "Length scale of exponential dropoff of topography in the y-direction.", & + units="km", default=50.) ! units="km", default=50.0, scale=1.0e3*US%m_to_L) + ! units=G%y_ax_unit_short, default=50.) call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & "Cross-shore wave mode.", & units="nondim", default=1.) @@ -107,11 +111,14 @@ subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables + real :: y ! Position relative to the southern boundary [km] or [degrees_N] + real :: rLy ! Exponential decay rate of the topography [km-1] or [degrees_N-1] + real :: Ly ! Exponential decay lengthscale of the topography [km] or [degrees_N] + real :: H0 ! The minimum depth of the ocean [Z ~> m] integer :: i, j - real :: y, rLy, Ly, H0 - call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE",Ly, & - default=50., do_not_log=.true.) + call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE", Ly, & + units=G%y_ax_unit_short, default=50., do_not_log=.true.) call get_param(param_file, mdl,"MINIMUM_DEPTH", H0, & default=10., units="m", scale=US%m_to_Z, do_not_log=.true.) @@ -140,10 +147,13 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! The following variables are used to set up the transport in the shelfwave example. real :: my_amp ! Amplitude of the open boundary current inflows [L T-1 ~> m s-1] real :: time_sec ! The time in the run [T ~> s] - real :: cos_wt, cos_ky, sin_wt, sin_ky + real :: cos_wt, sin_wt ! Cosine and sine associated with the propagating x-direction structure [nondim] + real :: cos_ky, sin_ky ! Cosine and sine associated with the y-direction structure [nondim] real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] - real :: alpha - real :: x, y, jj, kk, ll + real :: alpha ! Exponential decay rate in the y-direction [km-1] + real :: x, y ! Positions relative to the western and southern boundaries [km] + real :: kk ! y-direction wavenumber of the wave [km-1] + real :: ll ! x-direction wavenumber of the wave [km-1] integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() @@ -158,7 +168,6 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) omega = CS%omega alpha = CS%alpha my_amp = 1.0*US%m_s_to_L_T - jj = CS%jj kk = CS%kk ll = CS%ll do n = 1, OBC%number_of_segments From dba12c13b0ab2191391c62ae8affad2d58d891e7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 15 Dec 2022 09:31:53 -0500 Subject: [PATCH 100/629] +Document units in dye_example Added units arguments to 4 get_param calls in dye_example. This commit also adds comments describing the units of several internal real variables in this same file. All answers and output are bitwise identical, but there are minor changes in the MOM_parameter_doc files of cases that use this tracer package. --- src/tracer/dye_example.F90 | 48 ++++++++++++++++++++++---------------- 1 file changed, 28 insertions(+), 20 deletions(-) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 1aae1d3367..2244993447 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -41,14 +41,18 @@ module regional_dyes type, public :: dye_tracer_CS ; private integer :: ntr !< The number of tracers that are actually used. logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. - real, allocatable, dimension(:) :: dye_source_minlon !< Minimum longitude of region dye will be injected. - real, allocatable, dimension(:) :: dye_source_maxlon !< Maximum longitude of region dye will be injected. - real, allocatable, dimension(:) :: dye_source_minlat !< Minimum latitude of region dye will be injected. - real, allocatable, dimension(:) :: dye_source_maxlat !< Maximum latitude of region dye will be injected. + real, allocatable, dimension(:) :: dye_source_minlon !< Minimum longitude of region dye will be + !! injected, in [m] or [km] or [degrees_E] + real, allocatable, dimension(:) :: dye_source_maxlon !< Maximum longitude of region dye will be + !! injected, in [m] or [km] or [degrees_E] + real, allocatable, dimension(:) :: dye_source_minlat !< Minimum latitude of region dye will be + !! injected, in [m] or [km] or [degrees_N] + real, allocatable, dimension(:) :: dye_source_maxlat !< Maximum latitude of region dye will be + !! injected, in [m] or [km] or [degrees_N] real, allocatable, dimension(:) :: dye_source_mindepth !< Minimum depth of region dye will be injected [Z ~> m]. real, allocatable, dimension(:) :: dye_source_maxdepth !< Maximum depth of region dye will be injected [Z ~> m]. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine [CU ~> conc] integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -74,7 +78,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and diffusion module. - type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control structure ! Local variables character(len=40) :: mdl = "regional_dyes" ! This module's name. @@ -82,7 +86,7 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) character(len=48) :: desc_name ! The variable's descriptor. ! This include declares and sets the variable "version". # include "version_variable.h" - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers [CU ~> conc] logical :: register_dye_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -110,28 +114,32 @@ function register_dye_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) CS%dye_source_minlon(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINLON", CS%dye_source_minlon, & "This is the starting longitude at which we start injecting dyes.", & - fail_if_missing=.true.) + units="degrees_E", fail_if_missing=.true.) + ! units=G%x_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_minlon(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINLON ") CS%dye_source_maxlon(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MAXLON", CS%dye_source_maxlon, & "This is the ending longitude at which we finish injecting dyes.", & - fail_if_missing=.true.) + units="degrees_E", fail_if_missing=.true.) + ! units=G%x_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_maxlon(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXLON ") CS%dye_source_minlat(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MINLAT", CS%dye_source_minlat, & "This is the starting latitude at which we start injecting dyes.", & - fail_if_missing=.true.) + units="degrees_N", fail_if_missing=.true.) + ! units=G%y_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_minlat(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MINLAT ") CS%dye_source_maxlat(:) = -1.e30 call get_param(param_file, mdl, "DYE_SOURCE_MAXLAT", CS%dye_source_maxlat, & "This is the ending latitude at which we finish injecting dyes.", & - fail_if_missing=.true.) + units="degrees_N", fail_if_missing=.true.) + ! units=G%y_ax_unit_short, fail_if_missing=.true.) if (minval(CS%dye_source_maxlat(:)) < -1.e29) & call MOM_error(FATAL, "register_dye_tracer: Not enough values provided for DYE_SOURCE_MAXLAT ") @@ -211,10 +219,10 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C do m= 1, CS%ntr do j=G%jsd,G%jed ; do i=G%isd,G%ied ! A dye is set dependent on the center of the cell being inside the rectangular box. - if (CS%dye_source_minlon(m)=G%geoLonT(i,j) .and. & - CS%dye_source_minlat(m)=G%geoLatT(i,j) .and. & + if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & + CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & + CS%dye_source_minlat(m) < G%geoLatT(i,j) .and. & + CS%dye_source_maxlat(m) >= G%geoLatT(i,j) .and. & G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k = 1, GV%ke @@ -264,7 +272,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US !! fluxes can be applied [H ~> m or kg m-2] ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-3] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] integer :: i, j, k, is, ie, js, je, nz, m @@ -292,10 +300,10 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US do m=1,CS%ntr do j=G%jsd,G%jed ; do i=G%isd,G%ied ! A dye is set dependent on the center of the cell being inside the rectangular box. - if (CS%dye_source_minlon(m)=G%geoLonT(i,j) .and. & - CS%dye_source_minlat(m)=G%geoLatT(i,j) .and. & + if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & + CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & + CS%dye_source_minlat(m) < G%geoLatT(i,j) .and. & + CS%dye_source_maxlat(m) >= G%geoLatT(i,j) .and. & G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k=1,nz From 022531cd1a929f8269b83496518cf5ac340bd169 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 17 Dec 2022 08:02:22 -0500 Subject: [PATCH 101/629] Reorder i- and j-loops to be stride-1 in memory Swapped the order of the i- and j- loops in 13 places in 6 files so that they will be stride-1 in memory for efficiency, and to follow the established patterns elsewhere in the MOM6 code. All answers are bitwise identical. --- src/diagnostics/MOM_spatial_means.F90 | 4 ++-- src/initialization/MOM_shared_initialization.F90 | 10 +++++----- src/tracer/MOM_tracer_advect.F90 | 4 ++-- src/user/Phillips_initialization.F90 | 8 ++++---- src/user/RGC_initialization.F90 | 2 +- src/user/benchmark_initialization.F90 | 4 ++-- 6 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 551b821645..502475d3f3 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -367,7 +367,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) asum(j) = real_to_EFP(0.0) ; mask_sum(j) = real_to_EFP(0.0) enddo - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)*mask(i,j)) mask_sum(j+jdg_off) = mask_sum(j+jdg_off) + real_to_EFP(mask(i,j)) enddo ; enddo @@ -392,7 +392,7 @@ subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) else do j=G%jsg,G%jeg ; asum(j) = real_to_EFP(0.0) ; enddo - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie asum(j+jdg_off) = asum(j+jdg_off) + real_to_EFP(scalefac*array(i,j)) enddo ; enddo diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 53bfe851b0..bea5210c2e 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -323,12 +323,12 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth PI = 4.0*atan(1.0) if (trim(topog_config) == "flat") then - do i=is,ie ; do j=js,je ; D(i,j) = max_depth ; enddo ; enddo + do j=js,je ; do i=is,ie ; D(i,j) = max_depth ; enddo ; enddo elseif (trim(topog_config) == "spoon") then D0 = (max_depth - Dedge) / & ((1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay))) * & (1.0 - exp(-0.5*G%len_lat*G%Rad_Earth_L*PI/(180.0 *expdecay)))) - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie ! This sets a bowl shaped (sort of) bottom topography, with a ! ! maximum depth of max_depth. ! D(i,j) = Dedge + D0 * & @@ -343,7 +343,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth ! This sets a bowl shaped (sort of) bottom topography, with a ! maximum depth of max_depth. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie D(i,j) = Dedge + D0 * & (sin(PI * (G%geoLonT(i,j) - G%west_lon) / G%len_lon) * & ((1.0 - exp(-(G%geoLatT(i,j) - G%south_lat)*G%Rad_Earth_L*PI/ & @@ -353,7 +353,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth enddo ; enddo elseif (trim(topog_config) == "halfpipe") then D0 = max_depth - Dedge - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie D(i,j) = Dedge + D0 * ABS(sin(PI*(G%geoLatT(i,j) - G%south_lat)/G%len_lat)) enddo ; enddo else @@ -362,7 +362,7 @@ subroutine initialize_topography_named(D, G, param_file, topog_config, max_depth endif ! This is here just for safety. Hopefully it doesn't do anything. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie if (D(i,j) > max_depth) D(i,j) = max_depth if (D(i,j) < min_depth) D(i,j) = 0.5*min_depth enddo ; enddo diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 6d238a8e86..5abca6e578 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -157,7 +157,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first ! This loop reconstructs the thickness field the last time that the ! tracers were updated, probably just after the diabatic forcing. A useful ! diagnostic could be to compare this reconstruction with that older value. - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie hprev(i,j,k) = max(0.0, G%areaT(i,j)*h_end(i,j,k) + & ((uhr(I,j,k) - uhr(I-1,j,k)) + (vhr(i,J,k) - vhr(i,J-1,k)))) ! In the case that the layer is now dramatically thinner than it was previously, @@ -167,7 +167,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first max(0.0, 1.0e-13*hprev(i,j,k) - G%areaT(i,j)*h_end(i,j,k)) enddo ; enddo else - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie hprev(i,j,k) = vol_prev(i,j,k) enddo ; enddo endif diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 97d26f7ee2..06b3ed43d6 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -68,7 +68,7 @@ subroutine Phillips_initialize_thickness(h, depth_tot, G, GV, US, param_file, ju if (.not.just_read) call log_version(param_file, mdl, version) call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & "The fractional depth where the stratification is centered.", & - units="nondim", default = 0.5, do_not_log=just_read) + units="nondim", default=0.5, do_not_log=just_read) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & fail_if_missing=.not.just_read, do_not_log=just_read) @@ -262,10 +262,10 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) first_call = .false. call get_param(param_file, mdl, "HALF_STRAT_DEPTH", half_strat, & "The fractional depth where the stratificaiton is centered.", & - units="nondim", default = 0.5) + units="nondim", default=0.5) call get_param(param_file, mdl, "SPONGE_RATE", damp_rate, & "The rate at which the zonal-mean sponges damp.", & - units="s-1", default = 1.0/(10.0*86400.0), scale=US%T_to_s) + units="s-1", default=1.0/(10.0*86400.0), scale=US%T_to_s) call get_param(param_file, mdl, "JET_WIDTH", jet_width, & "The width of the zonal-mean jet.", units="km", & @@ -352,7 +352,7 @@ subroutine Phillips_initialize_topography(D, G, param_file, max_depth, US) y1=G%south_lat+0.5*G%len_lat+offset-0.5*Wtop; y2=y1+Wtop x1=G%west_lon+0.1*G%len_lon; x2=x1+Ltop; x3=x1+dist; x4=x3+3.0/2.0*Ltop - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie D(i,j)=0.0 if (G%geoLonT(i,j)>x1 .and. G%geoLonT(i,j)= (G%len_lon - lensponge) .AND. G%geoLonT(i,j) <= G%len_lon) then diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 9ed2881563..7d1656e191 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -268,12 +268,12 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & enddo enddo - do k=1,nz ; do i=is,ie ; do j=js,je + do k=1,nz ; do j=js,je ; do i=is,ie T(i,j,k) = T0(k) S(i,j,k) = S0(k) enddo ; enddo ; enddo PI = 4.0*atan(1.0) - do i=is,ie ; do j=js,je + do j=js,je ; do i=is,ie SST = 0.5*(T0(k1)+T0(nz)) - 0.9*0.5*(T0(k1)-T0(nz)) * & cos(PI*(G%geoLatT(i,j)-G%south_lat)/(G%len_lat)) do k=1,k1-1 From 43fd2e1a13807fad3b2cff2403be8925c71aed31 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sun, 18 Dec 2022 21:56:26 -0500 Subject: [PATCH 102/629] Made STANLEY_COEFF<0 warnings be fatal We were issuing a WARNING when the user indicates to use the STANLEY contribution to density but if the coefficient is negative we were toggling the logical flag but only issuing a warning. This would lead to users getting a result there were not expecting. Better for the run to fail so they can set the coefficient to non-negative. --- src/core/MOM_PressureForce_FV.F90 | 6 ++---- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 6 ++---- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 6 ++---- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 6 ++---- 4 files changed, 8 insertions(+), 16 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 854b6b788c..dfacb40001 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -869,10 +869,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS 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) then - call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_PGF is true.") - CS%use_stanley_pgf = .false. - endif + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_PGF is true.") CS%id_rho_pgf = register_diag_field('ocean_model', 'rho_pgf', diag%axesTL, & Time, 'rho in PGF', 'kg m-3', conversion=US%R_to_kg_m3) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 1aede30a74..2a26349b02 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1214,10 +1214,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) 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) then - call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") - CS%use_stanley_iso = .false. - endif + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") endif if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 5d87761363..94f4468433 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -897,10 +897,8 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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) then - call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ML is true.") - CS%use_stanley_ml = .false. - endif + 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.', & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b8d5e4c89c..33492337a7 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2107,10 +2107,8 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) 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) then - call MOM_error(WARNING, "STANLEY_COEFF must be set >= 0 if USE_STANLEY_GM is true.") - CS%use_stanley_gm = .false. - endif + if (Stanley_coeff < 0.0) call MOM_error(FATAL, & + "STANLEY_COEFF must be set >= 0 if USE_STANLEY_GM is true.") endif call get_param(param_file, mdl, "OMEGA", omega, & "The rotation rate of the earth.", & From 8e603a1cd74ce0625a200f8922070f99afba5892 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Fri, 21 Oct 2022 19:08:43 -0500 Subject: [PATCH 103/629] State-dependent options for diag coordinates Reference pressure and the compressibility fraction could previously only be set for coordinates if they were used as the main prognostic coordinate. This updates the logic to allow these parameters to be changed for diagnostic coordinates. To avoid, naming clashes with the prognostic coordinate, new function was written to construct the correct parameter name. Other places within the codebase where this occurred have subsequently been refactored. --- src/ALE/MOM_regridding.F90 | 42 +++++++++++++++++++++++++++++++------- 1 file changed, 35 insertions(+), 7 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 27dd1ab4d5..e1b4703d7c 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -179,6 +179,9 @@ module MOM_regridding !> Default minimum thickness for some coordinate generation modes real, parameter, public :: regriddingDefaultMinThickness = 1.e-3 +!> Maximum length of parameters +integer, parameter :: MAX_PARAM_LENGTH = 120 + #undef __DO_SAFETY_CHECKS__ contains @@ -199,7 +202,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! Local variables integer :: ke ! Number of levels character(len=80) :: string, string2, varName ! Temporary strings - character(len=40) :: coord_units, param_name, coord_res_param ! Temporary strings + character(len=40) :: coord_units, coord_res_param ! Temporary strings + character(len=MAX_PARAM_LENGTH) :: param_name character(len=200) :: inputdir, fileName character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings @@ -256,7 +260,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = "INTERPOLATION_SCHEME" string2 = regriddingDefaultInterpScheme else - param_name = trim(param_prefix)//"_INTERP_SCHEME_"//trim(param_suffix) + param_name = create_coord_param(param_prefix, "INTERP_SCHEME", param_suffix) string2 = 'PPM_H4' ! Default for diagnostics endif call get_param(param_file, mdl, "INTERPOLATION_SCHEME", string, & @@ -309,8 +313,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m coord_res_param = "ALE_RESOLUTION" string2 = 'UNIFORM' else - param_name = trim(param_prefix)//"_DEF_"//trim(param_suffix) - coord_res_param = trim(param_prefix)//"_RES_"//trim(param_suffix) + param_name = create_coord_param(param_prefix, "DEF", param_suffix) + coord_res_param = create_coord_param(param_prefix, "RES", param_suffix) string2 = 'UNIFORM' if (maximum_depth>3000.) string2='WOA09' ! For convenience endif @@ -545,13 +549,14 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m ! initialise coordinate-specific control structure call initCoord(CS, GV, US, coord_mode, param_file) - if (main_parameters .and. coord_is_state_dependent) then - call get_param(param_file, mdl, "P_REF", P_Ref, & + if (coord_is_state_dependent) then + 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 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) - call get_param(param_file, mdl, "REGRID_COMPRESSIBILITY_FRACTION", tmpReal, & + call get_param(param_file, mdl, create_coord_param(param_prefix, "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), & + tmpReal, & "When interpolating potential density profiles we can add "//& "some artificial compressibility solely to make homogeneous "//& "regions appear stratified.", units="nondim", default=0.) @@ -2564,6 +2569,29 @@ subroutine dz_function1( string, dz ) end subroutine dz_function1 +!> Construct the name of a parameter for a specific coordinate based on param_prefix and param_suffix. For the main, +!! prognostic coordinate this will simply return the parameter name (e.g. P_REF) +function create_coord_param(param_prefix, param_name, param_suffix) result(coord_param) + character(len=*) :: param_name !< The base name of the parameter (e.g. the one used for the main coordinate) + character(len=*) :: param_prefix !< String to prefix to parameter names. + character(len=*) :: param_suffix !< String to append to parameter names. + character(len=MAX_PARAM_LENGTH) :: coord_param !< Parameter name prepended by param_prefix + !! and appended with param_suffix + integer :: out_length + + if (len_trim(param_prefix) + len_trim(param_suffix) == 0) then + coord_param = param_name + else + ! Note the +2 is because of two underscores + out_length = len_trim(param_name)+len_trim(param_prefix)+len_trim(param_suffix)+2 + if (out_length > MAX_PARAM_LENGTH) then + call MOM_error(FATAL,"Coordinate parameter is too long; increase MAX_PARAM_LENGTH") + endif + coord_param = TRIM(param_prefix)//"_"//TRIM(param_name)//"_"//TRIM(param_suffix) + endif + +end function create_coord_param + !> Parses a string and generates a rho_target(:) profile with refined resolution downward !! and returns the number of levels integer function rho_function1( string, rho_target ) From ced34c5c32204676cca9dac3c1b1d358f77b788d Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Wed, 23 Nov 2022 01:11:55 +0000 Subject: [PATCH 104/629] Ensure ref_pressure propagates to RHO/HYCOM CS The ref_pressure was being passed into the set_regrid_params routine, however additional lines needed to be added for the RHO and HYCOM coordinates so that the value would be injected into their control structures. Setting the same target densities for two diagnostic RHO coordinates, but with different reference pressures now yield different results. --- src/ALE/MOM_regridding.F90 | 3 ++- src/ALE/coord_hycom.F90 | 4 +++- src/ALE/coord_rho.F90 | 5 ++++- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e1b4703d7c..ad40239874 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -2437,13 +2437,14 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri if (present(min_thickness)) call set_sigma_params(CS%sigma_CS, min_thickness=min_thickness) case (REGRIDDING_RHO) if (present(min_thickness)) call set_rho_params(CS%rho_CS, min_thickness=min_thickness) + if (present(ref_pressure)) call set_rho_params(CS%rho_CS, ref_pressure=ref_pressure) if (present(integrate_downward_for_e)) & call set_rho_params(CS%rho_CS, integrate_downward_for_e=integrate_downward_for_e) if (associated(CS%rho_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & call set_rho_params(CS%rho_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYCOM1) if (associated(CS%hycom_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & - call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) + call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS, ref_pressure=ref_pressure) case (REGRIDDING_HYBGEN) ! Do nothing for now. case (REGRIDDING_SLIGHT) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 5a3ffaff52..56c0d8d0d1 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -69,11 +69,13 @@ subroutine end_coord_hycom(CS) end subroutine end_coord_hycom !> This subroutine can be used to set the parameters for the coord_hycom module -subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) +subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS, ref_pressure) type(hycom_CS), pointer :: CS !< Coordinate control structure real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation + real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent + !! coordinates [R L2 T-2 ~> Pa] if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 0cbf025b94..8454c4be1d 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -67,12 +67,14 @@ subroutine end_coord_rho(CS) end subroutine end_coord_rho !> This subroutine can be used to set the parameters for the coord_rho module -subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS) +subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS, ref_pressure) type(rho_CS), pointer :: CS !< Coordinate control structure real, optional, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface !! positions from the top downward. If false, integrate !! from the bottom upward, as does the rest of the model. + real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent + !! coordinates [R L2 T-2 ~> Pa] type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation @@ -81,6 +83,7 @@ subroutine set_rho_params(CS, min_thickness, integrate_downward_for_e, interp_CS if (present(min_thickness)) CS%min_thickness = min_thickness if (present(integrate_downward_for_e)) CS%integrate_downward_for_e = integrate_downward_for_e if (present(interp_CS)) CS%interp_CS = interp_CS + if (present(ref_pressure)) CS%ref_pressure = ref_pressure end subroutine set_rho_params !> Build a rho coordinate column From 053752d886e51b63ce4c91da50d8bd5b5e28db41 Mon Sep 17 00:00:00 2001 From: Andrew Shao Date: Mon, 19 Dec 2022 16:25:59 -0800 Subject: [PATCH 105/629] Update diagnostic P_REF description As pointed out by @adcroft, the hybrid coordinate should not generally be used for diagnostic purposes. The description for P_REF when initializing a diagnostic coordinate has been updated to reflect this. --- src/ALE/MOM_regridding.F90 | 20 ++++++++++++++------ src/ALE/coord_hycom.F90 | 4 +--- 2 files changed, 15 insertions(+), 9 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index ad40239874..e28f2c5e82 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -550,11 +550,19 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call initCoord(CS, GV, US, coord_mode, param_file) if (coord_is_state_dependent) then - 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 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) + if (main_parameters) then + 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 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) + 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) + endif call get_param(param_file, mdl, create_coord_param(param_prefix, "REGRID_COMPRESSIBILITY_FRACTION", param_suffix), & tmpReal, & "When interpolating potential density profiles we can add "//& @@ -2444,7 +2452,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri call set_rho_params(CS%rho_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYCOM1) if (associated(CS%hycom_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & - call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS, ref_pressure=ref_pressure) + call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYBGEN) ! Do nothing for now. case (REGRIDDING_SLIGHT) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 56c0d8d0d1..5a3ffaff52 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -69,13 +69,11 @@ subroutine end_coord_hycom(CS) end subroutine end_coord_hycom !> This subroutine can be used to set the parameters for the coord_hycom module -subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS, ref_pressure) +subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) type(hycom_CS), pointer :: CS !< Coordinate control structure real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation - real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent - !! coordinates [R L2 T-2 ~> Pa] if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") From de8023d108daf91ea3af9036dd1e737876622e6d Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 22 Dec 2022 13:09:18 -0500 Subject: [PATCH 106/629] POSIX: siglongjmp and sigsetjmp_missing fixes This patch fixes two issues in the POSIX API. The `siglongjmp` interface was referencing the wrong symbol (`longjmp`). While this did not seem to cause any issues, possibly due to some shared definitions on glibc/BSD platforms, the error was correctly detected by the Cray compiler. This patch corrects the C symbol name. The `sigsetjmp_missing` function, as a default replacement for a missing `sigsetjmp`, was also defined without a return value, since it always returns an error if called at runtime. The Cray compiler raised a warning about this, so we now assign a return value of -1, although it is never used. Thanks to Jim Edwards for reporting these errors. --- src/framework/posix.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 142d7634e2..e5ec0e60d4 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -188,7 +188,7 @@ end subroutine longjmp_posix !> C interface to POSIX siglongjmp() !! Users should use the Fortran-defined siglongjmp() function. - subroutine siglongjmp_posix(env, val) bind(c, name="longjmp") + subroutine siglongjmp_posix(env, val) bind(c, name="siglongjmp") ! #include ! int siglongjmp(jmp_buf env, int val); import :: sigjmp_buf, c_int @@ -360,6 +360,9 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) print '(a)', 'ERROR: sigsetjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DSIGSETJMP_NAME=\"\".' error stop + + ! NOTE: Compilers may expect a return value, even if it is unreachable + rc = -1 end function sigsetjmp_missing end module posix From 7869030ff2f29d3398d50cd233cc126275cfdd71 Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Fri, 23 Dec 2022 06:22:43 -0700 Subject: [PATCH 107/629] Add GL90 parameterization for stacked shallow water (#268) This adds a new vertical viscosity parameterization as in Greatbatch and Lamb (1990), Ferreira & Marshall (2006) and Zhao & Vallis (2008), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, but in a TWA (thickness-weighted averaged) set of equations. The vertical viscosity coefficient nu is computed from kappa_GM via thermal wind balance, and the following relation: nu = kappa_GM * f^2 / N^2. The vertical viscosity del_z ( nu del_z u) is applied to the momentum equation with stress-free boundary conditions at the top and bottom. In the current implementation, kappa_GM is assumed either (a) constant or as (b) having an EBT structure. A third possible formulation of nu is depth-independent: nu = f^2 * alpha The latter formulation would be equivalent to a kappa_GM that varies as N^2 with depth. Currently, the GL90 parameterization is only implemented in stacked shallow water (SSW) mode, in which case we have 1/N^2 = h/g'. More specifically, this commit adds a new subroutine that computes the coupling coefficient associated with GL90 via a_cpl_gl90 = nu / h = kappa_GM * f^2 / g' or a_cpl_gl90 = nu / h = f^2 * alpha / h. Further, a_cpl_gl90 is multiplied by a function (botfn), which is 0 within the GL90 bottom boundary layer, whose depth is set by Hbbl_gl90, and 1 otherwise. This modification is necessary to avoid fluxing momentum into vanished layers that ride over steep topography. Finally, a_cpl_gl90 is added to a_cpl, where the latter is the coupling coefficient associated with the remaining vertical stresses, used in the vertical viscosity solver. More information can be found in Loose et al. (https://www.essoar.org/doi/abs/10.1002/essoar.10512867.1), Appendix B. * Introduce logical variable KD_GL90_USE_EBT_STRUCT This variable is analogous to KHTH_USE_EBT_STRUCT, but is specifically for the GL90 scheme. If the user sets KD_GL90_USE_EBT_STRUCT = True, an EBT structure will be applied to KD_GL90. --- src/core/MOM_dynamics_split_RK2.F90 | 6 +- src/core/MOM_dynamics_unsplit.F90 | 6 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 6 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 14 +- .../vertical/MOM_vert_friction.F90 | 282 +++++++++++++++++- 5 files changed, 289 insertions(+), 25 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index f438c14a05..748748f77f 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -567,7 +567,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -660,7 +660,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & - CS%OBC) + CS%OBC, VarMix) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2)") @@ -880,7 +880,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (G%nonblocking_updates) then diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index bc20c30a0f..a0a6633811 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -345,7 +345,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call disable_averaging(CS%diag) dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred - call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -405,7 +405,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -489,7 +489,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 957306eb3d..85f5d6c546 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -341,7 +341,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) @@ -392,10 +392,10 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 2a26349b02..f5dd0defdc 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -48,6 +48,8 @@ module MOM_lateral_mixing_coeffs !! of first baroclinic wave for calculating the resolution fn. logical :: khth_use_ebt_struct !< If true, uses the equivalent barotropic structure !! as the vertical structure of thickness diffusivity. + logical :: kdgl90_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of diffusivity in the GL90 scheme. logical :: calculate_cg1 !< If true, calls wave_speed() to calculate the first !! baroclinic wave speed and populate CS%cg1. !! This parameter is set depending on other parameters. @@ -229,7 +231,7 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%calculate_cg1) then if (.not. allocated(CS%cg1)) call MOM_error(FATAL, & "calc_resoln_function: %cg1 is not associated with Resoln_scaled_Kh.") - if (CS%khth_use_ebt_struct) then + if (CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then if (.not. allocated(CS%ebt_struct)) call MOM_error(FATAL, & "calc_resoln_function: %ebt_struct is not associated with RESOLN_USE_EBT.") if (CS%Resoln_use_ebt) then @@ -1177,6 +1179,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If true, uses the equivalent barotropic structure "//& "as the vertical structure of thickness diffusivity.",& default=.false.) + call get_param(param_file, mdl, "KD_GL90_USE_EBT_STRUCT", CS%kdgl90_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of diffusivity in the GL90 scheme.",& + default=.false.) call get_param(param_file, mdl, "KHTH_SLOPE_CFF", KhTh_Slope_Cff, & "The nondimensional coefficient in the Visbeck formula "//& "for the interface depth diffusivity", units="nondim", default=0.0) @@ -1194,7 +1200,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=1.0e-17, units="s-1", scale=US%T_to_s) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", use_FGNV_streamfn, & default=.false., do_not_log=.true.) - CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct + CS%calculate_cg1 = CS%calculate_cg1 .or. use_FGNV_streamfn .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct CS%calculate_Rd_dx = CS%calculate_Rd_dx .or. use_MEKE ! Indicate whether to calculate the Eady growth rate CS%calculate_Eady_growth_rate = use_MEKE .or. (KhTr_Slope_Cff>0.) .or. (KhTh_Slope_Cff>0.) @@ -1218,7 +1224,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "STANLEY_COEFF must be set >= 0 if USE_STANLEY_ISO is true.") endif - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) then + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) then in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& @@ -1568,7 +1574,7 @@ end subroutine VarMix_init subroutine VarMix_end(CS) type(VarMix_CS), intent(inout) :: CS - if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct) & + if (CS%Resoln_use_ebt .or. CS%khth_use_ebt_struct .or. CS%kdgl90_use_ebt_struct) & deallocate(CS%ebt_struct) if (CS%use_stored_slopes) then diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index af7ceef46a..eadd35b86e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -13,6 +13,7 @@ module MOM_vert_friction use MOM_forcing_type, only : mech_forcing use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type +use MOM_io, only : MOM_read_data, slasher use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_PointAccel, only : write_u_accel, write_v_accel, PointAccel_init @@ -24,6 +25,7 @@ module MOM_vert_friction use MOM_variables, only : ocean_internal_state use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS +use MOM_lateral_mixing_coeffs, only : VarMix_CS implicit none ; private #include @@ -49,10 +51,24 @@ module MOM_vert_friction !! from the surface; this can get very large with thin layers. real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. + real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [H ~> m or kg m-2]. real :: Kv_extra_bbl !< An extra vertical viscosity in the bottom boundary layer of thickness !! Hbbl when there is not a bottom drag law in use [Z2 T-1 ~> m2 s-1]. real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] + logical :: use_GL90_in_SSW !< If true, use the GL90 parameterization in stacked shallow water mode (SSW). + !! The calculation of the GL90 viscosity coefficient uses the fact that in SSW + !! we simply have 1/N^2 = h/g^prime, where g^prime is the reduced gravity. + !! This identity does not generalize to non-SSW setups. + logical :: use_GL90_N2 !< If true, use GL90 vertical viscosity coefficient that is depth-independent; + !! this corresponds to a kappa_GM that scales as N^2 with depth. + real :: kappa_gl90 !< The scalar diffusivity used in the GL90 vertical viscosity scheme + !! [L2 T-1 ~> m2 s-1] + logical :: read_kappa_gl90 !< If true, read a file containing the spatially varying kappa_gl90 + real :: alpha_gl90 !< Coefficient used to compute a depth-independent GL90 vertical + !! viscosity via Kv_gl90 = alpha_gl90 * f^2. Note that the implied + !! Kv_gl90 corresponds to a kappa_gl90 that scales as N^2 with depth. + !! [L2 T ~> m2 s] real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1]. real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. @@ -73,10 +89,14 @@ module MOM_vert_friction real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & a_u !< The u-drag coefficient across an interface [Z T-1 ~> m s-1]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & + a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [Z T-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & h_u !< The effective layer thickness at u-points [H ~> m or kg m-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & a_v !< The v-drag coefficient across an interface [Z T-1 ~> m s-1]. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & + a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [Z T-1 ~> m s-1]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & h_v !< The effective layer thickness at v-points [H ~> m or kg m-2]. real, pointer, dimension(:,:) :: a1_shelf_u => NULL() !< The u-momentum coupling coefficient under @@ -133,6 +153,7 @@ module MOM_vert_friction type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. + real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 T-1 ~> m2 s-1] !>@{ Diagnostic identifiers integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 @@ -154,6 +175,119 @@ module MOM_vert_friction contains +!> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb +!! (1990), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme +!! redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, +!! but in a TWA (thickness-weighted averaged) set of equations. The vertical viscosity coefficient nu is computed +!! from kappa_GM via thermal wind balance, and the following relation: +!! nu = kappa_GM * f^2 / N^2. +!! In the following subroutine kappa_GM is assumed either (a) constant or (b) horizontally varying. In both cases, +!! (a) and (b), one can additionally impose an EBT structure in the vertical for kappa_GM. +!! A third possible formulation of nu is depth-independent: +!! nu = f^2 * alpha +!! The latter formulation would be equivalent to a kappa_GM that varies as N^2 with depth. +!! The vertical viscosity del_z ( nu del_z u) is applied to the momentum equation with stress-free boundary +!! conditions at the top and bottom. +!! +!! In SSW mode, we have 1/N^2 = h/g'. The coupling coefficient is therefore equal to +!! a_cpl_gl90 = nu / h = kappa_GM * f^2 / g' +!! or +!! a_cpl_gl90 = nu / h = f^2 * alpha / h + +subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, VarMix, work_on_u) + type(ocean_grid_type), intent(in) :: G !< Grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Layer thickness used at a velocity + !! grid point [H ~> m or kg m-2]. + logical, dimension(SZIB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient + !! for a column + real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the + !! bottom, normalized by the GL90 bottom + !! boundary layer thickness + real, dimension(SZIB_(G),SZK_(GV)+1), intent(inout) :: a_cpl_gl90 !< Coupling coefficient associated + !! with GL90 across interfaces; is not + !! included in a_cpl [Z T-1 ~> m s-1]. + integer, intent(in) :: j !< j-index to find coupling coefficient for + type(vertvisc_cs), pointer :: CS !< Vertical viscosity control structure + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients + logical, intent(in) :: work_on_u !< If true, u-points are being calculated, + !! otherwise they are v-points. + + ! local variables + logical :: kdgl90_use_ebt_struct + integer :: i, k, is, ie, nz, Isq, Ieq + real :: f2 !< Squared Coriolis parameter at a + !! velocity grid point [T-2 ~> s-2]. + real :: h_neglect ! A thickness that is so small + !! it is usually lost in roundoff error + !! and can be neglected [H ~> m or kg m-2]. + real :: botfn ! A function that is 1 at the bottom + !! and small far from it [nondim] + real :: z2 ! The distance from the bottom, + !! normalized by Hbbl_gl90 [nondim] + + is = G%isc ; ie = G%iec + Isq = G%IscB ; Ieq = G%IecB + nz = GV%ke + + h_neglect = GV%H_subroundoff + kdgl90_use_ebt_struct = .false. + if (VarMix%use_variable_mixing) then + kdgl90_use_ebt_struct = VarMix%kdgl90_use_ebt_struct + endif + + if (work_on_u) then + ! compute coupling coefficient at u-points + do I=Isq,Ieq; if (do_i(I)) then + f2 = 0.25 * (G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J))**2 + do K=2,nz + if (CS%use_GL90_N2) then + a_cpl_gl90(I,K) = 2.0 * f2 * CS%alpha_gl90 / (hvel(I,k) + hvel(I,k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(I,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i+1,j)) / GV%g_prime(K) + else + a_cpl_gl90(I,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + endif + if (kdgl90_use_ebt_struct) then + a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + endif + endif + ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(I,k) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + a_cpl_gl90(I,K) = a_cpl_gl90(I,K) * (1 - botfn) + enddo + endif; enddo + else + ! compute viscosities at v-points + do i=is,ie; if (do_i(i)) then + f2 = 0.25 * (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J))**2 + do K=2,nz + if (CS%use_GL90_N2) then + a_cpl_gl90(i,K) = 2.0 * f2 * CS%alpha_gl90 / (hvel(i,k) + hvel(i,k-1) + h_neglect) + else + if (CS%read_kappa_gl90) then + a_cpl_gl90(i,K) = f2 * 0.5 * (CS%kappa_gl90_2d(i,j) + CS%kappa_gl90_2d(i,j+1)) / GV%g_prime(K) + else + a_cpl_gl90(i,K) = f2 * CS%kappa_gl90 / GV%g_prime(K) + endif + if (kdgl90_use_ebt_struct) then + a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + endif + endif + ! botfn determines when a point is within the influence of the GL90 bottom boundary layer, + ! going from 1 at the bottom to 0 in the interior. + z2 = z_i(i,k) + botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) + a_cpl_gl90(i,K) = a_cpl_gl90(i,K) * (1 - botfn) + enddo + endif; enddo + endif + +end subroutine find_coupling_coef_gl90 + !> Perform a fully implicit vertical diffusion !! of momentum. Stress top and bottom boundary conditions are used. !! @@ -671,10 +805,10 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) end subroutine vertvisc_remnant -!> Calculate the coupling coefficients (CS%a_u and CS%a_v) +!> Calculate the coupling coefficients (CS%a_u, CS%a_v, CS%a_u_gl90, CS%a_v_gl90) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) +subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -689,7 +823,7 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure - + type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients ! Field from forces used in this subroutine: ! ustar: the friction velocity [Z T-1 ~> m s-1], used here as the mixing ! velocity in the mixed layer if NKML > 1 in a bulk mixed layer. @@ -706,14 +840,21 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) real, dimension(SZIB_(G),SZK_(GV)+1) :: & a_cpl, & ! The drag coefficients across interfaces [Z T-1 ~> m s-1]. a_cpl times ! the velocity difference gives the stress across an interface. + a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [Z T-1 ~> m s-1]. + ! a_cpl_gl90 times the velocity difference gives the GL90 stress across an interface. + ! a_cpl_gl90 is part of a_cpl. a_shelf, & ! The drag coefficients across interfaces in water columns under ! ice shelves [Z T-1 ~> m s-1]. - z_i ! An estimate of each interface's height above the bottom, + z_i, & ! An estimate of each interface's height above the bottom, ! normalized by the bottom boundary layer thickness [nondim] + z_i_gl90 ! An estimate of each interface's height above the bottom, + ! normalized by the GL90 bottom boundary layer thickness [nondim] real, dimension(SZIB_(G)) :: & kv_bbl, & ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. bbl_thick, & ! The bottom boundary layer thickness [H ~> m or kg m-2]. I_Hbbl, & ! The inverse of the bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. + I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme + ! [H-1 ~> m-1 or m2 kg-1]. I_Htbl, & ! The inverse of the top boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. zcol1, & ! The height of the interfaces to the north and south of a zcol2, & ! v-point [H ~> m or kg m-2]. @@ -761,6 +902,9 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) h_neglect = GV%H_subroundoff a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) + if (CS%use_GL90_in_SSW) then + I_Hbbl_gl90 = 1.0 / (CS%Hbbl_gl90 + h_neglect) + endif I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val if (CS%id_Kv_u > 0) allocate(Kv_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) @@ -864,6 +1008,23 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) + a_cpl_gl90(:,:) = 0.0 + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 + ! BBL (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the GL90 + ! coupling coefficient is zeroed out within Hbbl_gl90, to ensure that + ! no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + do I=Isq,Ieq ; z_i_gl90(I,nz+1) = 0.0 ; enddo + do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + z_i_gl90(I,k) = z_i_gl90(I,k+1) + h_harm(I,k)*I_Hbbl_gl90(I) + endif ; enddo ; enddo ! i & k loops + call find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) + endif + if (allocated(hML_u)) then do i=isq,ieq ; if (do_i(i)) then ; hML_u(I,j) = h_ml(I) ; endif ; enddo endif @@ -913,13 +1074,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i_shelf(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * a_shelf(I,K) + & - (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) + CS%a_u(I,j,K) = min(a_cpl_max, (forces%frac_shelf_u(I,j) * a_shelf(I,K) + & + (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) + a_cpl_gl90(I,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH ! CS%a_u(I,j,K) = min(a_cpl_max, forces%frac_shelf_u(I,j) * max(a_shelf(I,K), a_cpl(I,K)) + & ! (1.0-forces%frac_shelf_u(I,j)) * a_cpl(I,K)) elseif (do_i(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) endif ; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i_shelf(I)) then ! Should we instead take the inverse of the average of the inverses? @@ -929,7 +1091,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_u(I,j,k) = hvel(I,k) + h_neglect endif ; enddo ; enddo else - do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K)) ; enddo ; enddo + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) + endif; enddo ; enddo + do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) + endif; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo endif @@ -1031,6 +1198,25 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) + a_cpl_gl90(:,:) = 0.0 + if (CS%use_GL90_in_SSW) then + ! The following block calculates the normalized height above the GL90 + ! BBL (z_i_gl90), using a harmonic mean between layer thicknesses. For the + ! GL90 BBL we use simply a constant (Hbbl_gl90). The purpose is that the GL90 + ! coupling coefficient is zeroed out within Hbbl_gl90, to ensure that + ! no momentum gets fluxed into vanished layers. The scheme is not + ! sensitive to the exact value of Hbbl_gl90, as long as it is in a + ! reasonable range (~1-20 m): large enough to capture vanished layers + ! over topography, small enough to not contaminate the interior. + do i=is,ie ; z_i_gl90(i,nz+1) = 0.0 ; enddo + + do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then + z_i_gl90(i,k) = z_i_gl90(i,k+1) + h_harm(i,k)*I_Hbbl_gl90(i) + endif ; enddo ; enddo ! i & k loops + + call find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) + endif + if ( allocated(hML_v)) then do i=is,ie ; if (do_i(i)) then ; hML_v(i,J) = h_ml(i) ; endif ; enddo endif @@ -1079,13 +1265,14 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) if (do_any_shelf) then do K=1,nz+1 ; do i=is,ie ; if (do_i_shelf(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * a_shelf(i,k) + & - (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) + CS%a_v(i,J,K) = min(a_cpl_max, (forces%frac_shelf_v(i,J) * a_shelf(i,k) + & + (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) + a_cpl_gl90(i,K)) ! This is Alistair's suggestion, but it destabilizes the model. I do not know why. RWH ! CS%a_v(i,J,K) = min(a_cpl_max, forces%frac_shelf_v(i,J) * max(a_shelf(i,K), a_cpl(i,K)) + & ! (1.0-forces%frac_shelf_v(i,J)) * a_cpl(i,K)) elseif (do_i(i)) then - CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K) + a_cpl_gl90(i,K)) + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i_shelf(i)) then ! Should we instead take the inverse of the average of the inverses? @@ -1095,7 +1282,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC) CS%h_v(i,J,k) = hvel(i,k) + h_neglect endif ; enddo ; enddo else - do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K)) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then + CS%a_v(i,J,K) = min(a_cpl_max, a_cpl(i,K) + a_cpl_gl90(i,K)) + endif ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then + CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) + endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif @@ -1798,6 +1990,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & !! use an arbitrary and hard-coded maximum viscous coupling coefficient !! between layers. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz + character(len=200) :: kappa_gl90_file, inputdir, kdgl90_varname ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_vert_friction" ! This module's name. @@ -1917,6 +2110,68 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true., scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "USE_GL90_IN_SSW", CS%use_GL90_in_SSW, & + "If true, use simpler method to calculate 1/N^2 in GL90 vertical "// & + "viscosity coefficient. This method is valid in stacked shallow water mode.", & + default=.false.) + call get_param(param_file, mdl, "KD_GL90", CS%kappa_gl90, & + "The scalar diffusivity used in GL90 vertical viscosity "//& + "scheme.", units="m2 s-1", default=0.0, & + scale=US%m_to_Z**2*US%T_to_s, do_not_log=.not.CS%use_GL90_in_SSW) + call get_param(param_file, mdl, "READ_KD_GL90", CS%read_kappa_gl90, & + "If true, read a file (given by KD_GL90_FILE) containing the "//& + "spatially varying diffusivity KD_GL90 used in the GL90 scheme.", default=.false., & + do_not_log=.not.CS%use_GL90_in_SSW) + if (CS%read_kappa_gl90) then + if (CS%kappa_gl90 > 0) then + call MOM_error(FATAL, "MOM_vert_friction.F90, vertvisc_init: KD_GL90 > 0 "// & + "is not compatible with READ_KD_GL90 = .TRUE. ") + endif + call get_param(param_file, mdl, "INPUTDIR", inputdir, & + "The directory in which all input files are found.", & + default=".", do_not_log=.true.) + inputdir = slasher(inputdir) + call get_param(param_file, mdl, "KD_GL90_FILE", kappa_gl90_file, & + "The file containing the spatially varying diffusivity used in the "// & + "GL90 scheme.", default="kd_gl90.nc", do_not_log=.not.CS%use_GL90_in_SSW) + call get_param(param_file, mdl, "KD_GL90_VARIABLE", kdgl90_varname, & + "The name of the GL90 diffusivity variable to read "//& + "from KD_GL90_FILE.", default="kd_gl90", do_not_log=.not.CS%use_GL90_in_SSW) + kappa_gl90_file = trim(inputdir) // trim(kappa_gl90_file) + + allocate(CS%kappa_gl90_2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) + call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call pass_var(CS%kappa_gl90_2d, G%domain) + endif + call get_param(param_file, mdl, "USE_GL90_N2", CS%use_GL90_N2, & + "If true, use GL90 vertical viscosity coefficient that is depth-independent; "// & + "this corresponds to a kappa_GM that scales as N^2 with depth.", & + default=.false., do_not_log=.not.CS%use_GL90_in_SSW) + if (CS%use_GL90_N2) then + if (.not. CS%use_GL90_in_SSW) call MOM_error(FATAL, & + "MOM_vert_friction.F90, vertvisc_init: "//& + "When USE_GL90_N2=True, USE_GL90_in_SSW must also be True.") + if (CS%kappa_gl90 > 0) then + call MOM_error(FATAL, "MOM_vert_friction.F90, vertvisc_init: KD_GL90 > 0 "// & + "is not compatible with USE_GL90_N2 = .TRUE. ") + endif + if (CS%read_kappa_gl90) call MOM_error(FATAL, & + "MOM_vert_friction.F90, vertvisc_init: "//& + "READ_KD_GL90 = .TRUE. is not compatible with USE_GL90_N2 = .TRUE.") + call get_param(param_file, mdl, "alpha_GL90", CS%alpha_gl90, & + "Coefficient used to compute a depth-independent GL90 vertical "//& + "viscosity via Kv_GL90 = alpha_GL90 * f2. Is only used "// & + "if USE_GL90_N2 is true. Note that the implied Kv_GL90 "// & + "corresponds to a KD_GL90 that scales as N^2 with depth.", & + units="m2 s", default=0.0, scale=US%m_to_Z**2*US%s_to_T, & + do_not_log=.not.CS%use_GL90_in_SSW) + endif + call get_param(param_file, mdl, "HBBL_GL90", CS%Hbbl_gl90, & + "The thickness of the GL90 bottom boundary layer, "//& + "which defines the range over which the GL90 coupling "//& + "coefficient is zeroed out, in order to avoid fluxing "//& + "momentum into vanished layers over steep topography.", & + units="m", default=5.0, scale=GV%m_to_H, do_not_log=.not.CS%use_GL90_in_SSW) CS%Kvml_invZ2 = 0.0 if (GV%nkml < 1) then @@ -2021,8 +2276,10 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "the age of the universe.", units="m s-1", default=0.0, scale=US%m_s_to_L_T) ALLOC_(CS%a_u(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u(:,:,:) = 0.0 + ALLOC_(CS%a_u_gl90(IsdB:IedB,jsd:jed,nz+1)) ; CS%a_u_gl90(:,:,:) = 0.0 ALLOC_(CS%h_u(IsdB:IedB,jsd:jed,nz)) ; CS%h_u(:,:,:) = 0.0 ALLOC_(CS%a_v(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v(:,:,:) = 0.0 + ALLOC_(CS%a_v_gl90(isd:ied,JsdB:JedB,nz+1)) ; CS%a_v_gl90(:,:,:) = 0.0 ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & @@ -2218,6 +2475,7 @@ subroutine vertvisc_end(CS) DEALLOC_(CS%a_v) ; DEALLOC_(CS%h_v) if (associated(CS%a1_shelf_u)) deallocate(CS%a1_shelf_u) if (associated(CS%a1_shelf_v)) deallocate(CS%a1_shelf_v) + if (allocated(CS%kappa_gl90_2d)) deallocate(CS%kappa_gl90_2d) end subroutine vertvisc_end !> \namespace mom_vert_friction From 747eeffcb5d641f949236e74eb823af6d802e109 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 16 Dec 2022 06:39:05 -0500 Subject: [PATCH 108/629] Rescale internal vars in reset_face_lengths_list Apply dimensional rescaling immediately after reading the open face width and porous barrier depth variables in reset_face_lengths_list to facilitate the detection of improperly scaled variables or incorrect unit declarations throughout the code. Also eliminated unnecessary local copies of rescaling factors in the MOM_porous_barriers module. All answers are bitwise identical. --- src/core/MOM_porous_barriers.F90 | 33 ++++++++----------- .../MOM_shared_initialization.F90 | 30 ++++++++++------- 2 files changed, 32 insertions(+), 31 deletions(-) diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index 0e48cf07fd..c1eb749467 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -69,8 +69,8 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: eta_bt !< optional barotropic variable !! used to dilate the layer thicknesses !! [H ~> m or kg m-2]. - type(porous_barrier_type), intent(inout) :: pbv !< porous barrier fractional cell metrics - type(porous_barrier_CS), intent(in) :: CS !< Control structure for porous barrier + type(porous_barrier_type), intent(inout) :: pbv !< porous barrier fractional cell metrics + type(porous_barrier_CS), intent(in) :: CS !< Control structure for porous barrier !local variables real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: eta_u ! Layer interface heights at u points [Z ~> m] @@ -80,9 +80,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points ! updated while moving up layers real :: A_layer ! Integral of fractional open width from bottom to current layer [Z ~> m] - real :: Z_to_eta, H_to_eta ! Unit conversion factors for eta. - real :: h_neglect, & ! Negligible thicknesses, often [Z ~> m] - h_min ! ! The minimum layer thickness, often [Z ~> m] + real :: h_min ! ! The minimum layer thickness [Z ~> m] real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -102,9 +100,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) - Z_to_eta = 1.0 - H_to_eta = GV%H_to_m * US%m_to_Z * Z_to_eta - h_min = GV%Angstrom_H * H_to_eta + h_min = GV%Angstrom_H * GV%H_to_Z ! u-points do j=js,je ; do I=Isq,Ieq ; do_I(I,j) = .False. ; enddo ; enddo @@ -203,8 +199,6 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: eta_v ! Layer interface height at v points [Z ~> m] logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points ! updated while moving up layers - real :: Z_to_eta, H_to_eta ! Unit conversion factors for eta. - real :: h_neglect ! Negligible thicknesses, often [Z ~> m] real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -292,8 +286,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m or 1/eta_to_m]. - real :: Z_to_eta, H_to_eta ! Unit conversion factors for eta. - real :: h_neglect ! Negligible thicknesses, often [Z ~> m] + real :: h_neglect ! Negligible thicknesses [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke @@ -302,9 +295,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) ! currently no treatment for using optional find_eta arguments if present call find_eta(h, tv, G, GV, US, eta, halo_size=1) - Z_to_eta = 1.0 - H_to_eta = GV%H_to_m * US%m_to_Z * Z_to_eta - h_neglect = GV%H_subroundoff * H_to_eta + h_neglect = GV%H_subroundoff * GV%H_to_Z do K=1,nk+1 do j=js,je ; do I=Isq,Ieq ; eta_u(I,j,K) = dmask ; enddo ; enddo @@ -365,8 +356,8 @@ subroutine calc_por_layer(D_min, D_max, D_avg, eta_layer, A_layer, do_next) logical, intent(out) :: do_next !< False if eta_layer>D_max ! local variables - real :: m, & ! convenience constant for fit [nondim] - zeta ! normalized vertical coordinate [nondim] + real :: m ! convenience constant for fit [nondim] + real :: zeta ! normalized vertical coordinate [nondim] do_next = .True. if (eta_layer <= D_min) then @@ -398,8 +389,8 @@ subroutine calc_por_interface(D_min, D_max, D_avg, eta_layer, w_layer, do_next) logical, intent(out) :: do_next !< False if eta_layer>D_max ! local variables - real :: m, a, & ! convenience constant for fit [nondim] - zeta ! normalized vertical coordinate [nondim] + real :: m, a ! convenience constants for fit [nondim] + real :: zeta ! normalized vertical coordinate [nondim] do_next = .True. if (eta_layer <= D_min) then @@ -407,12 +398,14 @@ subroutine calc_por_interface(D_min, D_max, D_avg, eta_layer, w_layer, do_next) elseif (eta_layer > D_max) then w_layer = 1.0 do_next = .False. - else + else ! The following option could be refactored for stability and efficiency (with fewer divisions) m = (D_avg - D_min) / (D_max - D_min) a = (1.0 - m) / m zeta = (eta_layer - D_min) / (D_max - D_min) if (m < 0.5) then w_layer = zeta**(1.0 / a) + ! Note that this would be safer and more efficent if it were rewritten as: + ! w_layer = zeta**( (D_avg - D_min) / (D_max - D_avg) ) elseif (m == 0.5) then w_layer = zeta else diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index bea5210c2e..73be3f5843 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -819,14 +819,14 @@ subroutine reset_face_lengths_list(G, param_file, US) real, allocatable, dimension(:,:) :: & u_lat, u_lon, v_lat, v_lon ! The latitude and longitude ranges of faces [degrees_N] or [degrees_E] real, allocatable, dimension(:) :: & - u_width, v_width ! The open width of faces [m] + u_width, v_width ! The open width of faces [L ~> m] integer, allocatable, dimension(:) :: & u_line_no, v_line_no, & ! The line numbers in lines of u- and v-face lines u_line_used, v_line_used ! The number of times each u- and v-line is used. real, allocatable, dimension(:) :: & - Dmin_u, Dmax_u, Davg_u ! Porous barrier monomial fit params [m] + Dmin_u, Dmax_u, Davg_u ! Porous barrier monomial fit params [Z ~> m] real, allocatable, dimension(:) :: & - Dmin_v, Dmax_v, Davg_v ! Porous barrier monomial fit params [m] + Dmin_v, Dmax_v, Davg_v ! Porous barrier monomial fit params [Z ~> m] real :: lat, lon ! The latitude and longitude of a point [degrees_N] and [degrees_E]. real :: len_lon ! The periodic range of longitudes, usually 360 degrees [degrees_E]. real :: len_lat ! The range of latitudes, usually 180 degrees [degrees_N]. @@ -945,6 +945,10 @@ subroutine reset_face_lengths_list(G, param_file, US) read(line(isu_por+12:),*) u_lon(1:2,u_pt), u_lat(1:2,u_pt), u_width(u_pt), & Dmin_u(u_pt), Dmax_u(u_pt), Davg_u(u_pt) endif + u_width(u_pt) = US%m_to_L*u_width(u_pt) ! Rescale units equivalently to scale=US%m_to_L during read. + Dmin_u(u_pt) = US%m_to_Z*Dmin_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Dmax_u(u_pt) = US%m_to_Z*Dmax_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Davg_u(u_pt) = US%m_to_Z*Davg_u(u_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. u_line_no(u_pt) = ln if (is_root_PE()) then if (check_360) then @@ -982,6 +986,10 @@ subroutine reset_face_lengths_list(G, param_file, US) read(line(isv+12:),*) v_lon(1:2,v_pt), v_lat(1:2,v_pt), v_width(v_pt), & Dmin_v(v_pt), Dmax_v(v_pt), Davg_v(v_pt) endif + v_width(v_pt) = US%m_to_L*v_width(v_pt) ! Rescale units equivalently to scale=US%m_to_L during read. + Dmin_v(v_pt) = US%m_to_Z*Dmin_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Dmax_v(v_pt) = US%m_to_Z*Dmax_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. + Davg_v(v_pt) = US%m_to_Z*Davg_v(v_pt) ! Rescale units equivalently to scale=US%m_to_Z during read. v_line_no(v_pt) = ln if (is_root_PE()) then if (check_360) then @@ -1027,10 +1035,10 @@ subroutine reset_face_lengths_list(G, param_file, US) ((lon_p >= u_lon(1,npt)) .and. (lon_p <= u_lon(2,npt))) .or. & ((lon_m >= u_lon(1,npt)) .and. (lon_m <= u_lon(2,npt)))) ) then - G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(US%m_to_L*u_width(npt), 0.0)) - G%porous_DminU(I,j) = US%m_to_Z*Dmin_u(npt) - G%porous_DmaxU(I,j) = US%m_to_Z*Dmax_u(npt) - G%porous_DavgU(I,j) = US%m_to_Z*Davg_u(npt) + G%dy_Cu(I,j) = G%mask2dCu(I,j) * min(G%dyCu(I,j), max(u_width(npt), 0.0)) + G%porous_DminU(I,j) = Dmin_u(npt) + G%porous_DmaxU(I,j) = Dmax_u(npt) + G%porous_DavgU(I,j) = Davg_u(npt) if (j>=G%jsc .and. j<=G%jec .and. I>=G%isc .and. I<=G%iec) then ! Limit messages/checking to compute domain if ( G%mask2dCu(I,j) == 0.0 ) then @@ -1064,10 +1072,10 @@ subroutine reset_face_lengths_list(G, param_file, US) (((lon >= v_lon(1,npt)) .and. (lon <= v_lon(2,npt))) .or. & ((lon_p >= v_lon(1,npt)) .and. (lon_p <= v_lon(2,npt))) .or. & ((lon_m >= v_lon(1,npt)) .and. (lon_m <= v_lon(2,npt)))) ) then - G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(US%m_to_L*v_width(npt), 0.0)) - G%porous_DminV(i,J) = US%m_to_Z*Dmin_v(npt) - G%porous_DmaxV(i,J) = US%m_to_Z*Dmax_v(npt) - G%porous_DavgV(i,J) = US%m_to_Z*Davg_v(npt) + G%dx_Cv(i,J) = G%mask2dCv(i,J) * min(G%dxCv(i,J), max(v_width(npt), 0.0)) + G%porous_DminV(i,J) = Dmin_v(npt) + G%porous_DmaxV(i,J) = Dmax_v(npt) + G%porous_DavgV(i,J) = Davg_v(npt) if (i>=G%isc .and. i<=G%iec .and. J>=G%jsc .and. J<=G%jec) then ! Limit messages/checking to compute domain if ( G%mask2dCv(i,J) == 0.0 ) then From 3794b83f7eea62a7a95a693e0c918aae881c43f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 16 Dec 2022 18:27:03 -0500 Subject: [PATCH 109/629] (+)Better units documentation in tracer_hordiff This commit includes minor cleanup of the units documentation in several of the process parameterization routines. These changes include: - Change the units of the (apparently unused) optional read_khdt_[xy] arguments to tracer_hordiff from [m2] to [L2 ~> m2] - Correct a tiny number used for safety in the denominator of a normalization factor based on the (nondimensional) masks from H_subroundoff to a tiny nondimensional number, giving an expression that is dimensionally consistent. Without this change, the diagnostic "KHTR_h" will vary with large enough negative values of H_RESCALE_POWER. - Replace a local variable in bulkmixedlayer_init with units of time with distinct get_param calls setting the default for BUFFER_LAY_DETRAIN_TIME depending on which buffer layer detrainment scheme is used. - Correct the dimensions of the "land_mask" diagnostic internal_tides_init from "logical" to "nondim", because it is a real multiplicable mask, not a boolean logical mask. - Eliminate the internal variable L2_to_Z2 in the calculate_projected_state routine in MOM_kappa_shear which had been described incorrectly and ultimately was not helpful. - Corrected the allocated size declaration for three 3-d v-face arrays - Add comments highlighting a non-stride-1 loop structure for openMP threading in tracer_epipycnal_ML_diff that required the addition of 3 extra 3-d arrays and might be a performance liability in non-openMP configurations. - Extensive modification of the comments describing the variables in MOM_tracer_hordiff to clearly indicate the units of each real variable and similarly of one variable in MOM_geothermal. All answers are bitwise identical unless very large rescaling is done for thickness units, and the only change in model output is to the documented units of one diagnostic that is not used often, and to the diagnostic "KHTR_h" when large enough negative values of H_RESCALE_POWER are used. --- .../lateral/MOM_internal_tides.F90 | 6 +- .../vertical/MOM_bulk_mixed_layer.F90 | 12 ++- .../vertical/MOM_geothermal.F90 | 10 +- .../vertical/MOM_kappa_shear.F90 | 10 +- src/tracer/MOM_tracer_hor_diff.F90 | 98 +++++++++++-------- 5 files changed, 76 insertions(+), 60 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 8414e27f8c..dc0daecd8e 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -2346,8 +2346,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) default=.false.) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& - "the velocity field to the bottom stress.", units="nondim", & - default=0.003) + "the velocity field to the bottom stress.", & + units="nondim", default=0.003) 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) @@ -2518,7 +2518,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_dy_Cu = register_diag_field('ocean_model', 'dy_Cu', diag%axesT1, & Time, 'East face unblocked width', 'm', conversion=US%L_to_m) CS%id_land_mask = register_diag_field('ocean_model', 'land_mask', diag%axesT1, & - Time, 'Land mask', 'logical') ! used if overriding (BDM) + Time, 'Land mask', 'nondim') ! Output reflection parameters as diags here (not needed every timestep) if (CS%id_refl_ang > 0) call post_data(CS%id_refl_ang, CS%refl_angle, CS%diag) if (CS%id_refl_pref > 0) call post_data(CS%id_refl_pref, CS%refl_pref, CS%diag) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index a00e97a497..0097fd12fa 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3360,7 +3360,6 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. - real :: BL_detrain_time_dflt ! The default value for BUFFER_LAY_DETRAIN_TIME [s] real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] real :: Hmix_min_m ! The unscaled value of HMIX_MIN [m] @@ -3454,10 +3453,15 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "The minimum buffer layer thickness relative to the combined mixed "//& "land buffer ayer thicknesses when they are thin.", & units="nondim", default=0.1/CS%nkbl) - BL_detrain_time_dflt = 4.0*3600.0 ; if (CS%nkbl==1) BL_detrain_time_dflt = 86400.0*30.0 - call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & + if (CS%nkbl==1) then + call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & "A timescale that characterizes buffer layer detrainment events.", & - units="s", default=BL_detrain_time_dflt, scale=US%s_to_T) + units="s", default=86400.0*30.0, scale=US%s_to_T) + else + call get_param(param_file, mdl, "BUFFER_LAY_DETRAIN_TIME", CS%BL_detrain_time, & + "A timescale that characterizes buffer layer detrainment events.", & + units="s", default=4.0*3600.0, scale=US%s_to_T) + endif call get_param(param_file, mdl, "BUFFER_SPLIT_RHO_TOL", CS%BL_split_rho_tol, & "The fractional tolerance for matching layer target densities when splitting "//& "layers to deal with massive interior layers that are lighter than one of the "//& diff --git a/src/parameterizations/vertical/MOM_geothermal.F90 b/src/parameterizations/vertical/MOM_geothermal.F90 index ce19609210..3769721da1 100644 --- a/src/parameterizations/vertical/MOM_geothermal.F90 +++ b/src/parameterizations/vertical/MOM_geothermal.F90 @@ -107,7 +107,7 @@ subroutine geothermal_entraining(h, tv, dt, ea, eb, G, GV, US, CS, halo) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_old, & ! Temperature of each layer before any heat is added, for diagnostics [C ~> degC] h_old, & ! Thickness of each layer before any heat is added, for diagnostics [H ~> m or kg m-2] - work_3d ! Scratch variable used to calculate changes due to geothermal + work_3d ! Scratch variable used to calculate changes due to geothermal [various] real :: Idt ! inverse of the timestep [T-1 ~> s-1] logical :: do_i(SZI_(G)) @@ -407,7 +407,7 @@ subroutine geothermal_in_place(h, tv, dt, G, GV, US, CS, halo) if (.not.associated(tv%T)) call MOM_error(FATAL, "MOM geothermal_in_place: "//& "Geothermal heating can only be applied if T & S are state variables.") -! do i=is,ie ; do j=js,je +! do j=js,je ; do i=is,ie ! resid(i,j) = tv%internal_heat(i,j) ! enddo ; enddo @@ -573,17 +573,17 @@ subroutine geothermal_init(Time, G, GV, US, param_file, diag, CS, useALEalgorith if (id > 0) call post_data(id, CS%geo_heat, diag, .true.) ! Diagnostic for tendencies due to internal heat (in 3d) - CS%id_internal_heat_heat_tendency=register_diag_field('ocean_model', & + CS%id_internal_heat_heat_tendency = register_diag_field('ocean_model', & 'internal_heat_heat_tendency', diag%axesTL, Time, & 'Heat tendency (in 3D) due to internal (geothermal) sources', & 'W m-2', conversion=US%QRZ_T_to_W_m2, v_extensive=.true.) - CS%id_internal_heat_temp_tendency=register_diag_field('ocean_model', & + CS%id_internal_heat_temp_tendency = register_diag_field('ocean_model', & 'internal_heat_temp_tendency', diag%axesTL, Time, & 'Temperature tendency (in 3D) due to internal (geothermal) sources', & 'degC s-1', conversion=US%C_to_degC*US%s_to_T, v_extensive=.true.) if (.not.useALEalgorithm) then ! Do not offer this diagnostic if heating will be in place. - CS%id_internal_heat_h_tendency=register_diag_field('ocean_model', & + CS%id_internal_heat_h_tendency = register_diag_field('ocean_model', & 'internal_heat_h_tendency', diag%axesTL, Time, & 'Thickness tendency (in 3D) due to internal (geothermal) sources', & trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 1e8015eacd..590711bc2c 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1061,8 +1061,6 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int ! Local variables real, dimension(nz+1) :: c1 ! A tridiagonal variable [nondim] - real :: L2_to_Z2 ! A conversion factor from horizontal length units to vertical depth - ! units squared [Z2 s2 T-2 m-2 ~> 1]. real :: a_a, a_b ! Tridiagonal coupling coefficients [Z ~> m] real :: b1, b1nz_0 ! Tridiagonal variables [Z-1 ~> m-1] real :: bd1 ! A term in the denominator of b1 [Z ~> m] @@ -1134,16 +1132,14 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int endif ! Store the squared shear at interfaces - ! L2_to_Z2 = US%m_to_Z**2 * US%T_to_s**2 - L2_to_Z2 = US%L_to_Z**2 S2(1) = 0.0 ; S2(nz+1) = 0.0 if (ks > 1) & - S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * (L2_to_Z2*I_dz_int(ks)**2) + S2(ks) = ((u(ks)-u0(ks-1))**2 + (v(ks)-v0(ks-1))**2) * (US%L_to_Z*I_dz_int(ks))**2 do K=ks+1,ke - S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * (L2_to_Z2*I_dz_int(K)**2) + S2(K) = ((u(k)-u(k-1))**2 + (v(k)-v(k-1))**2) * (US%L_to_Z*I_dz_int(K))**2 enddo if (ke A type that can be used to create arrays of pointers to 2D arrays type p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of reals + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array of reals [various] end type p2d !> A type that can be used to create arrays of pointers to 2D integer arrays type p2di @@ -123,12 +123,13 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! Optional inputs for offline tracer transport logical, optional, intent(in) :: do_online_flag !< If present and true, do online !! tracer transport with stored velocities. + ! The next two arguments do not appear to be used anywhere. real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(in) :: read_khdt_x !< If present, these are the zonal - !! diffusivities from previous run. + optional, intent(in) :: read_khdt_x !< If present, these are the zonal diffusivities + !! times a timestep from a previous run [L2 ~> m2] real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(in) :: read_khdt_y !< If present, these are the meridional - !! diffusivities from previous run. + optional, intent(in) :: read_khdt_y !< If present, these are the meridional diffusivities + !! times a timestep from a previous run [L2 ~> m2] real, dimension(SZI_(G),SZJ_(G)) :: & @@ -152,10 +153,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. real :: khdt_max ! The local limiting value of khdt_x or khdt_y [L2 ~> m2]. - real :: max_CFL ! The global maximum of the diffusive CFL number. + real :: max_CFL ! The global maximum of the diffusive CFL number [nondim] logical :: use_VarMix, Resoln_scaled, do_online, use_Eady integer :: i, j, k, m, is, ie, js, je, nz, ntr, itt, num_itts - real :: I_numitts ! The inverse of the number of iterations, num_itts. + real :: I_numitts ! The inverse of the number of iterations, num_itts [nondim] real :: scale ! The fraction of khdt_x or khdt_y that is applied in this ! layer for this iteration [nondim]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. @@ -164,7 +165,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real :: Kh_loc ! The local value of Kh [L2 T-1 ~> m2 s-1]. real :: Res_Fn ! The local value of the resolution function [nondim]. real :: Rd_dx ! The local value of deformation radius over grid-spacing [nondim]. - real :: normalize ! normalization used for diagnostic Kh_h; diffusivity averaged to h-points. + real :: normalize ! normalization used for diagnostic Kh_h [nondim]; diffusivity averaged to h-points. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -337,11 +338,11 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online else ! .not. do_online !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = US%m_to_L**2*read_khdt_x(I,j) + khdt_x(I,j) = read_khdt_x(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = US%m_to_L**2*read_khdt_y(i,J) + khdt_y(i,J) = read_khdt_y(i,J) enddo ; enddo call pass_vector(khdt_x, khdt_y, G%Domain) endif ! do_online @@ -561,7 +562,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online enddo ; enddo do j=js,je ; do i=is,ie normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & - (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + GV%H_subroundoff) + (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) Kh_h(i,j) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j)+Kh_u(I,j)) + & (Kh_v(i,J-1)+Kh_v(i,J))) enddo ; enddo @@ -633,24 +634,36 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & k0b_Lv, k0a_Lv, & ! The original k-indices of the layers that participate k0b_Rv, k0a_Rv ! in each pair of mixing at v-faces. + !### Accumulating the converge into this array one face at a time may lead to a lack of rotational symmetry. real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & tr_flux_conv ! The flux convergence of tracers [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)) :: Tr_flux_3d, Tr_adj_vert_L, Tr_adj_vert_R + + ! The following 3-d arrays were created in 2014 in MOM6 PR#12 to facilitate openMP threading + ! on an i-loop, which might have been ill advised. The k-size extents here might also be problematic. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + Tr_flux_3d, & ! The tracer flux through pairings at meridional faces [conc H L2 ~> conc m3 or conc kg] + Tr_adj_vert_L, & ! Vertical adjustments to which layer the fluxes go into in the southern + ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] + Tr_adj_vert_R ! Vertical adjustments to which layer the fluxes go into in the northern + ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] real, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & rho_srt, & ! The density of each layer of the sorted columns [R ~> kg m-3]. h_srt ! The thickness of each layer of the sorted columns [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZK_(GV), SZJ_(G)) :: & - k0_srt ! The original k-index that each layer of the sorted column - ! corresponds to. + k0_srt ! The original k-index that each layer of the sorted column corresponds to. real, dimension(SZK_(GV)) :: & - h_demand_L, & ! The thickness in the left (_L) or right (_R) column that - h_demand_R, & ! is demanded to match the thickness in the counterpart [H ~> m or kg m-2]. - h_used_L, & ! The summed thickness from the left or right columns that - h_used_R, & ! have actually been used [H ~> m or kg m-2]. - h_supply_frac_L, & ! The fraction of the demanded thickness that can - h_supply_frac_R ! actually be supplied from a layer. + h_demand_L, & ! The thickness in the left column that is demanded to match the thickness + ! in the counterpart [H ~> m or kg m-2]. + h_demand_R, & ! The thickness in the right column that is demanded to match the thickness + ! in the counterpart [H ~> m or kg m-2]. + h_used_L, & ! The summed thickness from the left column that has actually been used [H ~> m or kg m-2] + h_used_R, & ! The summed thickness from the right columns that has actually been used [H ~> m or kg m-2] + h_supply_frac_L, & ! The fraction of the demanded thickness that can actually be supplied + ! from a layer on the left [nondim]. + h_supply_frac_R ! The fraction of the demanded thickness that can actually be supplied + ! from a layer on the right [nondim]. integer, dimension(SZI_(G), SZJ_(G)) :: & num_srt, & ! The number of layers that are sorted in each column. k_end_srt, & ! The maximum index in each column that might need to be @@ -666,17 +679,17 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real :: h_exclude ! A thickness that layers must attain to be considered ! for inclusion in mixing [H ~> m or kg m-2]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. - real :: I_maxitt ! The inverse of the maximum number of iterations. + real :: I_maxitt ! The inverse of the maximum number of iterations [nondim] real :: rho_pair, rho_a, rho_b ! Temporary densities [R ~> kg m-3]. - real :: Tr_min_face ! The minimum and maximum tracer concentrations - real :: Tr_max_face ! associated with a pairing [Conc] - real :: Tr_La, Tr_Lb ! The 4 tracer concentrations that might be - real :: Tr_Ra, Tr_Rb ! associated with a pairing [Conc] - real :: Tr_av_L ! The average tracer concentrations on the left and right - real :: Tr_av_R ! sides of a pairing [Conc]. + real :: Tr_min_face ! The minimum tracer concentration associated with a pairing [Conc] + real :: Tr_max_face ! The maximum tracer concentration associated with a pairing [Conc] + real :: Tr_La, Tr_Lb ! The 2 left-side tracer concentrations that might be associated with a pairing [Conc] + real :: Tr_Ra, Tr_Rb ! The 2 right-side tracer concentrations that might be associated with a pairing [Conc] + real :: Tr_av_L ! The average tracer concentrations on the left side of a pairing [Conc]. + real :: Tr_av_R ! The average tracer concentrations on the right side of a pairing [Conc]. real :: Tr_flux ! The tracer flux from left to right in a pair [conc H L2 ~> conc m3 or conc kg]. - real :: Tr_adj_vert ! A downward vertical adjustment to Tr_flux between the - ! two cells that make up one side of the pairing [conc H L2 ~> conc m3 or conc kg]. + real :: Tr_adj_vert ! A downward vertical adjustment to Tr_flux between the two cells that + ! make up one side of the pairing [conc H L2 ~> conc m3 or conc kg]. real :: h_L, h_R ! Thicknesses to the left and right [H ~> m or kg m-2]. real :: wt_a, wt_b ! Fractional weights of layers above and below [nondim]. real :: vol ! A cell volume or mass [H L2 ~> m3 or kg]. @@ -690,7 +703,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & left_set, & ! If true, the left or right point determines the density of right_set ! of the trio. If densities are exactly equal, both are true. - real :: tmp + real :: tmp ! A temporary variable used in swaps [various] real :: p_ref_cv(SZI_(G)) ! The reference pressure for the coordinate density [R L2 T-2 ~> Pa] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -1320,7 +1333,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & h_L = hP_Lv(J)%p(i,k) ; h_R = hP_Rv(J)%p(i,k) Tr_flux = I_maxitt * ((2.0 * h_L * h_R) / (h_L + h_R)) * & khdt_epi_y(i,J) * (Tr_av_L - Tr_av_R) - Tr_flux_3d(i,j,k) = Tr_flux + Tr_flux_3d(i,J,k) = Tr_flux if (deep_wt_Lv(J)%p(i,k) < 1.0) then Tr_adj_vert = 0.0 @@ -1346,7 +1359,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & (vol*wt_a)*(Tr_Lb - Tr_La)) endif endif - Tr_adj_vert_L(i,j,k) = Tr_adj_vert + Tr_adj_vert_L(i,J,k) = Tr_adj_vert endif if (deep_wt_Rv(J)%p(i,k) < 1.0) then @@ -1373,7 +1386,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & (vol*wt_a)*(Tr_Rb - Tr_Ra)) endif endif - Tr_adj_vert_R(i,j,k) = Tr_adj_vert + Tr_adj_vert_R(i,J,k) = Tr_adj_vert endif if (associated(Tr(m)%df2d_y)) & Tr(m)%df2d_y(i,J) = Tr(m)%df2d_y(i,J) + Tr_flux * Idt @@ -1384,25 +1397,28 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & !$OMP deep_wt_Rv,k0a_Rv,Tr_adj_vert_R) & !$OMP private(kLa,kLb,kRa,kRb,wt_b,wt_a) do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.0) then + ! The non-stride-1 loop order here is to facilitate openMP threading. However, it might be + ! suboptimal when openMP threading is not used, at which point it might be better to fuse + ! these loope with those that precede it and thereby eliminate the need for three 3-d arrays. do k=1,nPv(i,J) kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) if (deep_wt_Lv(J)%p(i,k) >= 1.0) then - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,j,k) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k) else kLa = k0a_Lv(J)%p(i,k) wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b - tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,j,k) + Tr_adj_vert_L(i,j,k)) - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,j,k) - Tr_adj_vert_L(i,j,k)) + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) endif if (deep_wt_Rv(J)%p(i,k) >= 1.0) then - tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,j,k) + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k) else kRa = k0a_Rv(J)%p(i,k) wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + & - (wt_a*Tr_flux_3d(i,j,k) - Tr_adj_vert_R(i,j,k)) + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + & - (wt_b*Tr_flux_3d(i,j,k) + Tr_adj_vert_R(i,j,k)) + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) endif enddo endif ; enddo ; enddo @@ -1455,8 +1471,8 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic type(param_file_type), intent(in) :: param_file !< parameter file type(tracer_hor_diff_CS), pointer :: CS !< horz diffusion control structure -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. if (associated(CS)) then From 5a80ec8bbfb57b043aa6dad2bed5d37f8cb1e14e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 12 Dec 2022 14:00:38 -0500 Subject: [PATCH 110/629] Rescale input fields in MOM_tidal_mixing Rescaled 3-d diagnostics and tidal input energies in the MOM_tidal_mixing code so that there is more explicit tested documentation of the units of various fields and arguments, and so that there are conversion factors that can be compared with the declared units of diagnostics, and explicit scale factors in the MOM_read_data calls. All answers are bitwise identical. --- .../vertical/MOM_tidal_mixing.F90 | 47 ++++++++++--------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index fa3dbe4b87..4380ceb4bd 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -49,10 +49,10 @@ module MOM_tidal_mixing real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: N2_int(:,:,:) !< Buoyancy frequency squared at interfaces [T-2 ~> s-2] - real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition [W m-3] + real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition vertical fraction [nondim]? real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme, in UNITS? real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, - !! interpolated to model vertical coordinate [W m-3?] + !! interpolated to model vertical coordinate [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces !! due to propagating low modes [Z2 T-1 ~> m2 s-1]. real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent @@ -163,9 +163,9 @@ module MOM_tidal_mixing real, allocatable :: h_src(:) !< tidal constituent input layer thickness [m] real, allocatable :: tidal_qe_2d(:,:) !< Tidal energy input times the local dissipation !! fraction, q*E(x,y), with the CVMix implementation - !! of Jayne et al tidal mixing [W m-2]. + !! of Jayne et al tidal mixing [R Z3 T-3 ~> W m-2]. !! TODO: make this E(x,y) only - real, allocatable :: tidal_qe_3d_in(:,:,:) !< q*E(x,y,z) with the Schmittner parameterization [W m-3?] + real, allocatable :: tidal_qe_3d_in(:,:,:) !< q*E(x,y,z) with the Schmittner parameterization [R Z3 T-3 ~> W m-2] ! Diagnostics @@ -641,11 +641,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%id_Schmittner_coeff = register_diag_field('ocean_model','Schmittner_coeff',diag%axesTL,Time, & 'time-invariant portion of the tidal mixing coefficient using the Schmittner', '') CS%id_tidal_qe_md = register_diag_field('ocean_model','tidal_qe_md',diag%axesTL,Time, & - 'input tidal energy dissipated locally interpolated to model vertical coordinates', '') + 'input tidal energy dissipated locally interpolated to model vertical coordinates', & + 'W m-2', conversion=US%RZ3_T3_to_W_m2) endif CS%id_vert_dep = register_diag_field('ocean_model','vert_dep',diag%axesTi,Time, & 'vertical deposition function needed for Simmons et al tidal mixing', '') - else CS%id_TKE_itidal = register_diag_field('ocean_model','TKE_itidal',diag%axesT1,Time, & 'Internal Tide Driven Turbulent Kinetic Energy', & @@ -779,7 +779,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(SZK_(GV)+1) :: SchmittnerSocn real, dimension(SZK_(GV)) :: cellHeight ! Height of cell centers [m] real, dimension(SZK_(GV)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input - ! to model coordinates + ! to model coordinates [R Z3 T-3 ~> W m-2] real, dimension(SZK_(GV)+1) :: N2_int_i ! De-scaled interface buoyancy frequency [s-2] real, dimension(SZK_(GV)) :: Schmittner_coeff ! A coefficient in the Schmittner et al (2014) mixing ! parameterization [nondim] @@ -813,7 +813,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int enddo call CVMix_compute_Simmons_invariant( nlev = GV%ke, & - energy_flux = CS%tidal_qe_2d(i,j), & + energy_flux = US%RZ3_T3_to_W_m2*CS%tidal_qe_2d(i,j), & rho = rho_fw, & SimmonsCoeff = Simmons_coeff, & VertDep = vert_dep, & @@ -863,7 +863,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T*Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T * Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -916,14 +916,14 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! CVMix API to prevent this redundancy. ! remap from input z coordinate to model coordinate: - tidal_qe_md = 0.0 + tidal_qe_md(:) = 0.0 call remapping_core_h(CS%remap_cs, size(CS%h_src), CS%h_src, CS%tidal_qe_3d_in(i,j,:), & GV%ke, h_m, tidal_qe_md, GV%H_subroundoff, GV%H_subroundoff) ! form the Schmittner coefficient that is based on 3D q*E, which is formed from ! summing q_i*TidalConstituent_i over the number of constituents. call CVMix_compute_SchmittnerCoeff( nlev = GV%ke, & - energy_flux = tidal_qe_md(:), & + energy_flux = US%RZ3_T3_to_W_m2*tidal_qe_md(:), & SchmittnerCoeff = Schmittner_coeff, & exp_hab_zetar = exp_hab_zetar, & CVmix_tidal_params_user = CS%CVMix_tidal_params) @@ -1589,7 +1589,8 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) character(len=200) :: tidal_input_var ! Input file variable name character(len=40) :: mdl = "MOM_tidal_mixing" !< This module's name. integer :: i, j, isd, ied, jsd, jed - real, allocatable, dimension(:,:) :: tidal_energy_flux_2d ! input tidal energy flux at T-grid points [W m-2] + real, allocatable, dimension(:,:) :: & + tidal_energy_flux_2d ! Input tidal energy flux at T-grid points [R Z3 T-3 ~> W m-2] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1605,7 +1606,7 @@ subroutine read_tidal_energy(G, US, tidal_energy_type, param_file, CS) call get_param(param_file, mdl, "TIDAL_DISSIPATION_VAR", tidal_input_var, & "The name in the input file of the tidal energy source for mixing.", & default="wave_dissipation") - call MOM_read_data(tidal_energy_file, tidal_input_var, tidal_energy_flux_2d, G%domain) + call MOM_read_data(tidal_energy_file, tidal_input_var, tidal_energy_flux_2d, G%domain, scale=US%W_m2_to_RZ3_T3) do j=G%jsc,G%jec ; do i=G%isc,G%iec CS%tidal_qe_2d(i,j) = CS%Gamma_itides * tidal_energy_flux_2d(i,j) enddo ; enddo @@ -1629,16 +1630,16 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) ! local variables real, parameter :: C1_3 = 1.0/3.0 real, dimension(SZI_(G),SZJ_(G)) :: & - tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert - tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert + tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert [nondim] + tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert [nondim] real, allocatable, dimension(:) :: & z_t, & ! depth from surface to midpoint of input layer [Z ~> m] z_w ! depth from surface to top of input layer [Z ~> m] real, allocatable, dimension(:,:,:) :: & - tc_m2, & ! input lunar semidiurnal tidal energy flux [W m-2] - tc_s2, & ! input solar semidiurnal tidal energy flux [W m-2] - tc_k1, & ! input lunar diurnal tidal energy flux [W m-2] - tc_o1 ! input lunar diurnal tidal energy flux [W m-2] + tc_m2, & ! input lunar semidiurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_s2, & ! input solar semidiurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_k1, & ! input lunar diurnal tidal energy flux [R Z3 T-3 ~> W m-2] + tc_o1 ! input lunar diurnal tidal energy flux [R Z3 T-3 ~> W m-2] integer, dimension(4) :: nz_in integer :: k, is, ie, js, je, isd, ied, jsd, jed, i, j @@ -1660,10 +1661,10 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) if (.not. allocated(CS%h_src)) allocate(CS%h_src(nz_in(1))) ! read in tidal constituents - call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain) - call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain) - call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain) - call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain) + call MOM_read_data(tidal_energy_file, 'M2', tc_m2, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'S2', tc_s2, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'K1', tc_k1, G%domain, scale=US%W_m2_to_RZ3_T3) + call MOM_read_data(tidal_energy_file, 'O1', tc_o1, G%domain, scale=US%W_m2_to_RZ3_T3) ! Note the hard-coded assumption that z_t and z_w in the file are in centimeters. call MOM_read_data(tidal_energy_file, 'z_t', z_t, scale=0.01*US%m_to_Z) call MOM_read_data(tidal_energy_file, 'z_w', z_w, scale=0.01*US%m_to_Z) From ab68e602b187396ce123dc4cb7d7e47a8f11f611 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 12 Dec 2022 14:01:12 -0500 Subject: [PATCH 111/629] Rescale diagnostics from MOM_CVMix_KPP Rescaled 3-d diagnostics in MOM_CVMix_KPP, and do even more of the preliminary calculations in rescaled variables before explicitly recasting variables into MKS units for the calls to the CVMix routines. With this change, all register_diag_field routines in this module (apart from nondimensional diagnostics) have conversion factors that can be tested for correctness can be compared with the declared units of diagnostics. All answers are bitwise identical. --- .../vertical/MOM_CVMix_KPP.F90 | 222 +++++++++++------- 1 file changed, 131 insertions(+), 91 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index d73bba1551..d1d4b1c790 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -140,22 +140,23 @@ module MOM_CVMix_KPP !>@} ! Diagnostics arrays - real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [m] - real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [m] without smoothing + real, allocatable, dimension(:,:) :: OBLdepth !< Depth (positive) of ocean boundary layer (OBL) [Z ~> m] + real, allocatable, dimension(:,:) :: OBLdepth_original !< Depth (positive) of OBL [Z ~> m] without smoothing real, allocatable, dimension(:,:) :: kOBL !< Level (+fraction) of OBL extent [nondim] - real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [m] + real, allocatable, dimension(:,:) :: OBLdepthprev !< previous Depth (positive) of OBL [Z ~> m] real, allocatable, dimension(:,:) :: La_SL !< Langmuir number used in KPP [nondim] real, allocatable, dimension(:,:,:) :: dRho !< Bulk difference in density [R ~> kg m-3] - real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [m2 s-2] + real, allocatable, dimension(:,:,:) :: Uz2 !< Square of bulk difference in resolved velocity [L2 T-2 ~> m2 s-2] real, allocatable, dimension(:,:,:) :: BulkRi !< Bulk Richardson number for each layer [nondim] real, allocatable, dimension(:,:,:) :: sigma !< Sigma coordinate (dimensionless) [nondim] - real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [m s-1] - real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [s-1] - real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [s-2] - real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for bulk Ri [m2 s-2] - real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [m2 s-1] - real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [m2 s-1] - real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [m2 s-1] + real, allocatable, dimension(:,:,:) :: Ws !< Turbulent velocity scale for scalars [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: N !< Brunt-Vaisala frequency [T-1 ~> s-1] + real, allocatable, dimension(:,:,:) :: N2 !< Squared Brunt-Vaisala frequency [T-2 ~> s-2] + real, allocatable, dimension(:,:,:) :: Vt2 !< Unresolved squared turbulence velocity for + !! bulk Ri [Z2 T-2 ~> m2 s-2] + real, allocatable, dimension(:,:,:) :: Kt_KPP !< Temp diffusivity from KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Ks_KPP !< Scalar diffusivity from KPP [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Kv_KPP !< Viscosity due to KPP [Z2 T-1 ~> m2 s-1] real, allocatable, dimension(:,:) :: Tsurf !< Temperature of surface layer [C ~> degC] real, allocatable, dimension(:,:) :: Ssurf !< Salinity of surface layer [S ~> ppt] real, allocatable, dimension(:,:) :: Usurf !< i-velocity of surface layer [L T-1 ~> m s-1] @@ -483,7 +484,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) ! Register diagnostics CS%diag => diag CS%id_OBLdepth = register_diag_field('ocean_model', 'KPP_OBLdepth', diag%axesT1, Time, & - 'Thickness of the surface Ocean Boundary Layer calculated by [CVMix] KPP', 'meter', & + 'Thickness of the surface Ocean Boundary Layer calculated by [CVMix] KPP', & + 'meter', conversion=US%Z_to_m, & cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') ! CMOR names are placeholders; must be modified by time period @@ -491,7 +493,8 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) ! omldamax. if (CS%n_smooth > 0) then CS%id_OBLdepth_original = register_diag_field('ocean_model', 'KPP_OBLdepth_original', diag%axesT1, Time, & - 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', 'meter', & + 'Thickness of the surface Ocean Boundary Layer without smoothing calculated by [CVMix] KPP', & + 'meter', conversion=US%Z_to_m, & cmor_field_name='oml', cmor_long_name='ocean_mixed_layer_thickness_defined_by_mixing_scheme', & cmor_units='m', cmor_standard_name='Ocean Mixed Layer Thickness Defined by Mixing Scheme') endif @@ -499,32 +502,37 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Bulk difference in density used in Bulk Richardson number, as used by [CVMix] KPP', & 'kg/m3', conversion=US%R_to_kg_m3) CS%id_BulkUz2 = register_diag_field('ocean_model', 'KPP_BulkUz2', diag%axesTL, Time, & - 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', 'm2/s2') + 'Square of bulk difference in resolved velocity used in Bulk Richardson number via [CVMix] KPP', & + 'm2/s2', conversion=US%L_T_to_m_s**2) CS%id_BulkRi = register_diag_field('ocean_model', 'KPP_BulkRi', diag%axesTL, Time, & 'Bulk Richardson number used to find the OBL depth used by [CVMix] KPP', 'nondim') CS%id_Sigma = register_diag_field('ocean_model', 'KPP_sigma', diag%axesTi, Time, & 'Sigma coordinate used by [CVMix] KPP', 'nondim') CS%id_Ws = register_diag_field('ocean_model', 'KPP_Ws', diag%axesTL, Time, & - 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', 'm/s') + 'Turbulent vertical velocity scale for scalars used by [CVMix] KPP', & + 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_N = register_diag_field('ocean_model', 'KPP_N', diag%axesTi, Time, & - '(Adjusted) Brunt-Vaisala frequency used by [CVMix] KPP', '1/s') + '(Adjusted) Brunt-Vaisala frequency used by [CVMix] KPP', '1/s', conversion=US%s_to_T) CS%id_N2 = register_diag_field('ocean_model', 'KPP_N2', diag%axesTi, Time, & - 'Square of Brunt-Vaisala frequency used by [CVMix] KPP', '1/s2') + 'Square of Brunt-Vaisala frequency used by [CVMix] KPP', '1/s2', conversion=US%s_to_T**2) CS%id_Vt2 = register_diag_field('ocean_model', 'KPP_Vt2', diag%axesTL, Time, & - 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2') + 'Unresolved shear turbulence used by [CVMix] KPP', 'm2/s2', conversion=US%Z_to_m**2*US%s_to_T**2) CS%id_uStar = register_diag_field('ocean_model', 'KPP_uStar', diag%axesT1, Time, & 'Friction velocity, u*, as used by [CVMix] KPP', 'm/s', conversion=US%Z_to_m*US%s_to_T) CS%id_buoyFlux = register_diag_field('ocean_model', 'KPP_buoyFlux', diag%axesTi, Time, & 'Surface (and penetrating) buoyancy flux, as used by [CVMix] KPP', & 'm2/s3', conversion=US%L_to_m**2*US%s_to_T**3) CS%id_Kt_KPP = register_diag_field('ocean_model', 'KPP_Kheat', diag%axesTi, Time, & - 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', 'm2/s') + 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & 'Diffusivity passed to KPP', 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & - 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', 'm2/s') + 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kv_KPP = register_diag_field('ocean_model', 'KPP_Kv', diag%axesTi, Time, & - 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', 'm2/s') + 'Vertical viscosity due to KPP, as calculated by [CVMix] KPP', & + 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_NLTt = register_diag_field('ocean_model', 'KPP_NLtransport_heat', diag%axesTi, Time, & 'Non-local transport (Cs*G(sigma)) for heat, as calculated by [CVMix] KPP', 'nondim') CS%id_NLTs = register_diag_field('ocean_model', 'KPP_NLtransport_salt', diag%axesTi, Time, & @@ -598,18 +606,20 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP !! (out) Vertical viscosity including KPP !! [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [nondim] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier ! Local variables - integer :: i, j, k ! Loop indices - real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces [m2 s-1] - real, dimension( GV%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces [m2 s-1] - real, dimension( GV%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] + integer :: i, j, k ! Loop indices + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1 ) :: z_inter ! Cell interface heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1, 2) :: Kdiffusivity ! Vertical diffusivity at interfaces in MKS units [m2 s-1] + real, dimension( GV%ke+1 ) :: Kviscosity ! Vertical viscosity at interfaces in MKS units [m2 s-1] + real, dimension( GV%ke+1, 2) :: nonLocalTrans ! Non-local transport for heat/salt at interfaces [nondim] real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] @@ -643,7 +653,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & !$OMP parallel do default(none) firstprivate(nonLocalTrans) & !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & !$OMP surfBuoyFlux, Kdiffusivity, Kviscosity, LangEnhK, sigma, & - !$OMP sigmaRatio) & + !$OMP sigmaRatio, z_inter, z_cell) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, Kt, & !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! loop over horizontal points on processor @@ -665,8 +675,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! k-loop finishes @@ -740,15 +750,23 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & enddo endif + ! Convert columns to MKS units for passing to CVMix + do k = 1, GV%ke + z_cell(k) = US%Z_to_m*cellHeight(k) + enddo + do K = 1, GV%ke+1 + z_inter(K) = US%Z_to_m*iFaceHeight(K) + enddo + call CVMix_coeffs_kpp(Kviscosity(:), & ! (inout) Total viscosity [m2 s-1] Kdiffusivity(:,1), & ! (inout) Total heat diffusivity [m2 s-1] Kdiffusivity(:,2), & ! (inout) Total salt diffusivity [m2 s-1] - iFaceHeight, & ! (in) Height of interfaces [m] - cellHeight, & ! (in) Height of level centers [m] + z_inter(:), & ! (in) Height of interfaces [m] + z_cell(:), & ! (in) Height of level centers [m] Kviscosity(:), & ! (in) Original viscosity [m2 s-1] Kdiffusivity(:,1), & ! (in) Original heat diffusivity [m2 s-1] Kdiffusivity(:,2), & ! (in) Original salt diffusivity [m2 s-1] - CS%OBLdepth(i,j), & ! (in) OBL depth [m] + US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] CS%kOBL(i,j), & ! (in) level (+fraction) of OBL extent nonLocalTrans(:,1),& ! (out) Non-local heat transport [nondim] nonLocalTrans(:,2),& ! (out) Non-local salt transport [nondim] @@ -821,14 +839,14 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! Copy 1d data into 3d diagnostic arrays !/ grabbing obldepth_0d for next time step. - CS%OBLdepthprev(i,j)=CS%OBLdepth(i,j) + CS%OBLdepthprev(i,j) = CS%OBLdepth(i,j) if (CS%id_sigma > 0) then CS%sigma(i,j,:) = 0. - if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight/CS%OBLdepth(i,j) + if (CS%OBLdepth(i,j)>0.) CS%sigma(i,j,:) = -iFaceHeight(:)/CS%OBLdepth(i,j) endif - if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = Kdiffusivity(:,1) - if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = Kdiffusivity(:,2) - if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = Kviscosity(:) + if (CS%id_Kt_KPP > 0) CS%Kt_KPP(i,j,:) = US%m2_s_to_Z2_T * Kdiffusivity(:,1) + if (CS%id_Ks_KPP > 0) CS%Ks_KPP(i,j,:) = US%m2_s_to_Z2_T * Kdiffusivity(:,2) + if (CS%id_Kv_KPP > 0) CS%Kv_KPP(i,j,:) = US%m2_s_to_Z2_T * Kviscosity(:) ! Update output of routine if (.not. CS%passiveMode) then @@ -898,19 +916,22 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor ! Local variables - ! Variables in MKS units for passing to CVMix routines - real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] (negative in ocean) - real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [s-2] - real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars [m s-1] - real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] - real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] - real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] - real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] + ! Variables for passing to CVMix routines, often in MKS units + real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] + real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] + real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] + real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] + real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] + real, dimension( GV%ke ) :: Vt2_1d ! Unresolved squared turbulence velocity for bulk Ri [m2 s-2] + real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke ) :: OBL_depth ! Cell center depths referenced to surface [m] (positive in ocean) + real, dimension( GV%ke+1 ) :: z_inter ! Cell interface heights referenced to surface [m] (negative in ocean) + real, dimension( GV%ke+1 ) :: N_col ! A column of buoyancy frequencies at interfaces in MKS units [s-1] real :: surfFricVel ! Surface friction velocity in MKS units [m s-1] real :: surfBuoyFlux ! Surface buoyancy flux in MKS units [m2 s-3] - real :: Coriolis ! Coriolis parameter at tracer points [s-1] - real :: zBottomMinusOffset ! Height of bottom plus a little bit [m] + real :: Coriolis ! Coriolis parameter at tracer points in MKS units [s-1] + real :: KPP_OBL_depth ! Boundary layer depth calculated by CVMix_kpp_compute_OBL_depth in MKS units [m] + ! Variables for EOS calculations real, dimension( 3*GV%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] @@ -918,7 +939,13 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension( 3*GV%ke ) :: Temp_1D ! A column of temperatures [C ~> degC] real, dimension( 3*GV%ke ) :: Salt_1D ! A column of salinities [S ~> ppt] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) + real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [T-2 ~> s-2] + real :: zBottomMinusOffset ! Height of bottom plus a little bit [Z ~> m] real :: GoRho ! Gravitational acceleration in MKS units divided by density [m s-2 R-1 ~> m4 kg-1 s-2] + real :: GoRho_Z_L2 ! Gravitational acceleration divided by density times aspect ratio + ! rescaling [Z T-2 R-1 ~> m4 kg-1 s-2] real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] @@ -957,20 +984,21 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants - GoRho = US%L_T_to_m_s**2*US%m_to_Z * GV%g_Earth / GV%Rho0 + GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 + GoRho = US%Z_to_m*US%s_to_T**2 * GoRho_Z_L2 buoy_scale = US%L_to_m**2*US%s_to_T**3 ! loop over horizontal points on processor !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & - !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, & + !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, vt2_1d, & !$OMP ksfc, surfHtemp, surfHsalt, surfHu, surfHv, surfHuS, & !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & - !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, & + !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, N_col, & !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2, & - !$OMP BulkRi_1d, zBottomMinusOffset) & + !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & + !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & - !$OMP Temp, Salt, waves, tv, GoRho, u, v, lamult) + !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) do j = G%jsc, G%jec do i = G%isc, G%iec @@ -1003,14 +1031,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh ! find ksfc for cell where "surface layer" sits - SLdepth_0d = CS%surf_layer_ext*max( US%m_to_Z*max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) + SLdepth_0d = CS%surf_layer_ext*max( max(-cellHeight(k),-iFaceHeight(2) ), CS%minOBLdepth ) ksfc = k do ktmp = 1,k - if (-1.0*iFaceHeight(ktmp+1) >= US%Z_to_m*SLdepth_0d) then + if (-1.0*iFaceHeight(ktmp+1) >= SLdepth_0d) then ksfc = ktmp exit endif @@ -1092,7 +1120,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl enddo ! k-loop finishes if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then - MLD_guess = max( 1.*US%m_to_Z, abs(US%m_to_Z*CS%OBLdepthprev(i,j) ) ) + MLD_guess = max( 1.*US%m_to_Z, abs(CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) CS%La_SL(i,j)=LA @@ -1109,20 +1137,30 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) - N2_1d(k) = (GoRho * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & - ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_m) + N2_1d(k) = (GoRho_Z_L2 * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & + ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo N2_1d(GV%ke+1 ) = 0.0 CS%N(i,j,GV%ke+1 ) = 0.0 + ! Convert columns to MKS units for passing to CVMix + do k = 1, GV%ke + OBL_depth(k) = -US%Z_to_m * cellHeight(k) + z_cell(k) = US%Z_to_m*cellHeight(k) + enddo + do K = 1, GV%ke+1 + N_col(K) = US%s_to_T*CS%N(i,j,K) + z_inter(K) = US%Z_to_m*iFaceHeight(K) + enddo + ! turbulent velocity scales w_s and w_m computed at the cell centers. ! Note that if sigma > CS%surf_layer_ext, then CVMix_kpp_compute_turbulent_scales ! computes w_s and w_m velocity scale at sigma=CS%surf_layer_ext. So we only pass ! sigma=CS%surf_layer_ext for this calculation. call CVMix_kpp_compute_turbulent_scales( & CS%surf_layer_ext, & ! (in) Normalized surface layer depth; sigma = CS%surf_layer_ext - -cellHeight, & ! (in) Assume here that OBL depth [m] = -cellHeight(k) + OBL_depth, & ! (in) OBL depth [m] surfBuoyFlux2, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] @@ -1153,73 +1191,75 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & - zt_cntr = cellHeight(1:GV%ke), & ! Depth of cell center [m] + zt_cntr=z_cell, & ! Depth of cell center [m] delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [m s-2] delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] - N_iface=CS%N(i,j,:), & ! Buoyancy frequency [s-1] + N_iface=N_col, & ! Buoyancy frequency [s-1] EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] - LaSL = CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] - bfsfc = surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] - uStar = uStar(i,j), & ! surface friction velocity [m s-1] + LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] + bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] + uStar=surfFricVel, & ! surface friction velocity [m s-1] CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters call CVMix_kpp_compute_OBL_depth( & BulkRi_1d, & ! (in) Bulk Richardson number - iFaceHeight, & ! (in) Height of interfaces [m] - CS%OBLdepth(i,j), & ! (out) OBL depth [m] + z_inter, & ! (in) Height of interfaces [m] + KPP_OBL_depth, & ! (out) OBL depth [m] CS%kOBL(i,j), & ! (out) level (+fraction) of OBL extent - zt_cntr=cellHeight, & ! (in) Height of cell centers [m] + zt_cntr=z_cell, & ! (in) Height of cell centers [m] surf_fric=surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] surf_buoy=surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] Coriolis=Coriolis, & ! (in) Coriolis parameter [s-1] CVMix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%OBLdepth(i,j) = US%m_to_Z * KPP_OBL_depth ! A hack to avoid KPP reaching the bottom. It was needed during development ! because KPP was unable to handle vanishingly small layers near the bottom. if (CS%deepOBLoffset>0.) then - zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(US%Z_to_m*CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) + zBottomMinusOffset = iFaceHeight(GV%ke+1) + min(CS%deepOBLoffset, -0.1*iFaceHeight(GV%ke+1)) CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -zBottomMinusOffset ) endif ! apply some constraints on OBLdepth - if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = US%Z_to_m*CS%fixedOBLdepth_value + if (CS%fixedOBLdepth) CS%OBLdepth(i,j) = CS%fixedOBLdepth_value CS%OBLdepth(i,j) = max( CS%OBLdepth(i,j), -iFaceHeight(2) ) ! no shallower than top layer CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) ! compute unresolved squared velocity for diagnostics if (CS%id_Vt2 > 0) then - CS%Vt2(i,j,:) = CVmix_kpp_compute_unresolved_shear( & - cellHeight(1:GV%ke), & ! Depth of cell center [m] - ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] - N_iface=CS%N(i,j,:), & ! Buoyancy frequency at interface [s-1] + Vt2_1d(:) = CVmix_kpp_compute_unresolved_shear( & + z_cell, & ! Depth of cell center [m] + ws_cntr=Ws_1d, & ! Turbulent velocity scale profile, at centers [m s-1] + N_iface=N_col, & ! Buoyancy frequency at interface [s-1] EFactor=LangEnhVT2, & ! Langmuir enhancement factor [nondim] LaSL=CS%La_SL(i,j), & ! surface layer averaged Langmuir number [nondim] bfsfc=surfBuoyFlux, & ! surface buoyancy flux [m2 s-3] - uStar=uStar(i,j), & ! surface friction velocity [m s-1] + uStar=surfFricVel, & ! surface friction velocity [m s-1] CVmix_kpp_params_user=CS%KPP_params ) ! KPP parameters + CS%Vt2(i,j,:) = US%m_to_Z*US%T_to_s * Vt2_1d(:) endif ! recompute wscale for diagnostics, now that we in fact know boundary layer depth !BGR consider if LTEnhancement is wanted for diagnostics if (CS%id_Ws > 0) then call CVMix_kpp_compute_turbulent_scales( & - -CellHeight/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate - CS%OBLdepth(i,j), & ! (in) OBL depth [m] + -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] w_s=Ws_1d, & ! (out) Turbulent velocity scale profile [m s-1] CVMix_kpp_params_user=CS%KPP_params) ! KPP parameters - CS%Ws(i,j,:) = Ws_1d(:) + CS%Ws(i,j,:) = US%m_to_Z*US%T_to_s*Ws_1d(:) endif ! Diagnostics if (CS%id_N2 > 0) CS%N2(i,j,:) = N2_1d(:) if (CS%id_BulkDrho > 0) CS%dRho(i,j,:) = deltaRho(:) if (CS%id_BulkRi > 0) CS%BulkRi(i,j,:) = BulkRi_1d(:) - if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = deltaU2(:) + if (CS%id_BulkUz2 > 0) CS%Uz2(i,j,:) = US%m_s_to_L_T**2 * deltaU2(:) if (CS%id_Tsurf > 0) CS%Tsurf(i,j) = surfTemp if (CS%id_Ssurf > 0) CS%Ssurf(i,j) = surfSalt if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU @@ -1261,10 +1301,10 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] ! local - real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [m] - real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [m] + real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [Z ~> m] + real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] ! (negative in the ocean) - real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [m] + real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] ! (negative in the ocean) real :: wc, ww, we, wn, ws ! averaging weights for smoothing [nondim] real :: dh ! The local thickness used for calculating interface positions [Z ~> m] @@ -1300,8 +1340,8 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! compute weights @@ -1344,10 +1384,10 @@ subroutine KPP_get_BLD(CS, BLD, G, US, m_to_BLD_units) real, optional, intent(in) :: m_to_BLD_units !< A conversion factor from meters !! to the desired units for BLD [various] ! Local variables - real :: scale ! A dimensional rescaling factor in [Z m-1 ~> 1] or other units. + real :: scale ! A dimensional rescaling factor in [nondim] or other units. integer :: i,j - scale = US%m_to_Z ; if (present(m_to_BLD_units)) scale = m_to_BLD_units + scale = 1.0 ; if (present(m_to_BLD_units)) scale = US%Z_to_m*m_to_BLD_units !$OMP parallel do default(none) shared(BLD, CS, G, scale) do j = G%jsc, G%jec ; do i = G%isc, G%iec From 3310ee3c62e5b8f7fc7f326445c1653b436a1cb1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 18 Dec 2022 09:18:55 -0500 Subject: [PATCH 112/629] Avoid using the unscaled argument to MOM_get_param Avoid using the unscaled argument to MOM_get_param in 5 places in 4 files, and made related changes to avoid using some unscaled variables: - Replace Hmix_min_m (in [m]) with Hmix_min_z (in [Z ~> m]) in bulkmixedlayer_init and then set CS%Hmix_min by rescaling Hmix_min_z to [H ~> m or kg m-2]. - Replace Hmix_m (in [m]) with Hmix_z (in [Z ~> m]) in vertvisc_init, and then set CS%Hmix by rescaling Hmix_z to [H ~> m or kg m-2]. - Add a separate unlogged and unscaled get_param call for FLUXCONST for flux_const_default in the solo_driver surface_forcing_init - Do not rescale FLUXCONST when it is read in the FMS_cap surface_forcing_init. - The Flux_const element of the FMS_cap surface_forcing_CS was not actually being used apart from setting a default for Flux_const_temp and Flux_const_salt, so it was replaced with a local variable in surface_forcing_init. - Added comments better describing the internal variables in surface_forcing_init. All answers and output are bitwise identical. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 35 ++++++++++--------- .../solo_driver/MOM_surface_forcing.F90 | 28 +++++++-------- .../vertical/MOM_bulk_mixed_layer.F90 | 10 +++--- .../vertical/MOM_vert_friction.F90 | 17 ++++----- 4 files changed, 44 insertions(+), 46 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 ccd2183e3c..cd0106ec48 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -110,7 +110,6 @@ module MOM_surface_forcing_gfdl !! salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. - real :: Flux_const !< Piston velocity for surface restoring [Z T-1 ~> m s-1] real :: Flux_const_salt !< Piston velocity for surface salt restoring [Z T-1 ~> m s-1] real :: Flux_const_temp !< Piston velocity for surface temp restoring [Z T-1 ~> m s-1] logical :: trestore_SPEAR_ECDA !< If true, modify restoring data wrt local SSS @@ -1244,19 +1243,22 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) !! diagnostic output type(surface_forcing_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module - integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds that are - !! being provided in calls to update_ocean_model + integer, optional, intent(in) :: wind_stagger !< If present, the staggering of the winds + !! that are being provided in calls to update_ocean_model ! Local variables - real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. - type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags + real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. + real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + logical :: new_sim ! False if this simulation was started from a restart file + ! or other equivalent files. + logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. 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 ! the answers from the end of 2018. Otherwise, use a simpler ! expression to calculate gustiness. type(time_type) :: Time_frc + type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1265,7 +1267,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) character(len=48) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed - real :: unscaled_fluxconst isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1386,16 +1387,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "production runs.", units="nondim", default=1.0) if (CS%restore_salt) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + call get_param(param_file, mdl, "FLUXCONST", Flux_const_dflt, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s, unscaled=unscaled_fluxconst) + units="m day-1", default=0.0) call get_param(param_file, mdl, "FLUXCONST_SALT", CS%Flux_const_salt, & "The constant that relates the restoring surface salt fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - fail_if_missing=.false., default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) - ! Finish converting CS%Flux_const from m day-1 to [Z T-1 ~> m s-1]. - CS%Flux_const = CS%Flux_const / 86400.0 + units="m day-1", default=Flux_const_dflt, scale=US%m_to_Z*US%T_to_s) + ! Finish converting CS%Flux_const_salt from m day-1 to [Z T-1 ~> m s-1]. Ideally this would be + ! included in the scale factors above, but doing so would change answers because a/b /= a*(1/b). CS%Flux_const_salt = CS%Flux_const_salt / 86400.0 call get_param(param_file, mdl, "SALT_RESTORE_FILE", CS%salt_restore_file, & "A file in which to find the surface salinity to use for restoring.", & @@ -1437,16 +1438,16 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) endif if (CS%restore_temp) then - call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & + call get_param(param_file, mdl, "FLUXCONST", Flux_const_dflt, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s, unscaled=unscaled_fluxconst) + units="m day-1", default=0.0) call get_param(param_file, mdl, "FLUXCONST_TEMP", CS%Flux_const_temp, & "The constant that relates the restoring surface temperature fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - fail_if_missing=.false., default=unscaled_fluxconst, units="m day-1", scale=US%m_to_Z*US%T_to_s) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + units="m day-1", default=Flux_const_dflt, scale=US%m_to_Z*US%T_to_s) + ! Finish converting CS%Flux_const_temp from [m day-1] to [Z T-1 ~> m s-1]. Ideally this would be + ! included in the scale factors above, but doing so would change answers because a/b /= a*(1/b). CS%Flux_const_temp = CS%Flux_const_temp / 86400.0 call get_param(param_file, mdl, "SST_RESTORE_FILE", CS%temp_restore_file, & "A file in which to find the surface temperature to use for restoring.", & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 3ad06ddb8e..8b1c9aaa27 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1801,9 +1801,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & - "If true, the buoyancy fluxes drive the model back "//& - "toward some specified surface state with a rate "//& - "given by FLUXCONST.", default= .false.) + "If true, the buoyancy fluxes drive the model back toward some "//& + "specified surface state with a rate given by FLUXCONST.", default=.false.) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", default=hlf, & units="J/kg", scale=US%J_kg_to_Q) @@ -1814,22 +1813,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "FLUXCONST", CS%Flux_const, & "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & - default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - unscaled=flux_const_default) + default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0) if (CS%use_temperature) then + call get_param(param_file, mdl, "FLUXCONST", flux_const_default, & + default=0.0, units="m day-1", do_not_log=.true.) call get_param(param_file, mdl, "FLUXCONST_T", CS%Flux_const_T, & - "The constant that relates the restoring surface temperature "//& - "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - default=flux_const_default) + "The constant that relates the restoring surface temperature flux to the "//& + "relative surface anomaly (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, default=flux_const_default) call get_param(param_file, mdl, "FLUXCONST_S", CS%Flux_const_S, & - "The constant that relates the restoring surface salinity "//& - "flux to the relative surface anomaly (akin to a piston "//& - "velocity). Note the non-MKS units.", & - units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, & - default=flux_const_default) + "The constant that relates the restoring surface salinity flux to the "//& + "relative surface anomaly (akin to a piston velocity). Note the non-MKS units.", & + units="m day-1", scale=US%m_to_Z*US%T_to_s/86400.0, default=flux_const_default) endif if (trim(CS%buoy_config) == "linear") then @@ -1853,7 +1849,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C endif call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "GUST_CONST", CS%gust_const, & "The background gustiness in the winds.", & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 0097fd12fa..cb17884ee7 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3362,7 +3362,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] - real :: Hmix_min_m ! The unscaled value of HMIX_MIN [m] + real :: Hmix_min_z ! The default value of HMIX_MIN [Z ~> m] integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3418,10 +3418,10 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 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) - call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & + call get_param(param_file, mdl, "HMIX_MIN", Hmix_min_Z, & "The minimum mixed layer depth if the mixed layer depth "//& - "is determined dynamically.", units="m", default=0.0, scale=GV%m_to_H, & - unscaled=Hmix_min_m) + "is determined dynamically.", units="m", default=0.0, scale=US%m_to_Z) + CS%Hmix_min = GV%Z_to_H * Hmix_min_Z call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & "If true, limit the detrainment from the buffer layers "//& @@ -3470,7 +3470,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEPTH_LIMIT_FLUXES", CS%H_limit_fluxes, & "The surface fluxes are scaled away when the total ocean "//& "depth is less than DEPTH_LIMIT_FLUXES.", & - units="m", default=0.1*Hmix_min_m, scale=GV%m_to_H) + units="m", default=0.1*US%Z_to_m*Hmix_min_z, scale=GV%m_to_H) call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", & default=7.2921e-5, units="s-1", scale=US%T_to_s) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index eadd35b86e..bc8ef7e893 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -1982,7 +1982,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Local variables real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [Z2 T-1 ~> m2 s-1]. - real :: Hmix_m ! A boundary layer thickness [m]. + real :: Hmix_z ! A boundary layer thickness [Z ~> m]. 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 the @@ -2087,17 +2087,18 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & default=0.0, units="nondim") call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) - if (GV%nkml < 1) & - call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & - "The prescribed depth over which the near-surface "//& - "viscosity and diffusivity are elevated when the bulk "//& - "mixed layer is not used.", units="m", scale=GV%m_to_H, & - unscaled=Hmix_m, fail_if_missing=.true.) + if (GV%nkml < 1) then + call get_param(param_file, mdl, "HMIX_FIXED", Hmix_z, & + "The prescribed depth over which the near-surface viscosity and "//& + "diffusivity are elevated when the bulk mixed layer is not used.", & + units="m", scale=US%m_to_Z, fail_if_missing=.true.) + CS%Hmix = GV%Z_to_H * Hmix_z + endif if (CS%direct_stress) then if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & - units="m", default=Hmix_m, scale=GV%m_to_H) + units="m", default=US%Z_to_m*Hmix_z, scale=GV%m_to_H) else call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & From ec7a57fd87bd34276b6da9dcba8312219c135fc9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 21 Dec 2022 16:45:10 -0500 Subject: [PATCH 113/629] +Add runtime parameters for MOM_wave_interface Added 7 new runtime parameters (LA_DEPTH_MIN, DHH85_MIN_WAVE_FREQ, DHH85_MAX_WAVE_FREQ, RHO_AIR, VISCOSITY_AIR, WAVE_HEIGHT_SCALE_FACTOR and VON_KARMAN_WAVES) to specify the previously hard-coded dimensional parameters in the MOM_wave_interface module. Because there are several different ways to set the parameters related to the Langmuir number calculation, several of these parameters are set in the new private subroutine set_LF17_wave_params, which in turn is called in two different places. Some comments were also added to annotate the units of some of the variables in this module. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for some configurations that use the MOM6 surface wave module. --- src/user/MOM_wave_interface.F90 | 137 ++++++++++++++++++++------------ 1 file changed, 86 insertions(+), 51 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 1a1c06018e..70c0b4c71f 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -140,7 +140,8 @@ module MOM_wave_interface logical :: DataOver_initialized !< Flag for DataOverride Initialization ! Options for computing Langmuir number - real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number + real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] + real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive @@ -158,8 +159,9 @@ module MOM_wave_interface PrescribedSurfStkX !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] real, allocatable, dimension(:) :: & PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] + !### It appears that La_SL is never used. Can it be removed? real, allocatable, dimension(:,:) :: & - La_SL, & !< SL Langmuir number (directionality factored later) + La_SL, & !< SL Langmuir number (directionality factored later) [nondim] !! Horizontal -> H points La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points @@ -178,13 +180,20 @@ module MOM_wave_interface !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - !> An arbitrary lower-bound on the Langmuir number. Run-time parameter. + !> An arbitrary lower-bound on the Langmuir number [nondim]. Run-time parameter. !! Langmuir number is sqrt(u_star/u_stokes). When both are small !! but u_star is orders of magnitude smaller the Langmuir number could !! have unintended consequences. Since both are small it can be safely capped !! to avoid such consequences. real :: La_min = 0.05 + ! Parameters used in estimating the wind speed or wave properties from the friction velocity + real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] + real :: rho_air !< A typical density of air at sea level, as used in wave calculations [R ~> kg m-3] + real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] + real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the + !! significant wave height [Z T2 L-2 ~> s m-2] + ! Options used with the test profile real :: TP_STKX0 !< Test profile x-stokes drift amplitude [L T-1 ~> m s-1] real :: TP_STKY0 !< Test profile y-stokes drift amplitude [L T-1 ~> m s-1] @@ -196,6 +205,8 @@ module MOM_wave_interface logical :: DHH85_is_set !< The if the wave properties have been set when WaveMethod = DHH85. real :: WaveAge !< The fixed wave age used with the DHH85 spectrum [nondim] real :: WaveWind !< Wind speed for the DHH85 spectrum [L T-1 ~> m s-1] + real :: omega_min !< Minimum wave frequency with the DHH85 spectrum [T-1 ~> s-1] + real :: omega_max !< Maximum wave frequency with the DHH85 spectrum [T-1 ~> s-1] type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the @@ -281,12 +292,16 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & - "The depth (normalized by BLD) to average Stokes drift over in "//& - "Langmuir number calculation, where La = sqrt(ust/Stokes).", & - units="nondim", default=0.04) + "The depth (normalized by BLD) to average Stokes drift over in "//& + "Langmuir number calculation, where La = sqrt(ust/Stokes).", & + units="nondim", default=0.04) + call get_param(param_file, mdl, "LA_DEPTH_MIN", CS%LA_HBL_min, & + "The minimum depth over which to average the Stokes drift in the Langmuir "//& + "number calculation.", units="m", default=0.1, scale=US%m_to_Z) if (StatisticalWaves) then CS%WaveMethod = LF17 + call set_LF17_wave_params(param_file, mdl, US, CS) if (.not.use_waves) return else CS%WaveMethod = NULL_WaveMethod @@ -433,11 +448,18 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar call get_param(param_file, mdl, "DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & units='m s-1', default=10.0, scale=US%m_s_to_L_T) + call get_param(param_file, mdl, "DHH85_MIN_WAVE_FREQ", CS%omega_min, & + "Minimum wave frequency for the DHH85 spectrum.", & + units='s-1', default=0.1, scale=US%T_to_s) + call get_param(param_file, mdl, "DHH85_MAX_WAVE_FREQ", CS%omega_max, & + "Maximum wave frequency for the DHH85 spectrum.", & + units='s-1', default=10.0, scale=US%T_to_s) ! The default is about a 30 cm cutoff wavelength. call get_param(param_file, mdl, "STATIC_DHH85", CS%StaticWaves, & "Flag to disable updating DHH85 Stokes drift.", default=.false.) - case (LF17_STRING)!Li and Fox-Kemper 17 wind-sea Langmuir number + case (LF17_STRING) !Li and Fox-Kemper 17 wind-sea Langmuir number CS%WaveMethod = LF17 - case (EFACTOR_STRING)!Li and Fox-Kemper 16 + call set_LF17_wave_params(param_file, mdl, US, CS) + case (EFACTOR_STRING) !Li and Fox-Kemper 16 CS%WaveMethod = EFACTOR case default call MOM_error(FATAL,'Check WAVE_METHOD.') @@ -510,6 +532,32 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar end subroutine MOM_wave_interface_init +!> Set the parameters that are used to determine the averaged Stokes drift and Langmuir numbers +subroutine set_LF17_wave_params(param_file, mdl, US, CS) + type(param_file_type), intent(in) :: param_file !< Input parameter structure + character(len=*), intent(in) :: mdl !< A module name to use in the get_param calls + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure + + ! A separate routine is used to set these parameters because there are multiple ways that the + ! underlying parameterizations are enabled. + + call get_param(param_file, mdl, "VISCOSITY_AIR", CS%nu_air, & + "A typical viscosity of air at sea level, as used in wave calculations", & + units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + call get_param(param_file, mdl, "VON_KARMAN_WAVES", CS%vonKar, & + "The value the von Karman constant as used for surface wave calculations.", & + units="nondim", default=0.40) ! The default elsewhere in MOM6 is usually 0.41. + call get_param(param_file, mdl, "RHO_AIR", CS%rho_air, & + "A typical density of air at sea level, as used in wave calculations", & + units="kg m-3", default=1.225, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "WAVE_HEIGHT_SCALE_FACTOR", CS%SWH_from_u10sq, & + "A factor relating the square of the 10 m wind speed to the significant "//& + "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & + units="s m-2", default=0.0246, scale=US%m_to_Z*US%L_T_to_m_s**2) + +end subroutine set_LF17_wave_params + !> This interface provides the caller with information from the waves control structure. subroutine query_wave_properties(CS, NumBands, WaveNumbers, US) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure @@ -619,21 +667,20 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! Local Variables real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] - real :: one_cm ! One centimeter in the units of wavelengths [Z ~> m] real :: level_thick ! The thickness of each layer [Z ~> m] real :: min_level_thick_avg ! A minimum layer thickness for inclusion in the average [Z ~> m] real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] real :: CMN_FAC ! A nondimensional factor [nondim] real :: WN ! Model wavenumber [Z-1 ~> m-1] real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] real :: La ! The local Langmuir number [nondim] integer :: ii, jj, kk, b, iim1, jjm1 real :: idt ! 1 divided by the time step [T-1 ~> s-1] if (CS%WaveMethod==EFACTOR) return - one_cm = 0.01*US%m_to_Z + ! The following thickness cut-off would not be needed with the refactoring marked with '###' below. min_level_thick_avg = 1.e-3*US%m_to_Z idt = 1.0/dt @@ -896,7 +943,7 @@ end subroutine Update_Stokes_Drift !> Return the value of (1 - exp(-x))/x, using an accurate expression for small values of x. real function one_minus_exp_x(x) real, intent(in) :: x !< The argument of the function ((1 - exp(-x))/x) [nondim] - real, parameter :: C1_6 = 1.0/6.0 + real, parameter :: C1_6 = 1.0/6.0 ! A rational fraction [nondim] if (abs(x) <= 2.0e-5) then ! The Taylor series expression for exp(-x) gives a more accurate expression for 64-bit reals. one_minus_exp_x = 1.0 - x * (0.5 - C1_6*x) @@ -920,7 +967,7 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. character(len=20) :: varname ! The name of an input variable for data override. - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] logical :: wavenumber_exists integer :: ndims, b, i, j @@ -1058,9 +1105,8 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & real, allocatable :: StkBand_X(:), StkBand_Y(:) ! Stokes drifts by band [L T-1 ~> m s-1] integer :: KK, BB - - ! Compute averaging depth for Stokes drift (negative) - Dpt_LASL = min(-0.1*US%m_to_Z, -Waves%LA_FracHBL*HBL) + ! Compute averaging depth for Stokes drift (negative) + Dpt_LASL = -1.0*max(Waves%LA_FracHBL*HBL, Waves%LA_HBL_min) USE_MA = Waves%LA_Misalignment if (present(Override_MA)) USE_MA = Override_MA @@ -1183,19 +1229,14 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure real, intent(out) :: UStokes_SL !< Surface layer averaged Stokes drift [L T-1 ~> m s-1] - real, intent(out) :: LA !< Langmuir number + real, intent(out) :: LA !< Langmuir number [nondim] ! Local variables ! parameters - real, parameter :: & - ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] - u19p5_to_u10 = 1.075, & - ! ratio of mean frequency to peak frequency for - ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] - fm_into_fp = 1.296, & - ! ratio of surface Stokes drift to U10 [nondim] - us_to_u10 = 0.0162, & - ! loss ratio of Stokes transport [nondim] - r_loss = 0.667 + real, parameter :: u19p5_to_u10 = 1.075 ! ratio of U19.5 to U10 (Holthuijsen, 2007) [nondim] + real, parameter :: fm_into_fp = 1.296 ! ratio of mean frequency to peak frequency for + ! Pierson-Moskowitz spectrum (Webb, 2011) [nondim] + real, parameter :: us_to_u10 = 0.0162 ! ratio of surface Stokes drift to U10 [nondim] + real, parameter :: r_loss = 0.667 ! loss ratio of Stokes transport [nondim] real :: UStokes ! The surface Stokes drift [L T-1 ~> m s-1] real :: hm0 ! The significant wave height [Z ~> m] real :: fm ! The mean wave frequency [T-1 ~> s-1] @@ -1210,7 +1251,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! real :: root_2kz ! The square root of twice the peak wavenumber times the ! ! boundary layer depth [nondim] real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] PI = 4.0*atan(1.0) UStokes_sl = 0.0 @@ -1219,12 +1260,12 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! This code should be revised to minimize the number of divisions and cancel out common factors. ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/(1.225*US%kg_m3_to_R)), u10, GV, US, CS) + call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/CS%rho_air), u10, GV, US, CS) ! surface Stokes drift UStokes = us_to_u10*u10 ! ! significant wave height from Pierson-Moskowitz spectrum (Bouws, 1998) - hm0 = 0.0246*US%m_to_Z*US%L_T_to_m_s**2 * u10**2 + hm0 = CS%SWH_from_u10sq * u10**2 ! ! peak frequency (PM, Bouws, 1998) fp = 0.877 * (US%L_to_Z*GV%g_Earth) / (2.0 * PI * u19p5_to_u10 * u10) @@ -1306,13 +1347,13 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) real, dimension(SZK_(GV)), & intent(in) :: H !< Grid thickness [H ~> m or kg m-2] real, dimension(SZK_(GV)), & - intent(in) :: Profile !< Profile of quantity to be averaged [arbitrary] + intent(in) :: Profile !< Profile of quantity to be averaged in arbitrary units [A] !! (used here for Stokes drift) - real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [arbitrary] + real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [A] !! (used here for Stokes drift) !Local variables real :: top, midpoint, bottom ! Depths, negative downward [Z ~> m]. - real :: Sum + real :: Sum ! The depth weighted vertical sum of a quantity [A Z ~> A m] integer :: kk ! Initializing sum @@ -1392,23 +1433,18 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) real :: omega_peak ! The peak wave frequency [T-1 ~> s-1] real :: omega ! The average frequency in the band [T-1 ~> s-1] real :: domega ! The width in frequency of the band [T-1 ~> s-1] - real :: omega_min ! The minimum wave frequency [T-1 ~> s-1] - real :: omega_max ! The maximum wave frequency [T-1 ~> s-1] real :: u10 ! The wind speed for this spectrum [Z T-1 ~> m s-1] real :: wavespec ! The wave spectrum [L Z T ~> m2 s] real :: Stokes ! The Stokes displacement per cycle [L ~> m] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] integer :: Nomega ! The number of wavenumber bands integer :: OI u10 = CS%WaveWind*US%L_to_Z !/ - omega_min = 0.1*US%T_to_s ! Hz - ! Cut off at 30cm for now... - omega_max = 10.*US%T_to_s ! ~sqrt(0.2*g_Earth*2*pi/0.3) NOmega = 1000 - domega = (omega_max-omega_min)/real(NOmega) + domega = (CS%omega_max - CS%omega_min) / real(NOmega) ! if (CS%WaveAgePeakFreq) then @@ -1427,13 +1463,13 @@ subroutine DHH85_mid(GV, US, CS, zpt, UStokes) endif !/ UStokes = 0.0 - omega = omega_min + 0.5*domega + omega = CS%omega_min + 0.5*domega do oi = 1,nomega-1 Dnn = exp ( -0.5 * (omega-omega_peak)**2 / (Snn**2 * omega_peak**2) ) - ! wavespec units = m2s + ! wavespec units [L Z T ~> m2 s] wavespec = US%Z_to_L * (Ann * CS%g_Earth**2 / (omega_peak*omega**4 ) ) * & exp(-bnn*(omega_peak/omega)**4)*Cnn**Dnn - ! Stokes units m (multiply by frequency range for units of m/s) + ! Stokes units [L ~> m] (multiply by frequency range for units of [L T-1 ~> m s-1]) Stokes = 2.0 * wavespec * omega**3 * & exp( 2.0 * omega**2 * zpt / CS%g_Earth) / CS%g_Earth UStokes = UStokes + Stokes*domega @@ -1461,7 +1497,7 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) ! Local variables real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z L T-2 ~> m2 s-2] real :: h_Lay ! The layer thickness at a velocity point [Z ~> m]. - integer :: i,j,k + integer :: i, j, k ! This is a template to think about down-Stokes mixing. ! This is not ready for use... @@ -1824,8 +1860,6 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure ! Local variables - real, parameter :: vonkar = 0.4 ! Should access a get_param von karman - real :: nu ! The viscosity of air [Z2 T-1 ~> m2 s-1] real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] real :: alpha ! A nondimensional factor in a parameterization [nondim] @@ -1838,21 +1872,22 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) ! Note in Edson et al. 2013, eq. 13 m is given as 0.017. However, ! m=0.0017 reproduces the curve in their figure 6. - nu = 1.0e-6*US%m2_s_to_Z2_T ! Should access a get_param for air-viscosity + if (CS%vonKar < 0.0) call MOM_error(FATAL, & + "ust_2_u10_coare3p5 called with a negative value of Waves%vonKar") - z0sm = 0.11 * nu / USTair ! Compute z0smooth from ustar guess + z0sm = 0.11 * CS%nu_air / USTair ! Compute z0smooth from ustar guess u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 - ! For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . + !### For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. CT=0 - do while (abs(u10a/u10 - 1.) > 0.001) ! Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. + do while (abs(u10a/u10 - 1.) > 0.001) !### Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. CT=CT+1 u10a = u10 alpha = min(0.028, 0.0017*US%L_T_to_m_s * u10 - 0.005) z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess z0 = z0sm + z0rough - CD = ( vonkar / log(10.*US%m_to_Z / z0) )**2 ! Compute CD from derived roughness + CD = ( CS%vonKar / log(10.*US%m_to_Z / z0) )**2 ! Compute CD from derived roughness u10 = US%Z_to_L*USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop ! ends and checks for convergence...CT counter ! makes sure loop doesn't run away if function From 775050b255a95d8fb0c74b38a76c722bad7b23f6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 07:30:58 -0500 Subject: [PATCH 114/629] +Add runtime parameter for dumbbell_initialization Added the new runtime parameter DUMBBELL_T_LIGHT to specify the previously hard-coded dimensional parameters in the dumbbell_initialization module. Also used G%x_ax_unit_short to describe the units of the DUMBBELL_LEN. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for the dumbbell test case. --- src/user/dumbbell_initialization.F90 | 21 ++++++++++----------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 26b382b94c..0b65883eca 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -52,11 +52,10 @@ subroutine dumbbell_initialize_topography( D, G, param_file, max_depth ) logical :: dbrotate ! If true, rotate this configuration integer :: i, j - call get_param(param_file, mdl, "DUMBBELL_LEN",dblen, & + call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & 'Lateral Length scale for dumbbell.', & - units='km', default=600., do_not_log=.false.) - ! units=G%x_ax_unit_short, default=600., do_not_log=.false.) - call get_param(param_file, mdl, "DUMBBELL_FRACTION",dbfrac, & + units=G%x_ax_unit_short, default=600., do_not_log=.false.) + call get_param(param_file, mdl, "DUMBBELL_FRACTION", dbfrac, & 'Meridional fraction for narrow part of dumbbell.', & units='nondim', default=0.5, do_not_log=.false.) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & @@ -275,8 +274,6 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - T_surf = 20.0*US%degC_to_C - ! layer mode call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) if (.not. use_ALE) call MOM_error(FATAL, "dumbbell_initialize_temperature_salinity: "//& @@ -287,6 +284,9 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ call get_param(param_file, mdl, "INITIAL_DENSITY_PROFILE", density_profile, & 'Initial profile shape. Valid values are "linear", "parabolic" '// & 'and "exponential".', default='linear', do_not_log=just_read) + 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=just_read) call get_param(param_file, mdl, "DUMBBELL_SREF", S_surf, & 'DUMBBELL REFERENCE SALINITY', & units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=just_read) @@ -294,9 +294,8 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ 'DUMBBELL salinity range (right-left)', & units='1e-3', default=2., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & - 'Lateral Length scale for dumbbell ', & - units='km', default=600., do_not_log=just_read) - ! units=G%x_ax_unit_short, default=600., do_not_log=.false.) + 'Lateral Length scale for dumbbell ', & + units=G%x_ax_unit_short, default=600., do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_ROTATION", dbrotate, & 'Logical for rotation of dumbbell domain.', & default=.false., do_not_log=just_read) @@ -376,8 +375,8 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil nz = GV%ke call get_param(param_file, mdl, "DUMBBELL_SPONGE_TIME_SCALE", sponge_time_scale, & - "The time scale in the reservoir for restoring. If zero, the sponge is disabled.", & - units="s", default=0., scale=US%s_to_T) + "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_SREF", S_ref, & 'DUMBBELL REFERENCE SALINITY', & units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=.true.) From bd0cd8a4eaae066d2945b27be321b3cdd85489dd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 07:31:22 -0500 Subject: [PATCH 115/629] +Add runtime parameters for Kelvin_initialization Added the new runtime parameters KELVIN_WAVE_PERIOD, KELVIN_WAVE_SSH_AMP and KELVIN_WAVE_INFLOW_AMP to specify the previously hard-coded dimensional parameters in the Kelvin_initialization module. This change includes the addition of 3 new elements in the Kelvin_OBC_CS type. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for configurations using the Kelvin_initialization module. --- src/user/Kelvin_initialization.F90 | 64 ++++++++++++++++++------------ 1 file changed, 39 insertions(+), 25 deletions(-) diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 1684f88a89..88d0cbb482 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -16,7 +16,7 @@ module Kelvin_initialization use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_S, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_registry_type -use MOM_unit_scaling, only : unit_scale_type +use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_time_manager, only : time_type, time_type_to_real @@ -35,13 +35,16 @@ module Kelvin_initialization !> Control structure for Kelvin wave open boundaries. type, public :: Kelvin_OBC_CS ; private integer :: mode = 0 !< Vertical mode - real :: coast_angle = 0 !< Angle of coastline [rad] - real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] - real :: coast_offset2 = 0 !< Longshore distance to coastal angle [L ~> m] - real :: H0 = 0 !< Bottom depth [Z ~> m] - real :: F_0 !< Coriolis parameter [T-1 ~> s-1] - real :: rho_range !< Density range [R ~> kg m-3] - real :: rho_0 !< Mean density [R ~> kg m-3] + real :: coast_angle = 0 !< Angle of coastline [rad] + real :: coast_offset1 = 0 !< Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 = 0 !< Offshore distance to coastal angle [L ~> m] + real :: H0 = 0 !< Bottom depth [Z ~> m] + real :: F_0 !< Coriolis parameter [T-1 ~> s-1] + real :: rho_range !< Density range [R ~> kg m-3] + real :: rho_0 !< Mean density [R ~> kg m-3] + real :: wave_period !< Period of the mode-0 waves [T ~> s] + real :: ssh_amp !< Amplitude of the sea surface height forcing for mode-0 waves [Z ~> m] + real :: inflow_amp !< Amplitude of the boundary velocity forcing for internal waves [L T-1 ~> m s-1] end type Kelvin_OBC_CS ! This include declares and sets the variable "version". @@ -87,16 +90,28 @@ function register_Kelvin_OBC(param_file, CS, US, OBC_Reg) units="km", default=10.0, scale=1.0e3*US%m_to_L) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", CS%coast_angle, & "The angle of the southern bondary beyond X=ROTATED_COAST_OFFSET.", & - units="degrees", default=11.3) - CS%coast_angle = CS%coast_angle * (atan(1.0)/45.) ! Convert to radians + units="degrees", default=11.3, scale=atan(1.0)/45.) ! Convert to radians + else + CS%coast_offset1 = 0.0 ; CS%coast_offset2 = 0.0 ; CS%coast_angle = 0.0 endif - if (CS%mode /= 0) then + if (CS%mode == 0) then + call get_param(param_file, mdl, "KELVIN_WAVE_PERIOD", CS%wave_period, & + "The period of the Kelvin wave forcing at the open boundaries. "//& + "The default value is the M2 tide period.", & + units="s", default=12.42*3600.0, scale=US%s_to_T) + call get_param(param_file, mdl, "KELVIN_WAVE_SSH_AMP", CS%ssh_amp, & + "The amplitude of the Kelvin wave sea surface height anomaly forcing "//& + "at the open boundaries.", units="m", default=1.0, scale=US%m_to_Z) + else call get_param(param_file, mdl, "DENSITY_RANGE", CS%rho_range, & units="kg m-3", default=2.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "RHO_0", CS%rho_0, & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "MAXIMUM_DEPTH", CS%H0, & units="m", default=1000.0, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "KELVIN_WAVE_INFLOW_AMP", CS%inflow_amp, & + "The amplitude of the Kelvin wave sea surface inflow velocity forcing "//& + "at the open boundaries.", units="m s-1", default=1.0, scale=US%m_s_to_L_T) endif ! Register the Kelvin open boundary. @@ -126,8 +141,10 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) ! Local variables character(len=40) :: mdl = "Kelvin_initialize_topography" ! This subroutine's name. - real :: min_depth ! The minimum and maximum depths [Z ~> m]. - real :: coast_offset1, coast_offset2, coast_angle, right_angle + real :: min_depth ! The minimum and maximum depths [Z ~> m]. + real :: coast_angle ! Angle of coastline [rad] + real :: coast_offset1 ! Longshore distance to coastal angle [L ~> m] + real :: coast_offset2 ! Offshore distance to coastal angle [L ~> m] integer :: i, j call MOM_mesg(" Kelvin_initialization.F90, Kelvin_initialize_topography: setting topography", 5) @@ -139,22 +156,19 @@ subroutine Kelvin_initialize_topography(D, G, param_file, max_depth, US) call get_param(param_file, mdl, "ROTATED_COAST_OFFSET_2", coast_offset2, & units="km", default=10.0, do_not_log=.true.) call get_param(param_file, mdl, "ROTATED_COAST_ANGLE", coast_angle, & - units="degrees", default=11.3, do_not_log=.true.) - - coast_angle = coast_angle * (atan(1.0)/45.) ! Convert to radians - right_angle = 2 * atan(1.0) + units="degrees", default=11.3, scale=(atan(1.0)/45.), do_not_log=.true.) ! Convert to radians do j=G%jsc,G%jec ; do i=G%isc,G%iec D(i,j) = max_depth ! Southern side if ((G%geoLonT(i,j) - G%west_lon > coast_offset1) .AND. & (atan2(G%geoLatT(i,j) - G%south_lat + coast_offset2, & - G%geoLonT(i,j) - G%west_lon - coast_offset1) < coast_angle)) & + G%geoLonT(i,j) - G%west_lon - coast_offset1) < coast_angle)) & D(i,j) = 0.5*min_depth ! Northern side if ((G%geoLonT(i,j) - G%west_lon < G%len_lon - coast_offset1) .AND. & (atan2(G%len_lat + G%south_lat + coast_offset2 - G%geoLatT(i,j), & - G%len_lon + G%west_lon - coast_offset1 - G%geoLonT(i,j)) < coast_angle)) & + G%len_lon + G%west_lon - coast_offset1 - G%geoLonT(i,j)) < coast_angle)) & D(i,j) = 0.5*min_depth if (D(i,j) > max_depth) D(i,j) = max_depth @@ -181,10 +195,8 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: N0 ! Brunt-Vaisala frequency times a rescaling of slopes [L Z-1 T-1 ~> s-1] real :: lambda ! Offshore decay scale [L-1 ~> m-1] real :: omega ! Wave frequency [T-1 ~> s-1] - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real :: depth_tot(SZI_(G),SZJ_(G)) ! The total depth of the ocean [Z ~> m] - integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz - integer :: IsdB, IedB, JsdB, JedB real :: mag_SSH ! An overall magnitude of the external wave sea surface height at the coastline [Z ~> m] real :: mag_int ! An overall magnitude of the internal wave at the coastline [L2 T-2 ~> m2 s-2] real :: x1, y1 ! Various positions [L ~> m] @@ -194,6 +206,8 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) real :: km_to_L_scale ! A scaling factor from longitudes in km to L [L km-1 ~> 1e3] real :: sina, cosa ! The sine and cosine of the coast angle [nondim] type(OBC_segment_type), pointer :: segment => NULL() + integer :: i, j, k, n, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -214,11 +228,11 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo ; enddo ; enddo if (CS%mode == 0) then - mag_SSH = 1.0*US%m_to_Z - omega = 2.0 * PI / (12.42 * 3600.0*US%s_to_T) ! M2 Tide period + mag_SSH = CS%ssh_amp + omega = 2.0 * PI / CS%wave_period val1 = sin(omega * time_sec) else - mag_int = 1.0*US%m_s_to_L_T**2 + mag_int = CS%inflow_amp**2 N0 = sqrt((CS%rho_range / CS%rho_0) * (GV%g_Earth / CS%H0)) lambda = PI * CS%mode * CS%F_0 / (CS%H0 * N0) ! Two wavelengths in domain From 40c24c5ad6616d2eecc5ec52dccf39b1b3ec80ac Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 07:31:49 -0500 Subject: [PATCH 116/629] +Add runtime parameters for tidal_bay_initialization Added the new runtime parameters TIDAL_BAY_PERIOD and TIDAL_BAY_SSH_ANOM to specify the previously hard-coded dimensional parameters in the tidal_bay_initialization module. This change includes the addition of 2 new elements in the tidal_bay_OBC_CS type. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for configurations using the tidal_bay_initialization module. --- src/user/tidal_bay_initialization.F90 | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index d25ad0615c..60ce7b4a56 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -25,7 +25,10 @@ module tidal_bay_initialization !> Control structure for tidal bay open boundaries. type, public :: tidal_bay_OBC_CS ; private - real :: tide_flow = 3.0e6 !< Maximum tidal flux [L2 Z T-1 ~> m3 s-1] + real :: tide_flow = 3.0e6 !< Maximum tidal flux with the tidal bay configuration [L2 Z T-1 ~> m3 s-1] + real :: tide_period !< The period associated with the tidal bay configuration [T ~> s-1] + real :: tide_ssh_amp !< The magnitude of the sea surface height anomalies at the inflow + !! with the tidal bay configuration [Z ~> m] end type tidal_bay_OBC_CS contains @@ -43,6 +46,13 @@ function register_tidal_bay_OBC(param_file, CS, US, OBC_Reg) call get_param(param_file, mdl, "TIDAL_BAY_FLOW", CS%tide_flow, & "Maximum total tidal volume flux.", & units="m3 s-1", default=3.0e6, scale=US%m_s_to_L_T*US%m_to_L*US%m_to_Z) + call get_param(param_file, mdl, "TIDAL_BAY_PERIOD", CS%tide_period, & + "Period of the inflow in the tidal bay configuration.", & + units="s", default=12.0*3600.0, scale=US%s_to_T) + call get_param(param_file, mdl, "TIDAL_BAY_SSH_ANOM", CS%tide_ssh_amp, & + "Magnitude of the sea surface height anomalies at the inflow with the "//& + "tidal bay configuration.", & + units="m", default=0.1, scale=US%m_to_Z) ! Register the open boundaries. call register_OBC(casename, param_file, OBC_Reg) @@ -63,11 +73,11 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the tidal_bay example. - real :: time_sec + real :: time_sec ! Elapsed model time [T ~> s] real :: cff_eta ! The total column thickness anomalies associated with the inflow [H ~> m or kg m-2] real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] real :: total_area ! The total face area of the OBCs [L Z ~> m2] - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] real :: flux_scale ! A scaling factor for the areas [m2 H-1 L-1 ~> nondim or m3 kg-1] real, allocatable :: my_area(:,:) ! The total OBC inflow area [m2] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, n @@ -86,10 +96,10 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) flux_scale = GV%H_to_m*US%L_to_m - time_sec = time_type_to_real(Time) - cff_eta = 0.1*GV%m_to_H * sin(2.0*PI*time_sec/(12.0*3600.0)) - my_area=0.0 - my_flux=0.0 + time_sec = US%s_to_T*time_type_to_real(Time) + cff_eta = CS%tide_ssh_amp*GV%Z_to_H * sin(2.0*PI*time_sec / CS%tide_period) + my_area = 0.0 + my_flux = 0.0 segment => OBC%segment(1) do j=segment%HI%jsc,segment%HI%jec ; do I=segment%HI%IscB,segment%HI%IecB @@ -101,7 +111,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) endif enddo ; enddo total_area = reproducing_sum(my_area) - my_flux = - CS%tide_flow*SIN(2.0*PI*time_sec/(12.0*3600.0)) + my_flux = - CS%tide_flow * SIN(2.0*PI*time_sec / CS%tide_period) do n = 1, OBC%number_of_segments segment => OBC%segment(n) From 47fa47ed26f2eb5e834b034a0ab40fd05b6a8282 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 20 Dec 2022 11:49:19 -0500 Subject: [PATCH 117/629] makedep: Include object file dependencies The current implementation of makedep contains something like a race condition, where the creation of the .mod and .o files may be in an order which breaks the current dependency tree. Currently, .mod depends on .o, and changes to a module do not trigger rebuilds of dependent source. Rather than try to sort out the rule order, which could even depend on compiler internals, this patch just adds both object and module output files as dependencies, and rebuilds if either changes. We might want to come back to this someday and understand the actual order of rule execution. Thanks to Alistair Adcroft (@adcroft) for proposing this solution. --- ac/makedep | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/ac/makedep b/ac/makedep index 5954f1aae5..439679f17d 100755 --- a/ac/makedep +++ b/ac/makedep @@ -136,6 +136,10 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, # Write rule for each object from Fortran for o in sorted(o2F90.keys()): found_mods = [m for m in o2uses[o] if m in all_modules] + found_objs = [mod2o[m] for m in o2uses[o] if m in all_modules] + found_deps = [ + dep for pair in zip(found_mods, found_objs) for dep in pair + ] missing_mods = [m for m in o2uses[o] if m not in all_modules] incs = nested_inc(o2h[o] + o2inc[o], f2F) incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) @@ -145,7 +149,8 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, print("# object:", o, file=file) print("# modules:", ' '.join(o2mods[o]), file=file) print("# uses:", ' '.join(o2uses[o]), file=file) - print("# found:", ' '.join(found_mods), file=file) + print("# found mods:", ' '.join(found_mods), file=file) + print("# found objs:", ' '.join(found_objs), file=file) print("# missing:", ' '.join(missing_mods), file=file) print("# includes_all:", ' '.join(incs), file=file) print("# includes_pth:", ' '.join(incdeps), file=file) @@ -153,7 +158,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, print("# program:", ' '.join(o2prg[o]), file=file) if o2mods[o]: print(' '.join(o2mods[o])+':', o, file=file) - print(o + ':', o2F90[o], ' '.join(incdeps+found_mods), file=file) + print(o + ':', o2F90[o], ' '.join(incdeps+found_deps), file=file) print('\t'+fc_rule, ' '.join(incargs), file=file) # Write rule for each object from C From 5f1572f377ee2ddc6ff58ecd63532c6a7da614ae Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 19 Dec 2022 09:37:07 -0500 Subject: [PATCH 118/629] +Revise interfaces to horiz_interp_and_extract Revised the interface to the two horiz_interp_and_extract to eliminate the unused reentrant_x and tripolar_n arguments and to rename the conversion argument to scale and make it the last mandatory argument in anticipation that we might decide to make it optional, similarly to other routines like MOM_read_data. The renaming is because we use 'conversion' to indicate how the internal representation is to be rescaled for output, most prominently in register_diag_field, whereas everywhere else where we are rescaling input to the model's internal units, we use a scale argument. This makes the convention self-consistent across the MOM6 code, and should avoid some confusion. The calls to these routines were updated in 8 places in 4 modules. In 8 places the get_param calls for TRIPOLAR_N or REENTRANT_X that are no longer needed were eliminated as were the associated internal variables. This commit also includes some additions to comments near the changes that were directly tied to this commit. All answers are bitwise identical, but there are changes to a publicly visible interface; code that tries to use the old interface will not compile. --- src/framework/MOM_horizontal_regridding.F90 | 59 ++++++++++--------- .../MOM_state_initialization.F90 | 43 +++++++------- .../MOM_tracer_initialization_from_Z.F90 | 41 +++++++------ src/ocean_data_assim/MOM_oda_driver.F90 | 21 ++++--- .../vertical/MOM_ALE_sponge.F90 | 37 ++++-------- 5 files changed, 97 insertions(+), 104 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index bbb5ae0e15..7a0ace9279 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -250,14 +250,13 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, end subroutine fill_miss_2d !> Extrapolate and interpolate from a file record -subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, recnum, G, tr_z, mask_z, & - z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & +subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr_z, mask_z, & + z_in, z_edges_in, missing_value, scale, & homogenize, m_to_Z, answers_2018, ongrid, tr_iter_tol, answer_date) character(len=*), intent(in) :: filename !< Path to file containing tracer to be !! interpolated. character(len=*), intent(in) :: varnam !< Name of tracer in file. - real, intent(in) :: conversion !< Conversion factor for tracer [CU conc-1 ~> 1] integer, intent(in) :: recnum !< Record number of tracer to be read. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z @@ -271,10 +270,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real, allocatable, dimension(:), intent(out) :: z_edges_in !< Cell grid edge values for input data [Z ~> m] real, intent(out) :: missing_value !< The missing value in the returned array, scaled - !! with conversion to avoid accidentally having valid - !! values match missing values [CU ~> conc] - logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction - logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid + !! to avoid accidentally having valid values match + !! missing values [CU ~> conc] + real, intent(in) :: scale !< Scaling factor for tracer into the internal + !! units of the model [CU conc-1 ~> 1] logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units @@ -311,7 +310,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] - real :: max_lat ! The maximum latitude on the input grid [degreeN] + real :: max_lat ! The maximum latitude on the input grid [degreesN] real :: pole ! The sum of tracer values at the pole [conc] real :: max_depth ! The maximum depth of the ocean [Z ~> m] real :: npole ! The number of points contributing to the pole value [nondim] @@ -330,7 +329,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read logical :: debug=.false. - real :: I_scale ! The inverse of the conversion factor for diagnostic output [conc CU-1 ~> 1] + real :: I_scale ! The inverse of the scale factor for diagnostic output [conc CU-1 ~> 1] real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing ! iterations that determines when to stop iterating [CU ~> conc] real :: npoints ! The number of points in an average [nondim] @@ -355,10 +354,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, is_ongrid = .false. if (present(ongrid)) is_ongrid = ongrid - dtr_iter_stop = 1.0e-3*conversion + dtr_iter_stop = 1.0e-3*scale if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol - I_scale = 1.0 / conversion + I_scale = 1.0 / scale PI_180 = atan(1.0)/45. @@ -371,6 +370,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, call cpu_clock_begin(id_clock_read) + ! A note by MJH copied from elsewhere suggests that this code may be using the model connectivity + ! (e.g., reentrant or tripolar) but should use the dataset's connectivity instead. + call get_var_axes_info(trim(filename), trim(varnam), axes_info) if (allocated(z_in)) deallocate(z_in) @@ -418,7 +420,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, if (.not. found_attr) call MOM_error(FATAL, & "error finding missing value for " // trim(varnam) // & " in file " // trim(filename) // " in hinterp_extrap") - missing_value = conversion * missing_val_in + missing_value = scale * missing_val_in call read_attribute(trim(filename), "scale_factor", scale_factor, & varname=trim(varnam), found=found_attr) @@ -471,7 +473,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, do i=is,ie if (abs(tr_in(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 - tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * conversion + tr_in(i,j) = (tr_in(i,j)*scale_factor+add_offset) * scale else tr_in(i,j) = missing_value endif @@ -511,7 +513,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, do j=1,jdp ; do i=1,id if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 - tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * conversion + tr_inp(i,j) = (tr_inp(i,j)*scale_factor+add_offset) * scale else tr_inp(i,j) = missing_value endif @@ -596,18 +598,17 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, conversion, end subroutine horiz_interp_and_extrap_tracer_record !> Extrapolate and interpolate using a FMS time interpolation handle -subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, tr_z, mask_z, & - z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & +subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, 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(time_type), intent(in) :: Time !< A FMS time type - real, intent(in) :: conversion !< Conversion factor for tracer. type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z !< Allocatable tracer array on the horizontal - !! model grid and input-file vertical levels. [CU ~> conc] + !! model grid and input-file vertical levels [CU ~> conc] real, allocatable, dimension(:,:,:), intent(out) :: mask_z !< Allocatable tracer mask array on the horizontal !! model grid and input-file vertical levels [nondim] @@ -616,10 +617,10 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, allocatable, dimension(:), intent(out) :: z_edges_in !< Cell grid edge values for input data [Z ~> m] real, intent(out) :: missing_value !< The missing value in the returned array, scaled - !! with conversion to avoid accidentally having valid - !! values match missing values [CU ~> conc] - logical, intent(in) :: reentrant_x !< If true, this grid is reentrant in the x-direction - logical, intent(in) :: tripolar_n !< If true, this is a northern tripolar grid + !! to avoid accidentally having valid values match + !! missing values [CU ~> conc] + real, intent(in) :: scale !< Scaling factor for tracer into the internal + !! units of the model [CU conc-1 ~> 1] logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid @@ -655,7 +656,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t real, dimension(:), allocatable :: lon_in ! The longitudes in the input file [degreesE] then [radians] real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] - real :: max_lat ! The maximum latitude on the input grid [degreeN] + real :: max_lat ! The maximum latitude on the input grid [degreesN] real :: pole ! The sum of tracer values at the pole [conc] real :: max_depth ! The maximum depth of the ocean [Z ~> m] real :: npole ! The number of points contributing to the pole value [nondim] @@ -673,7 +674,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t logical :: debug=.false. logical :: is_ongrid integer :: ans_date ! The vintage of the expressions and order of arithmetic to use - real :: I_scale ! The inverse of the conversion factor for diagnostic output [conc CU-1 ~> 1] + real :: I_scale ! The inverse of the scale factor for diagnostic output [conc CU-1 ~> 1] real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing ! iterations that determines when to stop iterating [CU ~> conc] real :: npoints ! The number of points in an average [nondim] @@ -699,10 +700,10 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t id_clock_read = cpu_clock_id('(Initialize tracer from Z) read', grain=CLOCK_LOOP) - dtr_iter_stop = 1.0e-3*conversion + dtr_iter_stop = 1.0e-3*scale if (present(tr_iter_tol)) dtr_iter_stop = tr_iter_tol - I_scale = 1.0 / conversion + I_scale = 1.0 / scale PI_180 = atan(1.0)/45. @@ -716,7 +717,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t call cpu_clock_begin(id_clock_read) call get_external_field_info(fms_id, size=fld_sz, axes=axes_data, missing=missing_val_in) - missing_value = conversion*missing_val_in + missing_value = scale*missing_val_in verbosity = MOM_get_verbosity() @@ -823,7 +824,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t do j=1,jdp ; do i=1,id if (abs(tr_inp(i,j)-missing_val_in) > abs(roundoff*missing_val_in)) then mask_in(i,j) = 1.0 - tr_inp(i,j) = tr_inp(i,j) * conversion + tr_inp(i,j) = tr_inp(i,j) * scale else tr_inp(i,j) = missing_value endif @@ -909,7 +910,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, conversion, G, t do k=1,kd do j=js,je do i=is,ie - tr_z(i,j,k) = data_in(i,j,k) * conversion + tr_z(i,j,k) = data_in(i,j,k) * scale if (ans_date >= 20190101) mask_z(i,j,k) = 1. if (abs(tr_z(i,j,k)-missing_value) < abs(roundoff*missing_value)) mask_z(i,j,k) = 0. enddo diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 62438cbc7f..c5b57f3d57 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2483,8 +2483,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just real :: PI_180 ! for conversion from degrees to radians [radian degree-1] real :: Hmix_default ! The default initial mixed layer depth [Z ~> m]. real :: Hmix_depth ! The mixed layer depth in the initial condition [Z ~> m]. - real :: missing_value_temp ! The missing value in the input temperature field - real :: missing_value_salt ! The missing value in the input salinity field + real :: missing_value_temp ! The missing value in the input temperature field [C ~> degC] + real :: missing_value_salt ! The missing value in the input salinity field [S ~> ppt] + real :: tol_temp ! The tolerance for changes in temperature during the horizontal + ! interpolation from an input dataset [C ~> degC] + real :: tol_sal ! The tolerance for changes in salinity during the horizontal + ! interpolation from an input dataset [S ~> ppt] logical :: correct_thickness real :: h_tolerance ! A parameter that controls the tolerance when adjusting the ! thickness to fit the bathymetry [Z ~> m]. @@ -2494,19 +2498,19 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just logical :: adjust_temperature = .true. ! fit t/s to target densities real :: temp_land_fill ! A temperature value to use for land points [C ~> degC] real :: salt_land_fill ! A salinity value to use for land points [C ~> degC] - logical :: reentrant_x, tripolar_n ! data arrays - real, dimension(:), allocatable :: z_edges_in, z_in ! Interface heights [Z ~> m] - real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] + real, dimension(:), allocatable :: z_edges_in ! Input data interface heights or depths [Z ~> m] + real, dimension(:), allocatable :: z_in ! Input data cell heights or depths [Z ~> m] + real, dimension(:), allocatable :: Rb ! Interface densities [R ~> kg m-3] real, dimension(:,:,:), allocatable, target :: temp_z ! Input temperatures [C ~> degC] 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(:,:,:), 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)) :: 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 + 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 real, dimension(SZI_(G)) :: press ! Pressures [R L2 T-2 ~> Pa]. ! Local variables for ALE remapping @@ -2569,9 +2573,6 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just eos => tv%eqn_of_state - reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x, default=.true.) - tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - call get_param(PF, mdl, "TEMP_SALT_Z_INIT_FILE", filename, & "The name of the z-space input file used to initialize "//& "temperatures (T) and salinities (S). If T and S are not "//& @@ -2701,6 +2702,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just !### These hard-coded constants should be made into runtime parameters temp_land_fill = 0.0*US%degC_to_C salt_land_fill = 35.0*US%ppt_to_S + tol_temp = 1.0e-3*US%degC_to_C + tol_sal = 1.0e-3*US%ppt_to_S eps_z = GV%Angstrom_Z eps_rho = 1.0e-10*US%kg_m3_to_R @@ -2720,15 +2723,15 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! to the North/South Pole past the limits of the input data, they are extrapolated using the average ! value at the northernmost/southernmost latitude. - call horiz_interp_and_extrap_tracer(tfilename, potemp_var, US%degC_to_C, 1, & - G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date, & - ongrid=pre_gridded, tr_iter_tol=1.0e-3*US%degC_to_C) + call horiz_interp_and_extrap_tracer(tfilename, potemp_var, 1, & + G, temp_z, mask_z, z_in, z_edges_in, missing_value_temp, & + scale=US%degC_to_C, homogenize=homogenize, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=pre_gridded, tr_iter_tol=tol_temp) - call horiz_interp_and_extrap_tracer(sfilename, salin_var, US%ppt_to_S, 1, & - G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, reentrant_x, & - tripolar_n, homogenize, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date, & - ongrid=pre_gridded, tr_iter_tol=1.0e-3*US%ppt_to_S) + call horiz_interp_and_extrap_tracer(sfilename, salin_var, 1, & + G, salt_z, mask_z, z_in, z_edges_in, missing_value_salt, & + scale=US%ppt_to_S, homogenize=homogenize, m_to_Z=US%m_to_Z, & + answer_date=hor_regrid_answer_date, ongrid=pre_gridded, tr_iter_tol=tol_sal) kd = size(z_in,1) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 04c03a5b43..7c62ea496e 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -41,11 +41,12 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ 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]. - real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized + real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized [CU ~> conc] type(param_file_type), intent(in) :: PF !< parameter file character(len=*), intent(in) :: src_file !< source filename character(len=*), intent(in) :: src_var_nam !< variable name in file - real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion + real, optional, intent(in) :: src_var_unit_conversion !< optional multiplicative unit conversion, + !! often used for rescaling into model units [CU conc-1 ~> 1] integer, optional, intent(in) :: src_var_record !< record to read for multiple time-level files logical, optional, intent(in) :: homogenize !< optionally homogenize to mean value logical, optional, intent(in) :: useALEremapping !< to remap or not (optional) @@ -53,11 +54,11 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ character(len=*), optional, intent(in) :: src_var_gridspec !< Source variable name in a gridspec file. !! This is not implemented yet. ! Local variables - real :: land_fill = 0.0 - real :: convert + real :: land_fill = 0.0 ! A value to use to replace missing values [CU ~> conc] + real :: convert ! A conversion factor into the model's internal units [CU conc-1 ~> 1] integer :: recnum character(len=64) :: remapScheme - logical :: homog,useALE + logical :: homog, useALE ! This include declares and sets the variable "version". # include "version_variable.h" @@ -66,8 +67,12 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ integer :: is, ie, js, je, nz ! compute domain indices integer :: isd, ied, jsd, jed ! data domain indices integer :: i, j, k, kd - real, allocatable, dimension(:,:,:), target :: tr_z, mask_z - real, allocatable, dimension(:), target :: z_edges_in, z_in + real, allocatable, dimension(:,:,:), target :: tr_z ! Tracer array on the horizontal model grid + ! and input-file vertical levels [CU ~> conc] + real, allocatable, dimension(:,:,:), target :: mask_z ! Missing value mask on the horizontal model grid + ! and input-file vertical levels [nondim] + real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] + 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]. @@ -75,8 +80,8 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ real :: zTopOfCell, zBottomOfCell, z_bathy ! Heights [Z ~> m]. type(remapping_CS) :: remapCS ! Remapping parameters and work arrays - real :: missing_value - integer :: nPoints + 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 integer :: id_clock_routine, id_clock_ALE 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. @@ -94,7 +99,6 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ ! for horizontal regridding. Values below 20190101 recover the ! answers from 2018, while higher values use expressions that have ! been rearranged for rotational invariance. - logical :: reentrant_x, tripolar_n id_clock_routine = cpu_clock_id('(Initialize tracer from Z)', grain=CLOCK_ROUTINE) id_clock_ALE = cpu_clock_id('(Initialize tracer from Z) ALE', grain=CLOCK_LOOP) @@ -153,22 +157,17 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_hor_reg_ans_date) - ! These are model grid properties, but being applied to the data grid for now. - ! need to revisit this (mjh) - reentrant_x = .false. ; call get_param(PF, mdl, "REENTRANT_X", reentrant_x,default=.true.) - tripolar_n = .false. ; call get_param(PF, mdl, "TRIPOLAR_N", tripolar_n, default=.false.) - if (PRESENT(homogenize)) homog=homogenize if (PRESENT(useALEremapping)) useALE=useALEremapping if (PRESENT(remappingScheme)) remapScheme=remappingScheme - recnum=1 + recnum = 1 if (PRESENT(src_var_record)) recnum = src_var_record - convert=1.0 + convert = 1.0 if (PRESENT(src_var_unit_conversion)) convert = src_var_unit_conversion - call horiz_interp_and_extrap_tracer(src_file, src_var_nam, convert, recnum, & - G, tr_z, mask_z, z_in, z_edges_in, missing_value, reentrant_x, tripolar_n, & - homog, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date) + call horiz_interp_and_extrap_tracer(src_file, src_var_nam, recnum, & + G, tr_z, mask_z, z_in, z_edges_in, missing_value, & + scale=convert, homogenize=homog, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date) kd = size(z_edges_in,1)-1 call pass_var(tr_z,G%Domain) @@ -221,7 +220,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ ! Fill land values do k=1,nz ; do j=js,je ; do i=is,ie if (tr(i,j,k) == missing_value) then - tr(i,j,k)=land_fill + tr(i,j,k) = land_fill endif enddo ; enddo ; enddo diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 2a1a96168a..4ad11592f9 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -559,19 +559,22 @@ subroutine get_bias_correction_tracer(Time, US, CS) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ODA_CS), pointer :: CS !< ocean DA control structure - integer :: i,j,k + ! Local variables real, allocatable, dimension(:,:,:) :: T_bias ! Temperature biases [C ~> degC] real, allocatable, dimension(:,:,:) :: S_bias ! Salinity biases [C ~> degC] - real, allocatable, dimension(:,:,:) :: mask_z - real, allocatable, dimension(:), target :: z_in, z_edges_in - real :: missing_value - integer,dimension(3) :: fld_sz + real, allocatable, dimension(:,:,:) :: mask_z ! Missing value mask on the horizontal model grid + ! and input-file vertical levels [nondim] + real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] + real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] + real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] + integer, dimension(3) :: fld_sz + integer :: i,j,k call cpu_clock_begin(id_clock_bias_adjustment) - call horiz_interp_and_extrap_tracer(CS%INC_CS%T_id, Time, US%degC_to_C, CS%G, T_bias, & - mask_z, z_in, z_edges_in, missing_value, .true., .false., .false., .true.) - call horiz_interp_and_extrap_tracer(CS%INC_CS%S_id, Time, US%ppt_to_S, CS%G, S_bias, & - mask_z, z_in, z_edges_in, missing_value, .true., .false., .false., .true.) + call horiz_interp_and_extrap_tracer(CS%INC_CS%T_id, Time, CS%G, T_bias, & + mask_z, z_in, z_edges_in, missing_value, scale=US%degC_to_C, spongeOngrid=.true.) + call horiz_interp_and_extrap_tracer(CS%INC_CS%S_id, Time, CS%G, S_bias, & + mask_z, z_in, z_edges_in, missing_value, scale=US%ppt_to_S, spongeOngrid=.true.) ! This should be replaced to use mask_z instead of the following lines ! which are intended to zero land values using an arbitrary limit. diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 9f5241bb9a..a121b05d30 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -133,9 +133,6 @@ module MOM_ALE_sponge logical :: time_varying_sponges !< True if using newer sponge code logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid - logical :: reentrant_x !< grid is reentrant in the x direction - logical :: tripolar_N !< grid is folded at its north edge - !>@{ Diagnostic IDs integer, dimension(MAX_FIELDS_) :: id_sp_tendency !< Diagnostic ids for tracers !! tendency due to sponges @@ -257,11 +254,6 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "while later versions add parentheses for rotational symmetry. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_hor_reg_ans_date) - call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & - "If true, the domain is zonally reentrant.", default=.true.) - call get_param(param_file, mdl, "TRIPOLAR_N", CS%tripolar_N, & - "Use tripolar connectivity at the northern edge of the "//& - "domain. With TRIPOLAR_N, NIGLOBAL must be even.", default=.false.) CS%time_varying_sponges = .false. CS%nz = GV%ke @@ -551,11 +543,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & default=.false.) - call get_param(param_file, mdl, "REENTRANT_X", CS%reentrant_x, & - "If true, the domain is zonally reentrant.", default=.true.) - call get_param(param_file, mdl, "TRIPOLAR_N", CS%tripolar_N, & - "Use tripolar connectivity at the northern edge of the "//& - "domain. With TRIPOLAR_N, NIGLOBAL must be even.", default=.false.) CS%time_varying_sponges = .true. CS%nz = GV%ke @@ -985,10 +972,10 @@ 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, CS%Ref_val(m)%scale, G, sp_val, & - mask_z, z_in, z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z, & - answer_date=CS%hor_regrid_answer_date) + call horiz_interp_and_extrap_tracer(CS%Ref_val(m)%id, 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) allocate( hsrc(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col @@ -1069,10 +1056,10 @@ 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, CS%Ref_val_u%scale, G, sp_val, & - mask_z, z_in, z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& - answer_date=CS%hor_regrid_answer_date) + call horiz_interp_and_extrap_tracer(CS%Ref_val_u%id, 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) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc-1, G%jsc:G%jec, :) = 0. @@ -1118,10 +1105,10 @@ 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, CS%Ref_val_v%scale, G, sp_val, & - mask_z, z_in, z_edges_in, missing_value, CS%reentrant_x, CS%tripolar_N, .false., & - spongeOnGrid=CS%SpongeDataOngrid, m_to_Z=US%m_to_Z,& - answer_date=CS%hor_regrid_answer_date) + call horiz_interp_and_extrap_tracer(CS%Ref_val_v%id, 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) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc:G%iec, G%jsc-1, :) = 0. mask_z(G%isc:G%iec, G%jec+1, :) = 0. From 31cb51737037478aefcfa45c5c2a8688df3f5b23 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 19 Dec 2022 18:09:15 -0500 Subject: [PATCH 119/629] +Add 7 runtime variables for hard-coded tolerances Added the runtime variables DZ_BOTTOM_TOLERANCE, TRIM_IC_Z_TOLERANCE, DENSITY_INTERP_TOLERANCE, HORIZ_INTERP_TOL_TEMP, HORIZ_INTERP_TOL_SALIN, LAND_FILL_TEMP and LAND_FILL_SALIN to replace hard-coded dimensional constants in the routines MOM_temp_salt_initialize_from_Z, trim_for_ice, and initialize_thickness_from_file in MOM_state_initialization.F90. By default, all answers are bitwise identical, but there are new entries in the MOM_parameter_doc files for some configurations. --- .../MOM_state_initialization.F90 | 75 ++++++++++++++----- 1 file changed, 55 insertions(+), 20 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index c5b57f3d57..5af360d775 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -691,7 +691,9 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f ! them to units of m or correct sign conventions to positive upward [various] real :: h_tolerance ! A parameter that controls the tolerance when adjusting the ! thickness to fit the bathymetry [Z ~> m]. - integer :: inconsistent = 0 + real :: tol_dz_bot ! A tolerance for detecting inconsistent bottom depths when + ! correct_thickness is false [Z ~> m] + integer :: inconsistent ! The total number of cells with in consistent topography and layer thicknesses. logical :: correct_thickness character(len=40) :: mdl = "initialize_thickness_from_file" ! This subroutine's name. character(len=200) :: filename, thickness_file, inputdir, mesg ! Strings for file/path @@ -738,6 +740,11 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) endif + call get_param(param_file, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & + "A tolerance for detecting inconsist topography and input layer "//& + "ticknesses when ADJUST_THICKNESS is false.", & + units="m", default=1.0, scale=US%m_to_Z, & + do_not_log=(just_read.or.correct_thickness)) call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & "The variable name for initial conditions for interface heights "//& "relative to mean sea level, positive upward unless otherwise rescaled.", & @@ -762,8 +769,9 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f endif enddo ; enddo ; enddo + inconsistent = 0 do j=js,je ; do i=is,ie - if (abs(eta(i,j,nz+1) + depth_tot(i,j)) > 1.0*US%m_to_Z) & + if (abs(eta(i,j,nz+1) + depth_tot(i,j)) > tol_dz_bot) & inconsistent = inconsistent + 1 enddo ; enddo call sum_across_PEs(inconsistent) @@ -1188,6 +1196,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) 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. real :: min_thickness ! The minimum layer thickness, recast into Z units [Z ~> m]. + 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. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. @@ -1217,6 +1226,11 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) 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) + 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.", & + units="m", default=1.0e-5, scale=US%m_to_Z, do_not_log=just_read) + call get_param(PF, mdl, "TRIMMING_USES_REMAPPING", use_remapping, & 'When trimming the column, also remap T and S.', & default=.false., do_not_log=just_read) @@ -1270,7 +1284,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) call cut_off_column_top(GV%ke, tv, GV, US, GV%g_Earth, G%bathyT(i,j)+G%Z_ref, & min_thickness, tv%T(i,j,:), T_t(i,j,:), T_b(i,j,:), & tv%S(i,j,:), S_t(i,j,:), S_b(i,j,:), p_surf(i,j), h(i,j,:), remap_CS, & - z_tol=1.0e-5*US%m_to_Z, remap_answer_date=remap_answer_date) + z_tol=z_tolerance, remap_answer_date=remap_answer_date) enddo ; enddo end subroutine trim_for_ice @@ -2476,7 +2490,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just integer :: i, j, k, ks integer :: nkml ! The number of layers in the mixed layer. - integer :: kd, inconsistent + integer :: inconsistent ! The total number of cells with in consistent topography and layer thicknesses. + integer :: kd ! The number of levels in the input data integer :: nkd ! number of levels to use for regridding input arrays real :: eps_Z ! A negligibly thin layer thickness [Z ~> m]. real :: eps_rho ! A negligibly small density difference [R ~> kg m-3]. @@ -2489,9 +2504,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ! interpolation from an input dataset [C ~> degC] real :: tol_sal ! The tolerance for changes in salinity during the horizontal ! interpolation from an input dataset [S ~> ppt] - logical :: correct_thickness + logical :: correct_thickness ! If true, correct the column thicknesses to match the topography real :: h_tolerance ! A parameter that controls the tolerance when adjusting the ! thickness to fit the bathymetry [Z ~> m]. + real :: tol_dz_bot ! A tolerance for detecting inconsistent bottom depths when + ! correct_thickness is false [Z ~> m] character(len=40) :: potemp_var, salin_var integer, parameter :: niter=10 ! number of iterations for t/s adjustment to layer density @@ -2662,12 +2679,16 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "If true, all mass below the bottom removed if the "//& "topography is shallower than the thickness input file "//& "would indicate.", default=.false., do_not_log=just_read) - if (correct_thickness) then - call get_param(PF, mdl, "THICKNESS_TOLERANCE", h_tolerance, & + call get_param(PF, mdl, "THICKNESS_TOLERANCE", h_tolerance, & "A parameter that controls the tolerance when adjusting the "//& "thickness to fit the bathymetry. Used when ADJUST_THICKNESS=True.", & - units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) - endif + units="m", default=0.1, scale=US%m_to_Z, & + do_not_log=(just_read.or..not.correct_thickness)) + call get_param(PF, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & + "A tolerance for detecting inconsist topography and input layer "//& + "ticknesses when ADJUST_THICKNESS is false.", & + units="m", default=1.0, scale=US%m_to_Z, & + do_not_log=(just_read.or.correct_thickness)) call get_param(PF, mdl, "FIT_TO_TARGET_DENSITY_IC", adjust_temperature, & "If true, all the interior layers are adjusted to "//& @@ -2686,27 +2707,41 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "The mixed layer depth in the initial conditions when Z_INIT_SEPARATE_MIXED_LAYER "//& "is set to true.", units="m", default=US%Z_to_m*Hmix_default, scale=US%m_to_Z, & do_not_log=(just_read .or. .not.separate_mixed_layer)) + ! Reusing MINIMUM_DEPTH for the default mixed layer depth may be a strange choice, but + ! it reproduces previous answers. + call get_param(PF, mdl, "DENSITY_INTERP_TOLERANCE", eps_rho, & + "A small density tolerance used when finding depths in a density profile.", & + units="kg m-3", default=1.0e-10, scale=US%kg_m3_to_R, & + do_not_log=useALEremapping.or.just_read) call get_param(PF, mdl, "LAYER_Z_INIT_IC_EXTRAP_BUG", density_extrap_bug, & "If true use an expression with a vertical indexing bug for extrapolating the "//& "densities at the bottom of unstable profiles from data when finding the "//& "initial interface locations in layered mode from a dataset of T and S.", & default=.false., do_not_log=just_read) - ! Reusing MINIMUM_DEPTH for the default mixed layer depth may be a strange choice, but - ! it reproduces previous answers. endif + call get_param(PF, mdl, "LAND_FILL_TEMP", temp_land_fill, & + "A value to use to fill in ocean temperatures on land points.", & + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "LAND_FILL_SALIN", salt_land_fill, & + "A value to use to fill in ocean salinities on land points.", & + units="1e-3", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "HORIZ_INTERP_TOL_TEMP", tol_temp, & + "The tolerance in temperature changes between iterations when interpolating "//& + "ifrom an nput dataset using horiz_interp_and_extrap_tracer. This routine "//& + "converges slowly, so an overly small tolerance can get expensive.", & + units="degC", default=1.0e-3, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "HORIZ_INTERP_TOL_SALIN", tol_sal, & + "The tolerance in salinity changes between iterations when interpolating "//& + "ifrom an nput dataset using horiz_interp_and_extrap_tracer. This routine "//& + "converges slowly, so an overly small tolerance can get expensive.", & + units="1e-3", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) + if (just_read) then call cpu_clock_end(id_clock_routine) return ! All run-time parameters have been read, so return. endif - !### These hard-coded constants should be made into runtime parameters - temp_land_fill = 0.0*US%degC_to_C - salt_land_fill = 35.0*US%ppt_to_S - tol_temp = 1.0e-3*US%degC_to_C - tol_sal = 1.0e-3*US%ppt_to_S - eps_z = GV%Angstrom_Z - eps_rho = 1.0e-10*US%kg_m3_to_R ! Read input grid coordinates for temperature and salinity field ! in z-coordinate dataset. The file is REQUIRED to contain the @@ -2877,9 +2912,9 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just h(i,j,k) = GV%Z_to_H * (zi(i,j,K) - zi(i,j,K+1)) endif enddo ; enddo ; enddo - inconsistent=0 + inconsistent = 0 do j=js,je ; do i=is,ie - if (abs(zi(i,j,nz+1) - Z_bottom(i,j)) > 1.0*US%m_to_Z) & + if (abs(zi(i,j,nz+1) - Z_bottom(i,j)) > tol_dz_bot) & inconsistent = inconsistent + 1 enddo ; enddo call sum_across_PEs(inconsistent) From 39f45f05400c6280cae5987317715cd3dcd4d965 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 19 Dec 2022 18:10:30 -0500 Subject: [PATCH 120/629] Document the units of variables in MOM_ALE_sponge Added to the comments describing a number of the internal variables in the MOM_ALE_sponge code, although given that much of this works on variables with arbitrary units, many of the units descriptions have to be simply [various]. All answers and output are bitwise identical. --- .../vertical/MOM_ALE_sponge.F90 | 78 +++++++++++-------- 1 file changed, 44 insertions(+), 34 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index a121b05d30..740c42f16a 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -69,8 +69,8 @@ module MOM_ALE_sponge 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. - real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid. + real, dimension(:,:,:), pointer :: p => NULL() !< pointer to the data [various] + real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid [H ~> m or kg m-2] end type p3d !> A structure for creating arrays of pointers to 2D arrays with extra gridding information @@ -79,8 +79,8 @@ module MOM_ALE_sponge 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 - real, dimension(:,:), pointer :: p => NULL() !< pointer the data. - real, dimension(:,:), pointer :: h => NULL() !< pointer the data grid. + real, dimension(:,:), pointer :: p => NULL() !< pointer to the data [various] + real, dimension(:,:), pointer :: h => NULL() !< pointer the data grid [H ~> m or kg m-2] character(len=:), allocatable :: name !< The name of the input field character(len=:), allocatable :: long_name !< The long name of the input field character(len=:), allocatable :: unit !< The unit of the input field @@ -687,9 +687,9 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & type(ALE_sponge_CS), pointer :: CS !< ALE sponge control structure (in/out). real, dimension(SZI_(G),SZJ_(G),CS%nz_data), & intent(in) :: sp_val !< Field to be used in the sponge, it can have an - !! arbitrary number of layers. + !! arbitrary number of layers [various] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: f_ptr !< Pointer to the field to be damped + target, intent(in) :: f_ptr !< Pointer to the field to be damped [various] character(len=*), intent(in) :: sp_name !< The name of the tracer field character(len=*), optional, & intent(in) :: sp_long_name !< The long name of the tracer field @@ -698,9 +698,10 @@ subroutine set_up_ALE_sponge_field_fixed(sp_val, G, GV, f_ptr, CS, & intent(in) :: sp_unit !< The unit of the tracer field !! if not given, use the none real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any - !! contributions due to dimensional rescaling. The default is 1. + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. - real :: scale_fac ! A factor by which to scale sp_val before storing it. + real :: scale_fac ! A factor by which to scale sp_val before storing it [various ~> 1] integer :: k, col character(len=256) :: mesg ! String for error messages character(len=256) :: long_name ! The long name of the tracer field @@ -749,7 +750,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, 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)), & - target, intent(in) :: f_ptr !< Pointer to the field to be damped (in). + target, intent(in) :: f_ptr !< Pointer to the field to be damped (in) [various]. type(ALE_sponge_CS), pointer :: CS !< Sponge control structure (in/out). character(len=*), intent(in) :: sp_name !< The name of the tracer field character(len=*), optional, & @@ -759,7 +760,8 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, intent(in) :: sp_unit !< The unit of the tracer field !! 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. The default is 1. + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. ! Local variables integer :: isd, ied, jsd, jed @@ -824,9 +826,10 @@ subroutine set_up_ALE_sponge_vel_field_fixed(u_val, v_val, G, GV, u_ptr, v_ptr, real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any - !! contributions due to dimensional rescaling. The default is 1. + !! contributions due to dimensional rescaling [various ~> 1]. + !! The default is 1. - real :: scale_fac + real :: scale_fac ! A dimensional rescaling factor [various ~> 1] integer :: k, col if (.not.associated(CS)) return @@ -867,8 +870,9 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename real, target, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u_ptr !< u-field to be damped [L T-1 ~> m s-1] real, target, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v_ptr !< v-field to be damped [L T-1 ~> m s-1] real, optional, intent(in) :: scale !< A factor by which to rescale the input data, including any - !! contributions due to dimensional rescaling. For varying - !! velocities the default is the same using US%m_s_to_L_T. + !! contributions due to dimensional rescaling, often in + !! [L s T-1 m-1 ~> 1]. For varying velocities the + !! default is the same as using US%m_s_to_L_T. ! Local variables logical :: override @@ -931,16 +935,19 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. - real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid - real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid + real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid [various] + real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid [various] real, dimension(SZK_(GV)) :: h_col ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] - real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields - real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts - real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts - real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts - real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency diagnostics, + real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields [various] + real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts [nondim] + real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts [nondim] + real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts [nondim] + real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency + !! diagnostics [various] real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics + !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics + !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. ! Local variables for ALE remapping real, dimension(:), allocatable :: tmpT1d @@ -948,12 +955,12 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, allocatable, dimension(:), target :: z_in ! The depths (positive downward) in the input file [Z ~> m] real, allocatable, dimension(:), target :: z_edges_in ! The depths (positive downward) of the ! edges in the input file [Z ~> m] - real :: missing_value + real :: missing_value ! The missing value in the input data field [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. - real :: sp_val_u ! Interpolation of sp_val to u-points - real :: sp_val_v ! Interpolation of sp_val to v-points + real :: sp_val_u ! Interpolation of sp_val to u-points, often a velocity in [L T-1 ~> m s-1] + real :: sp_val_v ! Interpolation of sp_val to v-points, often a velocity in [L T-1 ~> m s-1] integer :: nPoints is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -982,7 +989,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) i = CS%col_i(c) ; j = CS%col_j(c) CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0; tmpT1d(:) = -99.9 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; hsrc(:) = 0.0 ; tmpT1d(:) = -99.9 do k=1,nz_data if (mask_z(CS%col_i(c),CS%col_j(c),k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(CS%col_i(c),CS%col_j(c)) ) @@ -1012,7 +1019,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) enddo endif - tmp_val1(:)=0.0;h_col(:)=0.0 + tmp_val1(:) = 0.0 ; h_col(:) = 0.0 do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data allocate(tmp_val2(CS%Ref_val(m)%nz_data)) @@ -1086,7 +1093,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val_u%p(1:nz_data,c) = 0.0 endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; hsrc(:) = 0.0 do k=1,nz_data if (mask_u(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) @@ -1134,7 +1141,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val_v%p(1:nz_data,c) = 0.0 endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0; hsrc(:) = 0.0 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; hsrc(:) = 0.0 do k=1,nz_data if (mask_v(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) @@ -1241,10 +1248,13 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) ! 3. Call initialize_ALE_sponge using new grid and rotated Iresttime(:,:) ! All the index adjustment should follow from the Iresttime rotation - real, dimension(:,:), allocatable :: Iresttime_in, Iresttime - real, dimension(:,:,:), allocatable :: data_h_in, data_h - real, dimension(:,:,:), allocatable :: sp_val_in, sp_val - real, dimension(:,:,:), pointer :: sp_ptr => NULL() + real, dimension(:,:), allocatable :: Iresttime_in ! Restoring rate on the input sponges [T-1 ~> s-1] + real, dimension(:,:), allocatable :: Iresttime ! Restoring rate on the output sponges [T-1 ~> s-1] + real, dimension(:,:,:), allocatable :: data_h_in ! Grid for the input sponges [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: data_h ! Grid for the output sponges [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: sp_val_in ! Target data for the input sponges [various] + real, dimension(:,:,:), allocatable :: sp_val ! Target data for the output sponges [various] + real, dimension(:,:,:), pointer :: sp_ptr => NULL() ! Target data for the input sponges [various] integer :: c, c_i, c_j integer :: k, nz_data integer :: n @@ -1365,11 +1375,11 @@ end subroutine rotate_ALE_sponge subroutine update_ALE_sponge_field(sponge, p_old, G, GV, p_new) type(ALE_sponge_CS), intent(inout) :: sponge !< ALE sponge control struct real, dimension(:,:,:), & - target, intent(in) :: p_old !< The previous array of target values + target, intent(in) :: p_old !< The previous array of target values [various] type(ocean_grid_type), intent(in) :: G !< The updated ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: p_new !< The new array of target values + target, intent(in) :: p_new !< The new array of target values [various] integer :: n From 19e268dd8ad5e8b04c6c207f332e86628100b74c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 20 Dec 2022 15:32:55 -0500 Subject: [PATCH 121/629] +Add 11 runtime params for determine_temperature Added 11 new runtime parameters (DETERMINE_TEMP_ADJUST_T_AND_S, DETERMINE_TEMP_T_MIN, DETERMINE_TEMP_T_MAX, DETERMINE_TEMP_S_MIN, DETERMINE_TEMP_S_MAX, DETERMINE_TEMP_T_TOLERANCE, DETERMINE_TEMP_S_TOLERANCE, DETERMINE_TEMP_RHO_TOLERANCE, DETERMINE_TEMP_DT_DS_WEIGHT, DETERMINE_TEMP_T_ADJ_RANGE, and DETERMINE_TEMP_S_ADJ_RANGE) to replace hard coded dimensional parameters used in the routine determine_temperature. This change also requires that a param_file_type argument and the logical argument just_read are passed to determine temperature. By default, all answers are bitwise identical but there are up to 10 new entries in the MOM_parameter_doc files for some layer-mode configurations with INIT_LAYERS_FROM_Z_FILE and FIT_TO_TARGET_DENSITY_IC set to true. --- .../MOM_state_initialization.F90 | 8 +- src/tracer/MOM_tracer_Z_init.F90 | 84 ++++++++++++++----- 2 files changed, 70 insertions(+), 22 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 5af360d775..14459f7d0a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2737,6 +2737,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just units="1e-3", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) then + 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.) call cpu_clock_end(id_clock_routine) return ! All run-time parameters have been read, so return. endif @@ -2957,8 +2961,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just if (adjust_temperature) then ! 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), tv%P_Ref, niter, & - h, ks, G, GV, US, eos) + call determine_temperature(tv%T, tv%S, GV%Rlay(1:nz), eos, tv%P_Ref, niter, & + h, ks, G, GV, US, PF, just_read) endif endif ! useALEremapping diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index 85a858b8df..d887f5f3be 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -4,7 +4,7 @@ module MOM_tracer_Z_init ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -! use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, get_var_sizes, read_attribute, read_variable use MOM_io, only : open_file_to_read, close_file_to_read @@ -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, p_ref, niter, h, k_start, G, GV, US, & - EOS, h_massless) +subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, h, k_start, G, GV, US, & + PF, just_read, h_massless) 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,6 +565,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, h, k_start, G, 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 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) @@ -572,7 +573,10 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, h, k_start, G, 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(EOS_type), intent(in) :: EOS !< seawater equation of state control structure + 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] @@ -600,29 +604,69 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, h, k_start, G, ! when old_fit is true [C ~> degC] real :: max_s_adj ! The largest permitted salinity changes with each iteration ! when old_fit is true [S ~> ppt] - logical :: adjust_salt, old_fit + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=40) :: mdl = "determine_temperature" ! This subroutine's name. + logical :: adjust_salt, fit_together integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - ! These hard coded parameters need to be set properly. - S_min = 0.5*US%ppt_to_S ; S_max = 65.0*US%ppt_to_S - T_max = 31.0*US%degC_to_C ; T_min = -2.0*US%degC_to_C - max_t_adj = 1.0*US%degC_to_C - max_s_adj = 0.5*US%ppt_to_S - tol_T = 1.0e-4*US%degC_to_C - tol_S = 1.0e-4*US%ppt_to_S - tol_rho = 1.0e-4*US%kg_m3_to_R - old_fit = .true. ! reproduces siena behavior + ! ### The algorithms of determine_temperature subroutine needs to be reexamined. - dT_dS_gauge = 10.0*US%degC_to_C*US%S_to_ppt ! 10 degC is weighted equivalently to 1 ppt. - ! ### The whole determine_temperature subroutine needs to be reexamined, both the algorithms - ! and the extensive use of hard-coded dimensional parameters. + call log_version(PF, mdl, version, "") - ! We will switch to the newer method which simultaneously adjusts + ! We should switch the default to the newer method which simultaneously adjusts ! temp and salt based on the ratio of the thermal and haline coefficients, once it is tested. + call get_param(PF, mdl, "DETERMINE_TEMP_ADJUST_T_AND_S", fit_together, & + "If true, simltaneously adjust the estimates of the temperature and salinity "//& + "based on the ratio of the thermal and haline coefficients. Otherwise try to "//& + "match the density by only adjusting temperatures within a maximum range before "//& + "revising estimates of the salinity.", default=.false., do_not_log=just_read) + ! These hard coded parameters need to be set properly. + call get_param(PF, mdl, "DETERMINE_TEMP_T_MIN", T_min, & + "The minimum temperature that can be found by determine_temperature.", & + units="degC", default=-2.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_T_MAX", T_max, & + "The maximum temperature that can be found by determine_temperature.", & + units="degC", default=31.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_MIN", S_min, & + "The minimum salinity that can be found by determine_temperature.", & + units="1e-3", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_MAX", S_max, & + "The maximum salinity that can be found by determine_temperature.", & + units="1e-3", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & + "The convergence tolerance for temperature in determine_temperature.", & + units="degC", default=1.0e-4, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & + "The convergence tolerance for temperature in determine_temperature.", & + units="1e-3", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & + "The convergence tolerance for density in determine_temperature.", & + units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) + if (fit_together) then + ! By default 10 degC is weighted equivalently to 1 ppt when minimizing changes. + call get_param(PF, mdl, "DETERMINE_TEMP_DT_DS_WEIGHT", dT_dS_gauge, & + "When extrapolating T & S to match the layer target densities, this "//& + "factor (in deg C / PSU) is combined with the derivatives of density "//& + "with T & S to determine what direction is orthogonal to density contours. "//& + "It could be based on a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & + units="degC PSU-1", default=10.0, scale=US%degC_to_C*US%S_to_ppt) + else + call get_param(PF, mdl, "DETERMINE_TEMP_T_ADJ_RANGE", max_t_adj, & + "The maximum amount by which the initial layer temperatures can be "//& + "modified in determine_temperature.", & + units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(PF, mdl, "DETERMINE_TEMP_S_ADJ_RANGE", max_S_adj, & + "The maximum amount by which the initial layer salinities can be "//& + "modified in determine_temperature.", & + units="1e-3", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + endif + + if (just_read) return ! All run-time parameters have been read, so return. press(:) = p_ref EOSdom(:) = EOS_domain(G%HI) @@ -643,7 +687,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, h, k_start, G, 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) then - if (old_fit) 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) T(i,k) = max(min(T(i,k)+dT(i,k), T_max), T_min) else @@ -662,7 +706,7 @@ subroutine determine_temperature(temp, salt, R_tgt, p_ref, niter, h, k_start, G, endif enddo iter_loop - if (adjust_salt .and. old_fit) then ; do itt = 1,niter + if (adjust_salt .and. .not.fit_together) then ; do itt = 1,niter do k=1,nz call calculate_density(T(:,k), S(:,k), press, rho(:,k), EOS, EOSdom ) call calculate_density_derivs(T(:,k), S(:,k), press, drho_dT(:,k), drho_dS(:,k), & From e1982964b0dd068c363a1ff4f1743f2ca5440152 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 20 Dec 2022 15:36:17 -0500 Subject: [PATCH 122/629] +Add 2 runtime params for ice shelf temperatures Added the new runtime parameters INFLOW_SHELF_TEMPERATURE and MISSING_SHELF_TEMPERATURE to the ice_shelf_dynamics module to replace hard coded ice shelf temperatures. White space was also added around "=" in a number of places in this same module to align with the MOM6 style guide. By default, all answers are bitwise identical, but there are new entries in some MOM_parameter_doc files for cases that use the ice shelf code with DYNAMIC_SHELF_MASS. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 99 ++++++++++++++---------- 1 file changed, 56 insertions(+), 43 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 2ed64359cb..552216f41d 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -147,7 +147,7 @@ module MOM_ice_shelf_dynamics logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. - + real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [degC ~> C] real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that !! determines when to stop the conjugate gradient iterations [nondim]. real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, @@ -234,6 +234,8 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) type(ice_shelf_dyn_CS), pointer :: CS !< A pointer to the ice shelf dynamics control structure type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + ! Local variables + real :: T_shelf_missing ! An ice shelf temperature to use where there is no ice shelf [degC ~> C] logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -260,9 +262,12 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) endif if (active_shelf_dynamics) then + call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", T_shelf_missing, & + "An ice shelf temperature to use where there is no ice shelf.",& + units="degC", default=-10.0, scale=US%degC_to_C, do_not_log=.true.) allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%t_shelf(isd:ied,jsd:jed), source=-10.0*US%degC_to_C ) ! [C ~> degC] + allocate( CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing ) ! [C ~> degC] allocate( CS%ice_visc(isd:ied,jsd:jed), source=0.0 ) allocate( CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25 ) ! [Pa-3 s-1] allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) ! [R L2 T-2 ~> Pa] @@ -329,6 +334,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! 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". # include "version_variable.h" character(len=200) :: IC_file,filename,inputdir @@ -438,7 +445,13 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "if CONSTANT a constant value (for debugging).", & default="MODEL") + call get_param(param_file, mdl, "INFLOW_SHELF_TEMPERATURE", T_shelf_bdry, & + "A default ice shelf temperature to use for ice flowing in through "//& + "open boundaries.", units="degC", default=-15.0, scale=US%degC_to_C) endif + call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", CS%T_shelf_missing, & + "An ice shelf temperature to use where there is no ice shelf.",& + units="degC", default=-10.0, scale=US%degC_to_C) call get_param(param_file, mdl, "MIN_THICKNESS_SIMPLE_CALVE", CS%min_thickness_simple_calve, & "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) @@ -447,7 +460,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! previously allocated for registration for restarts. if (active_shelf_dynamics) then - allocate( CS%t_bdry_val(isd:ied,jsd:jed), source=-15.0*US%degC_to_C) ! [C ~> degC] + allocate( CS%t_bdry_val(isd:ied,jsd:jed), source=T_shelf_bdry) ! [C ~> degC] allocate( CS%thickness_bdry_val(isd:ied,jsd:jed), source=0.0) allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) @@ -1415,7 +1428,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after do j=jsh,jeh ; do I=ish-1,ieh if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) - elseif ((hmask(i,j)==1) .or. (hmask(i+1,j) == 1)) then + elseif ((hmask(i,j) == 1) .or. (hmask(i+1,j) == 1)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1494,7 +1507,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after do J=jsh-1,jeh ; do i=ish,ieh if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) - elseif ((hmask(i,j)==1) .or. (hmask(i,j+1) == 1)) then + elseif ((hmask(i,j) == 1) .or. (hmask(i,j+1) == 1)) then v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1854,7 +1867,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) else - S(i,j)=ISS%h_shelf(i,j)-CS%bed_elev(i,j) + S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) endif enddo enddo @@ -2219,12 +2232,12 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, bathyT(i,j), dens_ratio, Usub, Vsub) - if (umask(I-1,J-1)==1) uret(I-1,J-1) = uret(I-1,J-1) + Usub(1,1) * basal_trac(i,j) + if (umask(I-1,J-1) == 1) uret(I-1,J-1) = uret(I-1,J-1) + Usub(1,1) * basal_trac(i,j) if (umask(I-1,J) == 1) uret(I-1,J) = uret(I-1,J) + Usub(1,2) * basal_trac(i,j) if (umask(I,J-1) == 1) uret(I,J-1) = uret(I,J-1) + Usub(2,1) * basal_trac(i,j) if (umask(I,J) == 1) uret(I,J) = uret(I,J) + Usub(2,2) * basal_trac(i,j) - if (vmask(I-1,J-1)==1) vret(I-1,J-1) = vret(I-1,J-1) + Vsub(1,1) * basal_trac(i,j) + if (vmask(I-1,J-1) == 1) vret(I-1,J-1) = vret(I-1,J-1) + Vsub(1,1) * basal_trac(i,j) if (vmask(I-1,J) == 1) vret(I-1,J) = vret(I-1,J) + Vsub(1,2) * basal_trac(i,j) if (vmask(I,J-1) == 1) vret(I,J-1) = vret(I,J-1) + Vsub(2,1) * basal_trac(i,j) if (vmask(I,J) == 1) vret(I,J) = vret(I,J) + Vsub(2,2) * basal_trac(i,j) @@ -2550,12 +2563,12 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, CS%bed_elev(i,j), & dens_ratio, Usubcontr, Vsubcontr) - if (CS%umask(I-1,J-1)==1) u_bdry_contr(I-1,J-1) = u_bdry_contr(I-1,J-1) + Usubcontr(1,1) * basal_trac(i,j) + if (CS%umask(I-1,J-1) == 1) u_bdry_contr(I-1,J-1) = u_bdry_contr(I-1,J-1) + Usubcontr(1,1) * basal_trac(i,j) if (CS%umask(I-1,J) == 1) u_bdry_contr(I-1,J) = u_bdry_contr(I-1,J) + Usubcontr(1,2) * basal_trac(i,j) if (CS%umask(I,J-1) == 1) u_bdry_contr(I,J-1) = u_bdry_contr(I,J-1) + Usubcontr(2,1) * basal_trac(i,j) if (CS%umask(I,J) == 1) u_bdry_contr(I,J) = u_bdry_contr(I,J) + Usubcontr(2,2) * basal_trac(i,j) - if (CS%vmask(I-1,J-1)==1) v_bdry_contr(I-1,J-1) = v_bdry_contr(I-1,J-1) + Vsubcontr(1,1) * basal_trac(i,j) + if (CS%vmask(I-1,J-1) == 1) v_bdry_contr(I-1,J-1) = v_bdry_contr(I-1,J-1) + Vsubcontr(1,1) * basal_trac(i,j) if (CS%vmask(I-1,J) == 1) v_bdry_contr(I-1,J) = v_bdry_contr(I-1,J) + Vsubcontr(1,2) * basal_trac(i,j) if (CS%vmask(I,J-1) == 1) v_bdry_contr(I,J-1) = v_bdry_contr(I,J-1) + Vsubcontr(2,1) * basal_trac(i,j) if (CS%vmask(I,J) == 1) v_bdry_contr(I,J) = v_bdry_contr(I,J) + Vsubcontr(2,2) * basal_trac(i,j) @@ -2610,7 +2623,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) enddo ; enddo n_g = CS%n_glen; eps_min = CS%eps_glen_min - CS%ice_visc(:,:)=1e22 + CS%ice_visc(:,:) = 1.0e22 ! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) do j=jsc,jec ; do i=isc,iec @@ -2639,13 +2652,13 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) enddo ; enddo - if (trim(CS%ice_viscosity_compute)=="CONSTANT") then + if (trim(CS%ice_viscosity_compute) == "CONSTANT") then CS%ice_visc(i,j) = 1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - elseif (trim(CS%ice_viscosity_compute)=="MODEL") then + elseif (trim(CS%ice_viscosity_compute) == "MODEL") then CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) - elseif (trim(CS%ice_viscosity_compute)=="OBS") then + elseif (trim(CS%ice_viscosity_compute) == "OBS") then if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) = CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file endif @@ -3008,23 +3021,23 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face select case (int(CS%u_face_mask_bdry(I-1+k,j))) case (3) - vmask(I-1+k,J-1)=3. - u_face_mask(I-1+k,j)=3. - umask(I-1+k,J)=3. - vmask(I-1+k,J)=3. - vmask(I-1+k,J)=3. + vmask(I-1+k,J-1) = 3. + u_face_mask(I-1+k,j) = 3. + umask(I-1+k,J) = 3. + vmask(I-1+k,J) = 3. + vmask(I-1+k,J) = 3. case (2) - u_face_mask(I-1+k,j)=2. + u_face_mask(I-1+k,j) = 2. case (4) - umask(I-1+k,J-1:J)=0. - vmask(I-1+k,J-1:J)=0. - u_face_mask(I-1+k,j)=4. + umask(I-1+k,J-1:J) = 0. + vmask(I-1+k,J-1:J) = 0. + u_face_mask(I-1+k,j) = 4. case (0) - umask(I-1+k,J-1:J)=0. - vmask(I-1+k,J-1:J)=0. - u_face_mask(I-1+k,j)=0. + umask(I-1+k,J-1:J) = 0. + vmask(I-1+k,J-1:J) = 0. + u_face_mask(I-1+k,j) = 0. case (1) ! stress free x-boundary - umask(I-1+k,J-1:J)=0. + umask(I-1+k,J-1:J) = 0. case default end select enddo @@ -3033,23 +3046,23 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face select case (int(CS%v_face_mask_bdry(i,J-1+k))) case (3) - vmask(I-1,J-1+k)=3. - umask(I-1,J-1+k)=3. - vmask(I,J-1+k)=3. - umask(I,J-1+k)=3. - v_face_mask(i,J-1+k)=3. + vmask(I-1,J-1+k) = 3. + umask(I-1,J-1+k) = 3. + vmask(I,J-1+k) = 3. + umask(I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 3. case (2) - v_face_mask(i,J-1+k)=2. + v_face_mask(i,J-1+k) = 2. case (4) - umask(I-1:I,J-1+k)=0. - vmask(I-1:I,J-1+k)=0. - v_face_mask(i,J-1+k)=4. + umask(I-1:I,J-1+k) = 0. + vmask(I-1:I,J-1+k) = 0. + v_face_mask(i,J-1+k) = 4. case (0) - umask(I-1:I,J-1+k)=0. - vmask(I-1:I,J-1+k)=0. - v_face_mask(i,J-1+k)=0. + umask(I-1:I,J-1+k) = 0. + vmask(I-1:I,J-1+k) = 0. + v_face_mask(i,J-1+k) = 0. case (1) ! stress free y-boundary - vmask(I-1:I,J-1+k)=0. + vmask(I-1:I,J-1+k) = 0. case default end select enddo @@ -3223,7 +3236,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) if (ISS%h_shelf(i,j) > 0.0) then CS%t_shelf(i,j) = th_after_vflux(i,j) / ISS%h_shelf(i,j) else - CS%t_shelf(i,j) = -10.0*US%degC_to_C + CS%t_shelf(i,j) = CS%T_shelf_missing endif ! endif @@ -3234,11 +3247,11 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) else ! the ice is about to melt away in this case set thickness, area, and mask to zero ! NOTE: not mass conservative, should maybe scale salt & heat flux for this cell - CS%t_shelf(i,j) = -10.0*US%degC_to_C + CS%t_shelf(i,j) = CS%T_shelf_missing CS%tmask(i,j) = 0.0 endif elseif (ISS%hmask(i,j) == 0) then - CS%t_shelf(i,j) = -10.0*US%degC_to_C + CS%t_shelf(i,j) = CS%T_shelf_missing elseif ((ISS%hmask(i,j) == 3) .or. (ISS%hmask(i,j) == -2)) then CS%t_shelf(i,j) = CS%t_bdry_val(i,j) endif From f86d762bbb500a9af83e6cb565b4b127b5073bf3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 16 Dec 2022 13:12:59 -0500 Subject: [PATCH 123/629] +Pass ocean_grid_type to call_tracer_register Pass ocean_grid_type arguments to call_tracer_register and call_OBC_register in place of the hor_index_type arguments that had been used previously. Also use these ocean_grid_type arguments in calls to register_shelfwave_OBC, register_RGC_tracer and register_advection_test_tracer. Within these three routines, the contents of the ocean_grid_type are used to specify axis units. The new runtime parameter SHELFWAVE_AMPLITUDE was added to allow for run-time control of the amplitude of the shelfwave test case. By default all answers are bitwise identical, but there are some changes in the units of parameters as documented in the MOM_parameter_doc files and a new entry in these files for the shelfwave test case. --- src/core/MOM.F90 | 6 +- src/core/MOM_boundary_update.F90 | 16 +++-- src/tracer/MOM_tracer_flow_control.F90 | 36 +++++------ src/tracer/RGC_tracer.F90 | 15 ++--- src/tracer/advection_test_tracer.F90 | 89 +++++++++++++------------- src/user/shelfwave_initialization.F90 | 79 ++++++++++------------- 6 files changed, 114 insertions(+), 127 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3cac9583cb..c0ff15e858 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2177,7 +2177,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "at the end of the step.", default=.false.) if (CS%split) then - call get_param(param_file, "MOM", "DTBT", dtbt, default=-0.98) + call get_param(param_file, "MOM", "DTBT", dtbt, units="s or nondim", default=-0.98) default_val = US%T_to_s*CS%dt_therm ; if (dtbt > 0.0) default_val = -1.0 CS%dtbt_reset_period = -1.0 call get_param(param_file, "MOM", "DTBT_RESET_PERIOD", CS%dtbt_reset_period, & @@ -2637,7 +2637,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! This subroutine calls user-specified tracer registration routines. ! Additional calls can be added to MOM_tracer_flow_control.F90. - call call_tracer_register(HI, GV, US, param_file, CS%tracer_flow_CSp, & + call call_tracer_register(G, GV, US, param_file, CS%tracer_flow_CSp, & CS%tracer_Reg, restart_CSp) call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) @@ -2661,7 +2661,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & if (associated(CS%OBC)) then ! Set up remaining information about open boundary conditions that is needed for OBCs. - call call_OBC_register(param_file, CS%update_OBC_CSp, US, CS%OBC, CS%tracer_Reg) + call call_OBC_register(G, GV, US, param_file, CS%update_OBC_CSp, CS%OBC, CS%tracer_Reg) !### Package specific changes to OBCs need to go here? ! This is the equivalent to 2 calls to register_segment_tracer (per segment), which diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 11973f8c02..5a098cdf84 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -59,12 +59,14 @@ module MOM_boundary_update !> The following subroutines and associated definitions provide the !! machinery to register and call the subroutines that initialize !! open boundary conditions. -subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) - type(param_file_type), intent(in) :: param_file !< Parameter file to parse - type(update_OBC_CS), pointer :: CS !< Control structure for OBCs - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. +subroutine call_OBC_register(G, GV, US, param_file, CS, OBC, tr_Reg) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< Parameter file to parse + type(update_OBC_CS), pointer :: CS !< Control structure for OBCs + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + type(tracer_registry_type), pointer :: tr_Reg !< Tracer registry. ! Local variables character(len=200) :: config @@ -124,7 +126,7 @@ subroutine call_OBC_register(param_file, CS, US, OBC, tr_Reg) register_Kelvin_OBC(param_file, CS%Kelvin_OBC_CSp, US, & OBC%OBC_Reg) if (CS%use_shelfwave) CS%use_shelfwave = & - register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, US, & + register_shelfwave_OBC(param_file, CS%shelfwave_OBC_CSp, G, US, & OBC%OBC_Reg) if (CS%use_dyed_channel) CS%use_dyed_channel = & register_dyed_channel_OBC(param_file, CS%dyed_channel_OBC_CSp, US, & diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 46001a2dc3..bf7076d4bb 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -152,8 +152,8 @@ end subroutine call_tracer_flux_init !> This subroutine determines which tracer packages are to be used and does the calls to !! register their tracers to be advected, diffused, and read from restarts. -subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. +subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -163,7 +163,7 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the !! control structure for the tracer !! advection and diffusion module. - type(MOM_restart_CS), intent(inout) :: restart_CS !< A pointer to the restart control + type(MOM_restart_CS), intent(inout) :: restart_CS !< A pointer to the restart control !! structure. ! This include declares and sets the variable "version". @@ -230,49 +230,49 @@ subroutine call_tracer_register(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! tracer package registration call returns a logical false if it cannot be run ! for some reason. This then overrides the run-time selection from above. if (CS%use_USER_tracer_example) CS%use_USER_tracer_example = & - USER_register_tracer_example(HI, GV, param_file, CS%USER_tracer_example_CSp, & + USER_register_tracer_example(G%HI, GV, param_file, CS%USER_tracer_example_CSp, & tr_Reg, restart_CS) if (CS%use_DOME_tracer) CS%use_DOME_tracer = & - register_DOME_tracer(HI, GV, param_file, CS%DOME_tracer_CSp, & + register_DOME_tracer(G%HI, GV, param_file, CS%DOME_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_ISOMIP_tracer) CS%use_ISOMIP_tracer = & - register_ISOMIP_tracer(HI, GV, param_file, CS%ISOMIP_tracer_CSp, & + register_ISOMIP_tracer(G%HI, GV, param_file, CS%ISOMIP_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_RGC_tracer) CS%use_RGC_tracer = & - register_RGC_tracer(HI, GV, param_file, CS%RGC_tracer_CSp, & + register_RGC_tracer(G, GV, param_file, CS%RGC_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_ideal_age) CS%use_ideal_age = & - register_ideal_age_tracer(HI, GV, param_file, CS%ideal_age_tracer_CSp, & + register_ideal_age_tracer(G%HI, GV, param_file, CS%ideal_age_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_regional_dyes) CS%use_regional_dyes = & - register_dye_tracer(HI, GV, US, param_file, CS%dye_tracer_CSp, & + register_dye_tracer(G%HI, GV, US, param_file, CS%dye_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_oil) CS%use_oil = & - register_oil_tracer(HI, GV, US, param_file, CS%oil_tracer_CSp, & + register_oil_tracer(G%HI, GV, US, param_file, CS%oil_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_advection_test_tracer) CS%use_advection_test_tracer = & - register_advection_test_tracer(HI, GV, param_file, CS%advection_test_tracer_CSp, & + register_advection_test_tracer(G, GV, param_file, CS%advection_test_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_OCMIP2_CFC) CS%use_OCMIP2_CFC = & - register_OCMIP2_CFC(HI, GV, param_file, CS%OCMIP2_CFC_CSp, & + register_OCMIP2_CFC(G%HI, GV, param_file, CS%OCMIP2_CFC_CSp, & tr_Reg, restart_CS) if (CS%use_CFC_cap) CS%use_CFC_cap = & - register_CFC_cap(HI, GV, param_file, CS%CFC_cap_CSp, & + register_CFC_cap(G%HI, GV, param_file, CS%CFC_cap_CSp, & tr_Reg, restart_CS) if (CS%use_MOM_generic_tracer) CS%use_MOM_generic_tracer = & - register_MOM_generic_tracer(HI, GV, param_file, CS%MOM_generic_tracer_CSp, & + register_MOM_generic_tracer(G%HI, GV, param_file, CS%MOM_generic_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_pseudo_salt_tracer) CS%use_pseudo_salt_tracer = & - register_pseudo_salt_tracer(HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & + register_pseudo_salt_tracer(G%HI, GV, param_file, CS%pseudo_salt_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_boundary_impulse_tracer) CS%use_boundary_impulse_tracer = & - register_boundary_impulse_tracer(HI, GV, US, param_file, CS%boundary_impulse_tracer_CSp, & + register_boundary_impulse_tracer(G%HI, GV, US, param_file, CS%boundary_impulse_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_dyed_obc_tracer) CS%use_dyed_obc_tracer = & - register_dyed_obc_tracer(HI, GV, param_file, CS%dyed_obc_tracer_CSp, & + register_dyed_obc_tracer(G%HI, GV, param_file, CS%dyed_obc_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_nw2_tracers) CS%use_nw2_tracers = & - register_nw2_tracers(HI, GV, US, param_file, CS%nw2_tracers_CSp, tr_Reg, restart_CS) + register_nw2_tracers(G%HI, GV, US, param_file, CS%nw2_tracers_CSp, tr_Reg, restart_CS) end subroutine call_tracer_register diff --git a/src/tracer/RGC_tracer.F90 b/src/tracer/RGC_tracer.F90 index 7c9b52b66e..474fcb0c23 100644 --- a/src/tracer/RGC_tracer.F90 +++ b/src/tracer/RGC_tracer.F90 @@ -60,10 +60,9 @@ module RGC_tracer contains - !> This subroutine is used to register tracer fields -function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. +function register_RGC_tracer(G, GV, param_file, CS, tr_Reg, restart_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(param_file_type), intent(in) :: param_file ! NULL() ! A pointer to one of the tracers in this module [kg kg-1] logical :: register_RGC_tracer integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then call MOM_error(FATAL, "RGC_register_tracer called with an "// & @@ -108,13 +107,11 @@ function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "CONT_SHELF_LENGTH", CS%CSL, & "The length of the continental shelf (x dir, km).", & - units="km", default=15.0) - ! units=G%x_ax_unit_short, default=15.0) + units=G%x_ax_unit_short, default=15.0) call get_param(param_file, mdl, "LENSPONGE", CS%lensponge, & "The length of the sponge layer (km).", & - units="km", default=10.0) - ! units=G%x_ax_unit_short, default=10.0) + units=G%x_ax_unit_short, default=10.0) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) if (CS%mask_tracers) then @@ -130,7 +127,7 @@ function register_RGC_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This is needed to force the compiler not to do a copy in the registration calls. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection & diffusion. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units="kg/s", & restart_CS=restart_CS) diff --git a/src/tracer/advection_test_tracer.F90 b/src/tracer/advection_test_tracer.F90 index 5e43ce5757..d8eb4d57fb 100644 --- a/src/tracer/advection_test_tracer.F90 +++ b/src/tracer/advection_test_tracer.F90 @@ -3,25 +3,25 @@ module advection_test_tracer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : EFP_type -use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux -use MOM_diag_mediator, only : diag_ctrl -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_hor_index, only : hor_index_type -use MOM_io, only : slasher, vardesc, var_desc, query_vardesc -use MOM_open_boundary, only : ocean_OBC_type -use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS -use MOM_spatial_means, only : global_mass_int_EFP -use MOM_sponge, only : set_up_sponge_field, sponge_CS -use MOM_time_manager, only : time_type +use MOM_coms, only : EFP_type +use MOM_coupler_types, only : set_coupler_type_data, atmos_ocn_coupler_flux +use MOM_diag_mediator, only : diag_ctrl +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_io, only : slasher, vardesc, var_desc, query_vardesc +use MOM_open_boundary, only : ocean_OBC_type +use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS +use MOM_spatial_means, only : global_mass_int_EFP +use MOM_sponge, only : set_up_sponge_field, sponge_CS +use MOM_time_manager, only : time_type use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : surface +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -40,16 +40,16 @@ module advection_test_tracer character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine [conc] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [conc] logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. logical :: tracers_may_reinit !< If true, the tracers may be set up via the initialization code if !! they are not found in the restart files. Otherwise it is a fatal error !! if the tracers are not found in the restart files of a restarted run. - real :: x_origin !< Parameters describing the test functions - real :: x_width !< Parameters describing the test functions - real :: y_origin !< Parameters describing the test functions - real :: y_width !< Parameters describing the test functions + real :: x_origin !< Starting x-position of the tracer [m] or [km] or [degrees_E] + real :: x_width !< Initial size in the x-direction of the tracer patch [m] or [km] or [degrees_E] + real :: y_origin !< Starting y-position of the tracer [m] or [km] or [degrees_N] + real :: y_width !< Initial size in the y-direction of the tracer patch [m] or [km] or [degrees_N] integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and !! the surface tracer concentrations are to be provided to the coupler. @@ -64,8 +64,8 @@ module advection_test_tracer contains !> Register tracer fields and subroutines to be used with MOM. -function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure +function register_advection_test_tracer(G, GV, param_file, CS, tr_Reg, restart_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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(advection_test_tracer_CS), pointer :: CS !< The control structure returned by a previous @@ -80,13 +80,13 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "advection_test_tracer" ! This module's name. - character(len=200) :: inputdir + character(len=200) :: inputdir ! The directory where the input file can be found character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to a tracer array [conc] logical :: register_advection_test_tracer integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then call MOM_error(FATAL, "register_advection_test_tracer called with an "// & @@ -98,13 +98,13 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "ADVECTION_TEST_X_ORIGIN", CS%x_origin, & - "The x-coordinate of the center of the test-functions.", units="same as geoLon", default=0.) + "The x-coordinate of the center of the test-functions.", units=G%x_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_ORIGIN", CS%y_origin, & - "The y-coordinate of the center of the test-functions.", units="same as geoLat", default=0.) + "The y-coordinate of the center of the test-functions.", units=G%y_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_X_WIDTH", CS%x_width, & - "The x-width of the test-functions.", units="same as geoLon", default=0.) + "The x-width of the test-functions.", units=G%x_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_Y_WIDTH", CS%y_width, & - "The y-width of the test-functions.", units="same as geoLat", default=0.) + "The y-width of the test-functions.", units=G%y_ax_unit_short, default=0.) call get_param(param_file, mdl, "ADVECTION_TEST_TRACER_IC_FILE", CS%tracer_IC_file, & "The name of a file from which to read the initial "//& "conditions for the tracers, or blank to initialize "//& @@ -143,7 +143,7 @@ function register_advection_test_tracer(HI, GV, param_file, CS, tr_Reg, restart_ ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units=flux_units, & restart_CS=restart_CS, mandatory=.not.CS%tracers_may_reinit) @@ -181,12 +181,13 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS type(sponge_CS), pointer :: sponge_CSp !< Pointer to the control structure for the sponges. ! Local variables - character(len=16) :: name ! A variable's name in a NetCDF file. + character(len=16) :: name ! A variable's name in a NetCDF file. + real :: locx, locy ! x- and y- positions relative to the center of the tracer patch + ! normalized by its size [nondim] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB - real :: locx, locy if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -211,28 +212,28 @@ subroutine initialize_advection_test_tracer(restart, day, G, GV, h,diag, OBC, CS enddo ; enddo k=2 ! Triangle wave do j=js,je ; do i=is,ie - locx=abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width - locy=abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width CS%tr(i,j,k,m) = max(0.0, 1.0-locx)*max(0.0, 1.0-locy) enddo ; enddo k=3 ! Cosine bell do j=js,je ; do i=is,ie - locx=min(1.0, abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width)*(acos(0.0)*2.) - locy=min(1.0, abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width)*(acos(0.0)*2.) + locx = min(1.0, abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width) * (acos(0.0)*2.) + locy = min(1.0, abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width) * (acos(0.0)*2.) CS%tr(i,j,k,m) = (1.0+cos(locx))*(1.0+cos(locy))*0.25 enddo ; enddo k=4 ! Cylinder do j=js,je ; do i=is,ie - locx=abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width - locy=abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + locx = abs(G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = abs(G%geoLatT(i,j)-CS%y_origin)/CS%y_width if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0 enddo ; enddo k=5 ! Cut cylinder do j=js,je ; do i=is,ie - locx=(G%geoLonT(i,j)-CS%x_origin)/CS%x_width - locy=(G%geoLatT(i,j)-CS%y_origin)/CS%y_width + locx = (G%geoLonT(i,j)-CS%x_origin)/CS%x_width + locy = (G%geoLatT(i,j)-CS%y_origin)/CS%y_width if (locx**2+locy**2<=1.0) CS%tr(i,j,k,m) = 1.0 - if (locx>0.0.and.abs(locy)<0.2) CS%tr(i,j,k,m) = 0.0 + if (locx>0.0 .and. abs(locy)<0.2) CS%tr(i,j,k,m) = 0.0 enddo ; enddo call set_initialized(CS%tr(:,:,:,m), name, CS%restart_CSp) diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 7d588c49a0..5d7f1b7e97 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -28,29 +28,30 @@ module shelfwave_initialization !> Control structure for shelfwave open boundaries. type, public :: shelfwave_OBC_CS ; private - real :: Lx = 100.0 !< Long-shore length scale of bathymetry [km] - real :: Ly = 50.0 !< Cross-shore length scale [km] - real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] - real :: jj = 1.0 !< Cross-shore wave mode [nondim] - real :: kk !< Cross-shore wavenumber [km-1] - real :: ll !< Longshore wavenumber [km-1] - real :: alpha !< Exponential decay rate in the y-direction [km-1] - real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] + real :: my_amp !< Amplitude of the open boundary current inflows [L T-1 ~> m s-1] + real :: Lx = 100.0 !< Long-shore length scale of bathymetry [km] or [m] + real :: Ly = 50.0 !< Cross-shore length scale [km] or [m] + real :: f0 = 1.e-4 !< Coriolis parameter [T-1 ~> s-1] + real :: jj = 1.0 !< Cross-shore wave mode [nondim] + real :: kk !< Cross-shore wavenumber [km-1] or [m-1] + real :: ll !< Longshore wavenumber [km-1] or [m-1] + real :: alpha !< Exponential decay rate in the y-direction [km-1] or [m-1] + real :: omega !< Frequency of the shelf wave [T-1 ~> s-1] end type shelfwave_OBC_CS contains !> Add shelfwave to OBC registry. -function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) +function register_shelfwave_OBC(param_file, CS, G, US, OBC_Reg) type(param_file_type), intent(in) :: param_file !< parameter file. type(shelfwave_OBC_CS), pointer :: CS !< shelfwave control structure. + 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(OBC_registry_type), pointer :: OBC_Reg !< Open boundary condition registry. logical :: register_shelfwave_OBC + ! Local variables real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] - real :: len_lat ! Y-direction size of the domain [km] - character(len=32) :: casename = "shelfwave" !< This case's name. PI = 4.0*atan(1.0) @@ -62,30 +63,26 @@ function register_shelfwave_OBC(param_file, CS, US, OBC_Reg) endif allocate(CS) - !### Revise these parameters once the ocean_grid_type is available. - ! Register the tracer for horizontal advection & diffusion. call register_OBC(casename, param_file, OBC_Reg) call get_param(param_file, mdl, "F_0", CS%f0, & default=0.0, units="s-1", scale=US%T_to_s, do_not_log=.true.) - call get_param(param_file, mdl, "LENLAT", len_lat, & - units="km", do_not_log=.true., fail_if_missing=.true.) call get_param(param_file, mdl,"SHELFWAVE_X_WAVELENGTH", CS%Lx, & "Length scale of shelfwave in x-direction.",& - units="km", default=100.) -! units="km", default=100.0, scale=1.0e3*US%m_to_L) - ! units=G%x_ax_unit_short, default=100.) + units=G%x_ax_unit_short, default=100.) call get_param(param_file, mdl, "SHELFWAVE_Y_LENGTH_SCALE", CS%Ly, & "Length scale of exponential dropoff of topography in the y-direction.", & - units="km", default=50.) -! units="km", default=50.0, scale=1.0e3*US%m_to_L) - ! units=G%y_ax_unit_short, default=50.) + units=G%y_ax_unit_short, default=50.) call get_param(param_file, mdl, "SHELFWAVE_Y_MODE", CS%jj, & "Cross-shore wave mode.", & units="nondim", default=1.) + call get_param(param_file, mdl, "SHELFWAVE_AMPLITUDE", CS%my_amp, & + "Amplitude of the open boundary current inflows in the shelfwave configuration.", & + units="m s-1", default=1.0, scale=US%m_s_to_L_T) + CS%alpha = 1. / CS%Ly CS%ll = 2. * PI / CS%Lx - CS%kk = CS%jj * PI / len_lat + CS%kk = CS%jj * PI / G%len_lat CS%omega = 2 * CS%alpha * CS%f0 * CS%ll / & (CS%kk*CS%kk + CS%alpha*CS%alpha + CS%ll*CS%ll) register_shelfwave_OBC = .true. @@ -111,16 +108,16 @@ subroutine shelfwave_initialize_topography( D, G, param_file, max_depth, US ) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: y ! Position relative to the southern boundary [km] or [degrees_N] - real :: rLy ! Exponential decay rate of the topography [km-1] or [degrees_N-1] - real :: Ly ! Exponential decay lengthscale of the topography [km] or [degrees_N] + real :: y ! Position relative to the southern boundary [km] or [m] or [degrees_N] + real :: rLy ! Exponential decay rate of the topography [km-1] or [m-1] or [degrees_N-1] + real :: Ly ! Exponential decay lengthscale of the topography [km] or [m] or [degrees_N] real :: H0 ! The minimum depth of the ocean [Z ~> m] integer :: i, j call get_param(param_file, mdl,"SHELFWAVE_Y_LENGTH_SCALE", Ly, & units=G%y_ax_unit_short, default=50., do_not_log=.true.) call get_param(param_file, mdl,"MINIMUM_DEPTH", H0, & - default=10., units="m", scale=US%m_to_Z, do_not_log=.true.) + units="m", default=10., scale=US%m_to_Z, do_not_log=.true.) rLy = 0. ; if (Ly>0.) rLy = 1. / Ly @@ -145,15 +142,10 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the shelfwave example. - real :: my_amp ! Amplitude of the open boundary current inflows [L T-1 ~> m s-1] real :: time_sec ! The time in the run [T ~> s] real :: cos_wt, sin_wt ! Cosine and sine associated with the propagating x-direction structure [nondim] real :: cos_ky, sin_ky ! Cosine and sine associated with the y-direction structure [nondim] - real :: omega ! Frequency of the shelf wave [T-1 ~> s-1] - real :: alpha ! Exponential decay rate in the y-direction [km-1] - real :: x, y ! Positions relative to the western and southern boundaries [km] - real :: kk ! y-direction wavenumber of the wave [km-1] - real :: ll ! x-direction wavenumber of the wave [km-1] + real :: x, y ! Positions relative to the western and southern boundaries [km] or [m] or [degrees] integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, n integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() @@ -165,11 +157,6 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not.associated(OBC)) return time_sec = US%s_to_T*time_type_to_real(Time) - omega = CS%omega - alpha = CS%alpha - my_amp = 1.0*US%m_s_to_L_T - kk = CS%kk - ll = CS%ll do n = 1, OBC%number_of_segments segment => OBC%segment(n) if (.not. segment%on_pe) cycle @@ -180,15 +167,15 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) do j=jsd,jed ; do I=IsdB,IedB x = G%geoLonCu(I,j) - G%west_lon y = G%geoLatCu(I,j) - G%south_lat - sin_wt = sin(ll*x - omega*time_sec) - cos_wt = cos(ll*x - omega*time_sec) - sin_ky = sin(kk * y) - cos_ky = cos(kk * y) - segment%normal_vel_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * & - (alpha * sin_ky + kk * cos_ky) -! segment%tangential_vel_bt(I,j) = my_amp * ll * exp(- alpha * y) * sin_wt * sin_ky -! segment%vorticity_bt(I,j) = my_amp * exp(- alpha * y) * cos_wt * sin_ky& -! (ll*ll + kk*kk + alpha*alpha) + sin_wt = sin(CS%ll*x - CS%omega*time_sec) + cos_wt = cos(CS%ll*x - CS%omega*time_sec) + sin_ky = sin(CS%kk * y) + cos_ky = cos(CS%kk * y) + segment%normal_vel_bt(I,j) = CS%my_amp * exp(- CS%alpha * y) * cos_wt * & + (CS%alpha * sin_ky + CS%kk * cos_ky) +! segment%tangential_vel_bt(I,j) = CS%my_amp * CS%ll * exp(- CS%alpha * y) * sin_wt * sin_ky +! segment%vorticity_bt(I,j) = CS%my_amp * exp(- CS%alpha * y) * cos_wt * sin_ky& +! (CS%ll**2 + CS%kk**2 + CS%alpha**2) enddo ; enddo enddo From 78da7780e81525a9e36a1467f9b0d3c6bad3441e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 23 Dec 2022 06:37:10 -0500 Subject: [PATCH 124/629] +Add runtime parameters for benchmark_initialization Added the new runtime parameter BENCHMARK_T_LIGHT and reuse the existing parameter S_REF to specify the previously hard-coded dimensional parameters in the benchmark_initialization module. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for the benchmark test case. --- src/user/benchmark_initialization.F90 | 30 ++++++++++++++++++++------- 1 file changed, 23 insertions(+), 7 deletions(-) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 7d1656e191..a9344a6a30 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -101,9 +101,11 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e ! in depth units [Z ~> m]. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface ! positive upward, in depth units [Z ~> m]. - real :: SST ! The initial sea surface temperature [C ~> degC]. - real :: T_int ! The initial temperature of an interface [C ~> degC]. - real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. + real :: SST ! The initial sea surface temperature [C ~> degC]. + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] + real :: T_int ! The initial temperature of an interface [C ~> degC]. + real :: ML_depth ! The specified initial mixed layer depth, in depth units [Z ~> m]. real :: thermocline_scale ! The e-folding scale of the thermocline, in depth units [Z ~> m]. real, dimension(SZK_(GV)) :: & T0, S0, & ! Profiles of temperature [C ~> degC] and salinity [S ~> ppt] @@ -135,6 +137,12 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e call get_param(param_file, mdl, "BENCHMARK_THERMOCLINE_SCALE", thermocline_scale, & "Initial thermocline depth scale in the benchmark test case.", & default=500.0, units="m", scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "BENCHMARK_T_LIGHT", T_light, & + "A first guess at the temperature of the lightest layer in the benchmark test case.", & + units="degC", default=29.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, & + "The uniform salinities used to initialize the benchmark test case.", & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! This subroutine has no run-time parameters. @@ -147,9 +155,9 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e ! This block calculates T0(k) for the purpose of diagnosing where the ! interfaces will be found. do k=1,nz - pres(k) = P_Ref ; S0(k) = 35.0*US%ppt_to_S + pres(k) = P_Ref ; S0(k) = S_ref enddo - T0(k1) = 29.0*US%degC_to_C + T0(k1) = T_light call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) call calculate_density_derivs(T0(k1), S0(k1), pres(k1), drho_dT(k1), drho_dS(k1), eqn_of_state) @@ -232,25 +240,33 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & ! Local variables real :: T0(SZK_(GV)) ! A profile of temperatures [C ~> degC] real :: S0(SZK_(GV)) ! A profile of salinities [S ~> ppt] + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa] real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1] real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3] real :: PI ! 3.1415926... calculated as 4*atan(1) real :: SST ! The initial sea surface temperature [C ~> degC] + character(len=40) :: mdl = "benchmark_init_temperature_salinity" ! This subroutine's name. integer :: i, j, k, k1, is, ie, js, je, nz, itt is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + call get_param(param_file, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "BENCHMARK_T_LIGHT", T_light, & + units="degC", default=29.0, scale=US%degC_to_C, do_not_log=.true.) + if (just_read) return ! All run-time parameters have been read, so return. k1 = GV%nk_rho_varies + 1 do k=1,nz - pres(k) = P_Ref ; S0(k) = 35.0*US%ppt_to_S + pres(k) = P_Ref ; S0(k) = S_ref enddo - T0(k1) = 29.0*US%degC_to_C + T0(k1) = T_light call calculate_density(T0(k1), S0(k1), pres(k1), rho_guess(k1), eqn_of_state) call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, eqn_of_state, (/k1,k1/) ) From 9fd2bd03927befe1a03b9ac1fc7ca16e443143c6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 23 Dec 2022 06:37:28 -0500 Subject: [PATCH 125/629] +Add runtime parameters for DOME2d_initialization Added the new runtime parameters INITIAL_SSS, DOME2D_T_BAY and DOME2D_EAST_SPONGE_S_RANGE to specify the previously hard-coded dimensional parameters in the DOME2d_initialization module. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for the flow_downslope and similar test cases. --- src/user/DOME2d_initialization.F90 | 43 ++++++++++++++++++++---------- 1 file changed, 29 insertions(+), 14 deletions(-) diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 1c2b71334f..1382fe8e34 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -40,9 +40,9 @@ module DOME2d_initialization subroutine DOME2d_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables real :: bay_depth ! Depth of shelf, as fraction of basin depth [nondim] @@ -239,6 +239,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi real :: delta_S ! Change in salinity between layers [S ~> ppt] real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: T_bay ! Temperature in the inflow embayment [C ~> degC] real :: xi0, xi1 ! Fractional vertical positions [nondim] real :: dome2d_width_bay ! Width of shelf, as fraction of domain [nondim] real :: dome2d_width_bottom ! Width of deep ocean basin, as fraction of domain [nondim] @@ -262,9 +264,14 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_RANGE", S_range,' Initial salinity range', & - units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "DOME2D_T_BAY", T_bay, & + "Temperature in the inflow embayment in the DOME2d test case", & + units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -281,7 +288,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi xi0 = 0.0 do k = 1,nz xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth - S(i,j,k) = 34.0*US%ppt_to_S + 0.5 * S_range * (xi0 + xi1) + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo enddo ; enddo @@ -292,12 +299,12 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi xi0 = 0.0 do k = 1,nz xi1 = xi0 + (GV%H_to_Z * h(i,j,k)) / G%max_depth - S(i,j,k) = 34.0*US%ppt_to_S + 0.5 * S_range * (xi0 + xi1) + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - S(i,j,nz) = 34.0*US%ppt_to_S + S_range + S(i,j,nz) = S_surf + S_range endif enddo ; enddo @@ -322,7 +329,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then S(i,j,1:index_bay_z) = S_ref + S_range ! Use for z coordinates - T(i,j,1:index_bay_z) = 1.0*US%degC_to_C ! Use for z coordinates + T(i,j,1:index_bay_z) = T_bay ! Use for z coordinates endif enddo ; enddo ! i and j loops endif ! Z initial conditions @@ -332,8 +339,8 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - S(i,j,1:GV%ke) = S_ref + S_range ! Use for sigma coordinates - T(i,j,1:GV%ke) = 1.0*US%degC_to_C ! Use for sigma coordinates + S(i,j,1:GV%ke) = S_ref + S_range ! Use for sigma coordinates + T(i,j,1:GV%ke) = T_bay ! Use for sigma coordinates endif enddo ; enddo endif @@ -344,7 +351,7 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi do i = G%isc,G%iec ; do j = G%jsc,G%jec x = ( G%geoLonT(i,j) - G%west_lon ) / G%len_lon if ( x <= dome2d_width_bay ) then - T(i,j,GV%ke) = 1.0*US%degC_to_C + T(i,j,GV%ke) = T_bay endif enddo ; enddo endif @@ -373,6 +380,8 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A real :: T_ref ! Reference temperature within the surface layer [C ~> degC] real :: S_range ! Range of salinities in the vertical [S ~> ppt] real :: T_range ! Range of temperatures in the vertical [C ~> degC] + real :: S_range_sponge ! Range of salinities in the vertical in the east sponge [S ~> ppt] + real :: S_surf ! Initial surface salinity [S ~> ppt] real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], ! usually negative because it is positive upward. real :: eta1D(SZK_(GV)+1) ! Interface height relative to the sea surface @@ -428,7 +437,11 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A call get_param(param_file, mdl, "T_REF", T_ref, units="degC", scale=US%degC_to_C, fail_if_missing=.false.) call get_param(param_file, mdl, "S_RANGE", S_range, units="ppt", default=2.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "T_RANGE", T_range, units="degC", default=0.0, scale=US%degC_to_C) - + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_S_RANGE", S_range_sponge, & + "Range of salinities in the eastern sponge region in the DOME2D configuration", & + units="1e-3", default=1.0, scale=US%ppt_to_S) ! Set the sponge damping rate as a function of position Idamp(:,:) = 0.0 @@ -454,7 +467,7 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A if (use_ALE) then - ! Construct a grid (somewhat arbitrarily) to describe the sponge T/S on + ! Construct a grid (somewhat arbitrarily) to describe the sponge T/S on do k=1,nz e0(k) = -G%max_depth * ( real(k-1) / real(nz) ) enddo @@ -480,7 +493,9 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A 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 - S(i,j,k) = 34.0*US%ppt_to_S - 1.0*US%ppt_to_S * (z / (G%max_depth)) + ! 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 From f1aed7784cbacc21eb203d21ec45c2268b638d34 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 23 Dec 2022 06:37:46 -0500 Subject: [PATCH 126/629] +Add runtime parameters for sloshing_initialization Added the new runtime parameters INITIAL_SSS and SLOSHING_T_PERT to specify the previously hard-coded dimensional parameters in the sloshing_initialization module. Also added comments documenting the purpose and units of the internal real variables in sloshing_initialization.F90. There is also a new comment questioning whether the temperature perturbations are being applied correctly, but for now the code reproduces the previous answers. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for the sloshing test cases. --- src/user/sloshing_initialization.F90 | 72 +++++++++++++++------------- 1 file changed, 38 insertions(+), 34 deletions(-) diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index de7869511b..357f247896 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -30,9 +30,9 @@ module sloshing_initialization subroutine sloshing_initialize_topography( D, G, param_file, max_depth ) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables integer :: i, j @@ -60,23 +60,22 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, intent(out) :: h !< The thickness that is being initialized [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 - !! to parse for model parameter values. - logical, intent(in) :: just_read !< If true, this call will - !! only read parameters without changing h. + type(param_file_type), intent(in) :: param_file !< A structure to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables real :: displ(SZK_(GV)+1) ! The interface displacement [Z ~> m]. real :: z_unif(SZK_(GV)+1) ! Fractional uniform interface heights [nondim]. real :: z_inter(SZK_(GV)+1) ! Interface heights [Z ~> m] real :: a0 ! The displacement amplitude [Z ~> m]. - real :: weight_z ! A (misused?) depth-space weighting, in inconsistent units. - real :: x1, y1, x2, y2 ! Dimensonless parameters. - real :: x, t ! Dimensionless depth coordinates? + real :: weight_z ! A depth-space weighting [nondim]. + real :: x1, y1, x2, y2 ! Dimensonless parameters specifying the depth profile [nondim] + real :: x, t ! Dimensionless depth coordinates scales [nondim] logical :: use_IC_bug ! If true, set the initial conditions retaining an old bug. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "sloshing_initialization" !< This module's name. - integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -133,7 +132,7 @@ subroutine sloshing_initialize_thickness ( h, depth_tot, G, GV, US, param_file, x = G%geoLonT(i,j) / G%len_lon if (use_IC_bug) then - displ(k) = a0 * cos(acos(-1.0)*x) + weight_z * US%m_to_Z + displ(k) = a0 * cos(acos(-1.0)*x) + weight_z * US%m_to_Z ! There is a flag to fix this bug. else displ(k) = a0 * cos(acos(-1.0)*x) * weight_z endif @@ -176,29 +175,28 @@ end subroutine sloshing_initialize_thickness !! Note that the linear distribution is set up with respect to the layer !! number, not the physical position). subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, 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 [H ~> m or kg m-2]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure indicating the - !! open file to parse for model - !! parameter values. - logical, intent(in) :: just_read !< If true, this call will - !! only read parameters without changing T & S. + type(param_file_type), intent(in) :: param_file !< A structure to parse + !! for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing T & S. + ! Local variables + real :: delta_T ! Temperature difference between layers [C ~> degC] + real :: S_ref, T_ref ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer + real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical + real :: S_surf ! Initial surface salinity [S ~> ppt] + real :: T_pert ! A perturbed temperature [C ~> degC] + integer :: kdelta ! Half the number of layers with the temperature perturbation + real :: deltah ! Thickness of each layer [Z ~> m] + real :: xi0, xi1 ! Fractional vertical positions [nondim] + character(len=40) :: mdl = "sloshing_initialization" ! This module's name. integer :: i, j, k, is, ie, js, je, nz - real :: delta_T - real :: S_ref, T_ref; ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within - ! surface layer - real :: S_range, T_range; ! Range of [S ~> ppt] and temperatures [C ~> degC] over the - ! vertical - integer :: kdelta - real :: deltah - real :: xi0, xi1 - character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's - ! name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -208,10 +206,15 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) ! The default is to assume an increase by 2 ppt for the salinity and a uniform temperature. - call get_param(param_file, mdl,"S_RANGE",S_range,'Initial salinity range.', & + call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range.', & units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range', & + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & + units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + call get_param(param_file, mdl, "SLOSHING_T_PERT", T_pert, & + 'A mid-column temperature perturbation in the sloshing test case', & + units='degC', default=1.0, scale=US%degC_to_C, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -228,7 +231,7 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ xi0 = 0.0 do k = 1,nz xi1 = xi0 + deltah / G%max_depth ! = xi0 + 1.0 / real(nz) - S(i,j,k) = 34.0*US%ppt_to_S + 0.5 * S_range * (xi0 + xi1) + S(i,j,k) = S_surf + 0.5 * S_range * (xi0 + xi1) xi0 = xi1 enddo enddo ; enddo @@ -241,7 +244,8 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ T(:,:,k) = T(:,:,k-1) + delta_T enddo kdelta = 2 - T(:,:,GV%ke/2 - (kdelta-1):GV%ke/2 + kdelta) = 1.0*US%degC_to_C + ! Perhaps the following lines should instead assign T() = T_pert + T_ref + T(:,:,GV%ke/2 - (kdelta-1):GV%ke/2 + kdelta) = T_pert end subroutine sloshing_initialize_temperature_salinity From 8fa8f310495062050d1c6540021fcbbfa4a155ea Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 23 Dec 2022 06:38:04 -0500 Subject: [PATCH 127/629] +Add runtime parameters for DOME_initialization Added the new runtime parameters DOME_T_LIGHT and reuse the existing parameter S_REF to specify the previously hard-coded dimensional parameters in the DOME_initialization module. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for versions of the DOME test case with temperature and salinity as state variables. --- src/user/DOME_initialization.F90 | 17 +++++++++++++---- 1 file changed, 13 insertions(+), 4 deletions(-) diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index e8a6ae713c..7f939ffef6 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -306,6 +306,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3]. + real :: S_ref ! A default value for salinities [S ~> ppt] + real :: T_light ! A first guess at the temperature of the lightest layer [C ~> degC] ! The following variables are used to set up the transport in the DOME example. real :: tr_0 ! The total integrated inflow transport [H L2 T-1 ~> m3 s-1 or kg s-1] real :: tr_k ! The integrated inflow transport of a layer [H L2 T-1 ~> m3 s-1 or kg s-1] @@ -357,6 +359,13 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) "inflow properties.", units="s-1", default=f_0*US%s_to_T, scale=US%T_to_s) call get_param(PF, mdl, "DOME_INFLOW_LON", inflow_lon, & "The edge longitude of the DOME inflow.", units="km", default=1000.0) + if (associated(tv%S) .or. associated(tv%T)) then + call get_param(PF, mdl, "S_REF", S_ref, & + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + call get_param(PF, mdl, "DOME_T_LIGHT", T_light, & + "A first guess at the temperature of the lightest layer in the DOME test case.", & + units="degC", default=25.0, scale=US%degC_to_C) + endif if (.not.associated(OBC)) return @@ -413,16 +422,16 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) ! The inflow values of temperature and salinity also need to be set here if ! these variables are used. The following code is just a naive example. if (associated(tv%S)) then - ! In this example, all S inflows have values of 35 psu. + ! In this example, all S inflows have values given by S_ref. name = 'salt' call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, segment, OBC_scalar=35.0*US%ppt_to_S, scale=US%ppt_to_S) + call register_segment_tracer(tr_ptr, PF, GV, segment, OBC_scalar=S_ref, scale=US%ppt_to_S) endif if (associated(tv%T)) then ! In this example, the T values are set to be consistent with the layer - ! target density and a salinity of 35 psu. This code is taken from + ! target density and a salinity of S_ref. This code is taken from ! USER_initialize_temp_sal. - pres(:) = tv%P_Ref ; S0(:) = 35.0*US%ppt_to_S ; T0(1) = 25.0*US%degC_to_C + pres(:) = tv%P_Ref ; S0(:) = S_ref ; T0(1) = T_light call calculate_density(T0(1), S0(1), pres(1), rho_guess(1), tv%eqn_of_state) call calculate_density_derivs(T0, S0, pres, drho_dT, drho_dS, tv%eqn_of_state, (/1,1/) ) From 9102dbe39e96a0e17e91e4f2d1df192ed4d79e30 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:12:33 -0500 Subject: [PATCH 128/629] +Add runtime parameter MIN_DZ_FOR_SLOPE_N2 Added the new runtime parameters MIN_DZ_FOR_SLOPE_N2 to specify a previously hard-coded dimensional parameter in the MOM_lateral_mixing_coeffs module. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for configurations using the some forms of the Eady growth rate slope calculation. --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 29 ++++++++++--------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index f5dd0defdc..85049025b6 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -67,6 +67,8 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] + real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the + !! bouyancy frequency used in the slope calculation [Z ~> m] real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] @@ -474,22 +476,19 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) "Module must be initialized before it is used.") if (CS%calculate_Eady_growth_rate) then + call find_eta(h, tv, G, GV, US, e, halo_size=2) if (CS%use_simpler_Eady_growth_rate) then - call find_eta(h, tv, G, GV, US, e, halo_size=2) call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, dzu=dzu, dzv=dzv, & dzSxN=dzSxN, dzSyN=dzSyN, halo=1, OBC=OBC) call calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, CS%SN_u, CS%SN_v) + elseif (CS%use_stored_slopes) then + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) + call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) else - call find_eta(h, tv, G, GV, US, e, halo_size=2) - if (CS%use_stored_slopes) then - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & - CS%slope_x, CS%slope_y, N2_u=N2_u, N2_v=N2_v, halo=1, OBC=OBC) - call calc_Visbeck_coeffs_old(h, CS%slope_x, CS%slope_y, N2_u, N2_v, G, GV, US, CS) - else - !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) - call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) - endif + !call calc_isoneutral_slopes(G, GV, h, e, tv, dt*CS%kappa_smooth, CS%slope_x, CS%slope_y) + call calc_slope_functions_using_just_e(h, G, GV, US, CS, e, .true.) endif endif @@ -826,7 +825,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop real :: N2 ! Brunt-Vaisala frequency squared [T-2 ~> s-2] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. - real :: one_meter ! One meter in thickness units [H ~> m or kg m-2]. real :: S2N2_u_local(SZIB_(G),SZJ_(G),SZK_(GV)) ! The depth integral of the slope times ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times @@ -846,7 +844,6 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - one_meter = 1.0 * GV%m_to_H h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) @@ -887,7 +884,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn,Hup,one_meter)) + N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & S2 = 0.0 S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 @@ -898,7 +895,7 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn,Hup,one_meter)) + N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & S2 = 0.0 S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 @@ -1284,6 +1281,10 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The layer number at which to start vertical integration "//& "of S*N for purposes of finding the Eady growth rate.", & units="nondim", default=2) + call get_param(param_file, mdl, "MIN_DZ_FOR_SLOPE_N2", CS%h_min_N2, & + "The minimum vertical distance to use in the denominator of the "//& + "bouyancy frequency used in the slope calculation.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=CS%use_stored_slopes) endif endif From 90457125caa55a26049a5f618693f3c249ff55be Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:13:11 -0500 Subject: [PATCH 129/629] +Add runtime parameter EN_CHECK_TOLERANCE Added the new runtime parameters EN_CHECK_TOLERANCE to specify a previously hard-coded dimensional tolerance in the MOM_internal_tides module. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for configurations using the MOM_internal_tides module. --- src/parameterizations/lateral/MOM_internal_tides.F90 | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index dc0daecd8e..0f951b355a 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -113,6 +113,8 @@ module MOM_internal_tides !< If true, apply scattering due to small-scale roughness as a sink. logical :: apply_Froude_drag !< If true, apply wave breaking as a sink. + real :: En_check_tol !< An energy density tolerance for flagging points with an imbalance in the + !! internal tide energy budget when apply_Froude_drag is True [R Z3 T-2 ~> J m-2] logical :: apply_residual_drag !< If true, apply sink from residual term of reflection/transmission. real, allocatable :: En(:,:,:,:,:) @@ -474,7 +476,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! Re-scale (reduce) energy due to breaking CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m)/Fr2_max ! Check (for debugging only) - if (abs(En_new - En_check) > 1e-10*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2) then + if (abs(En_new - En_check) > CS%En_check_tol) then call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr-breaking.", & all_print=.true.) write(mesg,*) "En_new=", En_new , "En_check=", En_check @@ -485,7 +487,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & Delta_E_check = En_initial - sum(CS%En(i,j,:,fr,m)) TKE_Froude_loss_check = abs(Delta_E_check)/dt TKE_Froude_loss_tot = sum(CS%TKE_Froude_loss(i,j,:,fr,m)) - if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot) > 1e-10) then + if (abs(TKE_Froude_loss_check - TKE_Froude_loss_tot)*dt > CS%En_check_tol) then call MOM_error(WARNING, "MOM_internal_tides: something is wrong with Fr energy update.", & all_print=.true.) write(mesg,*) "TKE_Froude_loss_check=", TKE_Froude_loss_check, & @@ -2344,6 +2346,11 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_FROUDE_DRAG", CS%apply_Froude_drag, & "If true, apply wave breaking as a sink.", & default=.false.) + call get_param(param_file, mdl, "EN_CHECK_TOLERANCE", CS%En_check_tol, & + "An energy density tolerance for flagging points with an imbalance in the "//& + "internal tide energy budget when INTERNAL_TIDE_FROUDE_DRAG is True.", & + units="J m-2", default=1.0e-10, scale=US%W_m2_to_RZ3_T3*US%s_to_T, & + do_not_log=.not.CS%apply_Froude_drag) call get_param(param_file, mdl, "CDRAG", CS%cdrag, & "CDRAG is the drag coefficient relating the magnitude of "//& "the velocity field to the bottom stress.", & From ecfe8e5c8f4dc44b46a19528919016715040c748 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:14:14 -0500 Subject: [PATCH 130/629] +Add runtime parameter MEKE_LSCALE_MAX_VAL Added the runtime parameters MEKE_LSCALE_MAX_VAL and MEKE_MIN_DEPTH_TOT to specify two previously hard-coded dimensional parameters that are used with some options of the MEKE parameterizations. Also added or amended comments annotating the units of some of the internal variables in the MEKE module. By default, all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for some configurations using the MEKE parameterization. --- src/parameterizations/lateral/MOM_MEKE.F90 | 56 +++++++++++++--------- 1 file changed, 33 insertions(+), 23 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 10d4270202..013cfd386a 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -58,7 +58,7 @@ module MOM_MEKE real :: MEKE_GMECoeff !< Efficiency of conversion of MEKE into ME by GME [nondim] real :: MEKE_damping !< Local depth-independent MEKE dissipation rate [T-1 ~> s-1]. real :: MEKE_Cd_scale !< The ratio of the bottom eddy velocity to the column mean - !! eddy velocity, i.e. sqrt(2*MEKE). This should be less than 1 + !! eddy velocity, i.e. sqrt(2*MEKE), [nondim]. This should be less than 1 !! to account for the surface intensification of MEKE. real :: MEKE_Cb !< Coefficient in the \f$\gamma_{bot}\f$ expression [nondim] real :: MEKE_min_gamma!< Minimum value of gamma_b^2 allowed [nondim] @@ -67,17 +67,21 @@ module MOM_MEKE logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) real :: MEKE_GEOMETRIC_alpha !< The nondimensional coefficient governing the efficiency of the - !! GEOMETRIC thickness diffusion. + !! GEOMETRIC thickness diffusion [nondim]. logical :: MEKE_equilibrium_alt !< If true, use an alternative calculation for the !! equilibrium value of MEKE. logical :: MEKE_equilibrium_restoring !< If true, restore MEKE back to its equilibrium value, !! which is calculated at each time step. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the MEKE GM source term. + real :: MEKE_min_depth_tot !< The minimum total depth over which to distribute MEKE energy + !! sources from GM energy conversion [Z ~> m]. When the total + !! depth is less than this, the sources are scaled away. logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. logical :: use_min_lscale !< Use simple minimum for mixing length scale. + real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. real :: cdrag !< The bottom drag coefficient for MEKE [nondim]. real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] @@ -89,10 +93,10 @@ module MOM_MEKE !! MEKE itself [nondim]. real :: viscosity_coeff_Ku !< The scaling coefficient in the expression for !! viscosity used to parameterize lateral harmonic momentum mixing - !! by unresolved eddies represented by MEKE. + !! by unresolved eddies represented by MEKE [nondim]. real :: viscosity_coeff_Au !< The scaling coefficient in the expression for !! viscosity used to parameterize lateral biharmonic momentum mixing - !! by unresolved eddies represented by MEKE. + !! by unresolved eddies represented by MEKE [nondim]. real :: Lfixed !< Fixed mixing length scale [L ~> m]. real :: aDeform !< Weighting towards deformation scale of mixing length [nondim] real :: aRhines !< Weighting towards Rhines scale of mixing length [nondim] @@ -191,7 +195,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h LmixScale, & ! Eddy mixing length [L ~> m]. barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] - tmp, & ! Temporary variable for diagnostic computation + tmp, & ! Temporary variable for computation of diagnostic velocities [L T-1 ~> m s-1] equilibrium_value ! The equilbrium value of MEKE to be calculated at each ! time step [L2 T-2 ~> m2 s-2] @@ -200,20 +204,18 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! In one place, MEKE_uflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_u, & ! The zonal diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHu, & ! Depth integrated accumulated zonal mass flux [R Z L2 ~> kg]. - drag_vel_u ! A (vertical) viscosity associated with bottom drag at - ! u-points [Z T-1 ~> m s-1]. + drag_vel_u ! A (vertical) viscosity associated with bottom drag at u-points [Z T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G)) :: & MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. ! In one place, MEKE_vflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. - drag_vel_v ! A (vertical) viscosity associated with bottom drag at - ! v-points [Z T-1 ~> m s-1]. + drag_vel_v ! A (vertical) viscosity associated with bottom drag at v-points [Z T-1 ~> m s-1]. real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Inv_K4_max ! The inverse of the local horizontal biharmonic viscosity [T L-4 ~> s m-4] - real :: cdrag2 + real :: cdrag2 ! The square of the drag coefficient [nondim] real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. @@ -397,7 +399,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & - (GV%Rho0 * MAX(1.0*US%m_to_Z, depth_tot(i,j))) + (GV%Rho0 * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -757,10 +759,11 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: bottomFac2, barotrFac2 ! Vertical structure factors [nondim] real :: LmixScale, LRhines, LEady ! Various mixing length scales [L ~> m] - real :: I_H, KhCoeff + real :: I_H ! The inverse of the total column mass, converted to an inverse horizontal length [L-1 ~> m-1] + real :: KhCoeff ! A copy of MEKE_KhCoeff from the control structure [nondim] real :: Kh ! A lateral diffusivity [L2 T-1 ~> m2 s-1] real :: Ubg2 ! Background (tidal?) velocity squared [L2 T-2 ~> m2 s-2] - real :: cd2 + real :: cd2 ! The square of the drag coefficient [nondim] real :: drag_rate ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. real :: src ! The sum of MEKE sources [L2 T-3 ~> W kg-1] real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. @@ -916,7 +919,7 @@ subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & ! Local variables real :: SN ! The local Eady growth rate [T-1 ~> s-1] integer :: i, j, is, ie, js, je ! local indices - real :: cd2 ! bottom drag + real :: cd2 ! The square of the drag coefficient [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec cd2 = CS%cdrag**2 @@ -1011,7 +1014,7 @@ end subroutine MEKE_lengthScales !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. -subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Z_to_L, & +subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) type(MEKE_CS), intent(in) :: CS !< MEKE control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -1021,10 +1024,8 @@ subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Z real, intent(in) :: Rd_dx !< Resolution Ld/dx [nondim]. real, intent(in) :: SN !< Eady growth rate [T-1 ~> s-1]. real, intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. -! real, intent(in) :: Z_to_L !< A conversion factor from depth units (Z) to -! !! the units for lateral distances (L). - real, intent(out) :: bottomFac2 !< gamma_b^2 - real, intent(out) :: barotrFac2 !< gamma_t^2 + real, intent(out) :: bottomFac2 !< gamma_b^2 [nondim] + real, intent(out) :: barotrFac2 !< gamma_t^2 [nondim] real, intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. real, intent(out) :: Lrhines !< Rhines length scale [L ~> m]. real, intent(out) :: Leady !< Eady length scale [L ~> m]. @@ -1061,7 +1062,7 @@ subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Z Leady = 0. endif if (CS%use_min_lscale) then - LmixScale = 1.e7*US%m_to_L + LmixScale = CS%lscale_maxval if (CS%aDeform*Ldeform > 0.) LmixScale = min(LmixScale,CS%aDeform*Ldeform) if (CS%aFrict *Lfrict > 0.) LmixScale = min(LmixScale,CS%aFrict *Lfrict) if (CS%aRhines*Lrhines > 0.) LmixScale = min(LmixScale,CS%aRhines*Lrhines) @@ -1099,10 +1100,10 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, ! 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. + ! 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. - real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value. + ! 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 character(len=16) :: eke_source_str @@ -1244,6 +1245,10 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& "than the streamfunction for the MEKE GM source term.", default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_DEPTH_TOT", CS%MEKE_min_depth_tot, & + "The minimum total depth over which to distribute MEKE energy sources. "//& + "When the total depth is less than this, the sources are scaled away.", & + units="m", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%GM_src_alt) call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) @@ -1262,6 +1267,11 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, "If true, use a strict minimum of provided length scales "//& "rather than harmonic mean.", & default=.false.) + call get_param(param_file, mdl, "MEKE_LSCALE_MAX_VAL", CS%lscale_maxval, & + "The ceiling on the value of the MEKE length scale when MEKE_MIN_LSCALE=True. "//& + "The default is the distance from the equator to the pole on Earth, as "//& + "estimated by enlightenment era scientists, but should probably scale with RAD_EARTH.", & + units="m", default=1.0e7, scale=US%m_to_L, do_not_log=.not.CS%use_min_lscale) call get_param(param_file, mdl, "MEKE_RD_MAX_SCALE", CS%Rd_as_max_scale, & "If true, the length scale used by MEKE is the minimum of "//& "the deformation radius or grid-spacing. Only used if "//& From 17ae97b963d08a6a6070b52f194a07da3b88136d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:15:00 -0500 Subject: [PATCH 131/629] +Add runtime parameter MEKE_MIN_DEPTH_DIFF Added the runtime parameter MEKE_MIN_DEPTH_DIFF to specify a previously hard-coded dimensional parameter that is used to constrain the averaging of the horizontal diffusivity used with the MEKE parameterizations. By default, all answers are bitwise identical, but there is a new entries in the MOM_parameter_doc.all files for some configurations. --- .../lateral/MOM_thickness_diffuse.F90 | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 33492337a7..c0d7e6c50c 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -78,6 +78,9 @@ module MOM_thickness_diffuse !! original implementation, while higher values use expressions that !! satisfy rotational symmetry. logical :: Use_KH_in_MEKE !< If true, uses the thickness diffusivity calculated here to diffuse MEKE. + real :: MEKE_min_depth_diff !< The minimum total depth over which to average the diffusivity + !! used for MEKE [H ~> m or kg m-2]. When the total depth is less + !! than this, the diffusivity is scaled away. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the GM source term. logical :: use_GM_work_bug !< If true, use the incorrect sign for the @@ -97,9 +100,9 @@ module MOM_thickness_diffuse real, allocatable :: Kh_eta_u(:,:) !< Interface height diffusivities at u points [L2 T-1 ~> m2 s-1] real, allocatable :: Kh_eta_v(:,:) !< Interface height diffusivities in v points [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] - real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] - real, allocatable, dimension(:,:) :: khth2d !< 2D isopycnal height diffusivity at h-points [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + real, allocatable :: khth2d(:,:) !< 2D isopycnal height diffusivity at h-points [L2 T-1 ~> m2 s-1] !>@{ !! Diagnostic identifier @@ -537,7 +540,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp enddo do j=js,je ; do i=is,ie - MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) / MAX(1.0*GV%m_to_H, htot(i,j)) + MEKE%Kh_diff(i,j) = MEKE%Kh_diff(i,j) / MAX(CS%MEKE_min_depth_diff, htot(i,j)) enddo ; enddo endif @@ -2157,6 +2160,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & "If true, uses the thickness diffusivity calculated here to diffuse MEKE.", & default=.false.) + call get_param(param_file, mdl, "MEKE_MIN_DEPTH_DIFF", CS%MEKE_min_depth_diff, & + "The minimum total depth over which to average the diffusivity used for MEKE. "//& + "When the total depth is less than this, the diffusivity is scaled away.", & + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%Use_KH_in_MEKE) call get_param(param_file, mdl, "USE_GME", CS%use_GME_thickness_diffuse, & "If true, use the GM+E backscatter scheme in association "//& From f4c0bc132516baa5cd3719ad68f9e59e8c577cbb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:15:33 -0500 Subject: [PATCH 132/629] (*)Require dz_subML to calculate the sub-ML N2 Introduced a fatal error when diagnoseMLDbyDensityDifference is directed to calculate the mean stratification in a region below the mixed layer but dz_subML is not provided as the depth extent over which to average the stratification, replacing the previous hard coded (but unused) default value of 50 m. Also replaced a hard coded floor on the minimum thickness over which to apply boundary fluxes of 1e-30 m in applyBoundaryFluxesInOut with GV%H_subroundoff, which is also a tiny value. This floor is here just to avoid division by 0; while it is possible for this to change answers in some cases where ANGSTROM=0, even then there are other limiters that should apply so the solutions should not change. All answers are bitwise identical with for the MOM6-examples test suite, and very likely for all existing MOM6 configurations. --- .../vertical/MOM_diabatic_aux.F90 | 19 ++++++++++++++----- 1 file changed, 14 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index d51f796df1..c004b63d11 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -694,12 +694,21 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, id_N2, id_SQ - id_N2 = -1 ; if (PRESENT(id_N2subML)) id_N2 = id_N2subML - id_SQ = -1 ; if (PRESENT(id_MLDsq)) id_SQ = id_MLDsq - gE_rho0 = US%L_to_Z**2*GV%g_Earth / (GV%Rho0) - dH_subML = 50.*GV%m_to_H ; if (present(dz_subML)) dH_subML = GV%Z_to_H*dz_subML + id_N2 = -1 + if (present(id_N2subML)) then + if (present(dz_subML)) then + id_N2 = id_N2subML + dH_subML = GV%Z_to_H*dz_subML + else + call MOM_error(FATAL, "When the a diagnostic of the subML stratification is "//& + "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& + "the distance over which to calculate that distance must also be provided.") + endif + endif + + gE_rho0 = US%L_to_Z**2*GV%g_Earth / GV%Rho0 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1146,7 +1155,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! To accommodate vanishing upper layers, we need to allow for an instantaneous ! distribution of forcing over some finite vertical extent. The bulk mixed layer ! code handles this issue properly. - H_limit_fluxes = max(GV%Angstrom_H, 1.0e-30*GV%m_to_H) + H_limit_fluxes = max(GV%Angstrom_H, GV%H_subroundoff) ! diagnostic to see if need to create mass to avoid grounding if (CS%id_createdH>0) CS%createdH(:,:) = 0. From 391ddba15fbd15895057d2f36198d43ec6093344 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:16:45 -0500 Subject: [PATCH 133/629] +Add runtime parameter KD_SEED_KAPPA_SHEAR Added the new runtime parameter KD_SEED_KAPPA_SHEAR to specify a previously hard-coded dimensional parameter used in the MOM_kappa_shear module. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for configurations with USE_JACKSON_PARAM = True. --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 13 +++++++++++-- 1 file changed, 11 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 590711bc2c..a1a5a22322 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -54,6 +54,10 @@ module MOM_kappa_shear !! equation, 0 to eliminate the shear scale [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. real :: kappa_0 !< The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that + !! is used as a starting turbulent diffusivity in the iterations + !! to findind an energetically constrained solution for the + !! shear-driven diffusivity [Z2 T-1 ~> m2 s-1]. real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity [nondim]. @@ -270,7 +274,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! Set the initial guess for kappa, here defined at interfaces. ! ---------------------------------------------------- - do K=1,nzc+1 ; kappa(K) = 1.0*US%m2_s_to_Z2_T ; enddo + do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & @@ -537,7 +541,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ! ---------------------------------------------------- ! Set the initial guess for kappa, here defined at interfaces. ! ---------------------------------------------------- - do K=1,nzc+1 ; kappa(K) = 1.0*US%m2_s_to_Z2_T ; enddo + do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & @@ -1787,6 +1791,11 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & do_not_log=just_read) + call get_param(param_file, mdl, "KD_SEED_KAPPA_SHEAR", CS%kappa_seed, & + "A moderately large seed value of diapycnal diffusivity that is used as a "//& + "starting turbulent diffusivity in the iterations to find an energetically "//& + "constrained solution for the shear-driven diffusivity.", & + units="m2 s-1", default=1.0, scale=US%m2_s_to_Z2_T) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & From 1db93d3330d42bec12251b5055d42841345ba772 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 28 Dec 2022 09:17:10 -0500 Subject: [PATCH 134/629] +Add runtime parameter ENTRAIN_DIFFUSIVE_MAX_ENT Added the new runtime parameter ENTRAIN_DIFFUSIVE_MAX_ENT to specify a previously hard-coded upper limit on the rate of entrainment in the buffer layers with a bulk mixed layer in the MOM_entrainment_diffusive module. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for some layer-mode configurations with a bulk mixed layer. --- .../vertical/MOM_entrain_diffusive.F90 | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 9e749874c3..332321b209 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -34,6 +34,9 @@ module MOM_entrain_diffusive !! calculate the diapycnal entrainment. real :: Tolerance_Ent !< The tolerance with which to solve for entrainment values !! [H ~> m or kg m-2]. + real :: max_Ent !< A large ceiling on the maximum permitted amount of entrainment + !! across each interface between the mixed and buffer layers within + !! a timestep [H ~> m or kg m-2]. real :: Rho_sig_off !< The offset between potential density and a sigma value [R ~> kg m-3] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -1053,7 +1056,6 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, real, dimension(SZI_(G), SZK_(GV)) :: & S_est ! An estimate of the coordinate potential density - 1000 after ! entrainment for each layer [R ~> kg m-3]. - real :: max_ent ! The maximum possible entrainment [H ~> m or kg m-2]. real :: dh ! An available thickness [H ~> m or kg m-2]. real :: Kd_x_dt ! The diffusion that remains after thin layers are ! entrained [H2 ~> m2 or kg2 m-4]. @@ -1063,8 +1065,6 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke -! max_ent = 1.0e14*GV%Angstrom_H ! This is set to avoid roundoff problems. - max_ent = 1.0e4*GV%m_to_H h_neglect = GV%H_subroundoff do i=is,ie ; pres(i) = tv%P_Ref ; enddo @@ -1084,8 +1084,7 @@ subroutine set_Ent_bl(h, dtKd_int, tv, kb, kmb, do_i, G, GV, US, CS, j, Ent_bl, do k=2,kmb ; do i=is,ie if (do_i(i)) then - Ent_bl(i,K) = min(2.0 * dtKd_int(i,K) / (h(i,j,k-1) + h(i,j,k) + h_neglect), & - max_ent) + Ent_bl(i,K) = min(2.0 * dtKd_int(i,K) / (h(i,j,k-1) + h(i,j,k) + h_neglect), CS%max_Ent) else ; Ent_bl(i,K) = 0.0 ; endif enddo ; enddo @@ -2116,6 +2115,10 @@ subroutine entrain_diffusive_init(Time, G, GV, US, param_file, diag, CS, just_re "The tolerance with which to solve for entrainment values.", & units="m", default=US%Z_to_m*MAX(100.0*GV%Angstrom_Z,1.0e-4*sqrt(dt*Kd)), scale=GV%m_to_H, & do_not_log=just_read_params) + call get_param(param_file, mdl, "ENTRAIN_DIFFUSIVE_MAX_ENT", CS%max_Ent, & + "A large ceiling on the maximum permitted amount of entrainment across each "//& + "interface between the mixed and buffer layers within a timestep.", & + units="m", default=1.0e4, scale=GV%m_to_H, do_not_log=.not.CS%bulkmixedlayer) CS%Rho_sig_off = 1000.0*US%kg_m3_to_R From 42051fca7c8486a1c49780aac545be41e7e3c294 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 29 Dec 2022 10:10:13 -0500 Subject: [PATCH 135/629] +Add runtime parameter KPP_LT_MLD_GUESS_MIN Added the new runtime parameter KPP_LT_MLD_GUESS_MIN to specify a previously hard-coded lower limit on the estimate of the boundary layer depth used to calculate the Langmuir number for some options with KPP. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for some configurations with a KPP and Langmuir enhanced turbulence. --- .../vertical/MOM_CVMix_KPP.F90 | 35 ++++++++++--------- 1 file changed, 18 insertions(+), 17 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index d1d4b1c790..3ac31ef466 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -113,6 +113,9 @@ module MOM_CVMix_KPP logical :: LT_Vt2_Enhancement !< Flags if enhancing Vt2 due to LT integer :: LT_VT2_METHOD !< Integer for Vt2 LT method real :: KPP_VT2_ENH_FAC !< Factor to multiply by VT2 if Method is CONSTANT [nondim] + real :: MLD_guess_min !< The minimum estimate of the mixed layer depth used to + !! calculate the Langmuir number for Langmuir turbulence + !! enhancement with KPP [Z ~> m] logical :: STOKES_MIXING !< Flag if model is mixing down Stokes gradient !! This is relevant for which current to use in RiB @@ -460,6 +463,13 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) endif endif + if (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) then + call get_param(paramFile, mdl, "KPP_LT_MLD_GUESS_MIN", CS%MLD_guess_min, & + "The minimum estimate of the mixed layer depth used to calculate "//& + "the Langmuir number for Langmuir turbulence enhancement with KPP.", & + units="m", default=1.0, scale=US%m_to_Z) + endif + call closeParameterBlock(paramFile) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -658,10 +668,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! loop over horizontal points on processor do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip calling KPP for land points - if (G%mask2dT(i,j)==0.) cycle + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then ! things independent of position within the column surfFricVel = US%Z_to_m*US%s_to_T * uStar(i,j) @@ -869,7 +876,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! end of the horizontal do-loops over the vertical columns - enddo ! i + endif ; enddo ! i enddo ! j call cpu_clock_end(id_clock_KPP_calc) @@ -1000,10 +1007,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip calling KPP for land points - if (G%mask2dT(i,j)==0.) cycle + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then do k=1,GV%ke U_H(k) = 0.5 * (u(i,j,k)+u(i-1,j,k)) @@ -1120,10 +1124,10 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl enddo ! k-loop finishes if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then - MLD_guess = max( 1.*US%m_to_Z, abs(CS%OBLdepthprev(i,j) ) ) + MLD_guess = max( CS%MLD_guess_min, abs(CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) - CS%La_SL(i,j)=LA + CS%La_SL(i,j) = LA endif @@ -1265,7 +1269,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_Usurf > 0) CS%Usurf(i,j) = surfU if (CS%id_Vsurf > 0) CS%Vsurf(i,j) = surfV - enddo + endif ; enddo enddo call cpu_clock_end(id_clock_KPP_compute_BLD) @@ -1326,10 +1330,7 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) !$OMP parallel do default(none) shared(G, GV, US, CS, h, OBLdepth_prev) & !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) do j = G%jsc, G%jec - do i = G%isc, G%iec - - ! skip land points - if (G%mask2dT(i,j)==0.) cycle + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then iFaceHeight(1) = 0.0 ! BBL is all relative to the surface hcorr = 0. @@ -1363,7 +1364,7 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) ! prevent OBL depths deeper than the bathymetric depth CS%OBLdepth(i,j) = min( CS%OBLdepth(i,j), -iFaceHeight(GV%ke+1) ) ! no deeper than bottom CS%kOBL(i,j) = CVMix_kpp_compute_kOBL_depth( iFaceHeight, cellHeight, CS%OBLdepth(i,j) ) - enddo + endif ; enddo enddo enddo ! s-loop From 4e5f7408fde9515d4e09aaa8f51679a98a344f6f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 3 Jan 2023 10:57:32 -0500 Subject: [PATCH 136/629] +Add runtime parameter REG_SFC_SUFFICIENT_ADJ Added the new runtime parameter REG_SFC_SUFFICIENT_ADJ to specify a previously hard-coded fraction of the target net entrainment to the mixed and buffer layers that is enough to stop the search for additional mass from the interior layers when regularizing the near-surface layers in layer-mode configurations. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for some layer-mode configurations with REGULARIZE_SURFACE_LAYERS=True. --- .../vertical/MOM_regularize_layers.F90 | 29 ++++++++++++------- 1 file changed, 19 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 8966c12b79..bb81d367c6 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -34,6 +34,10 @@ module MOM_regularize_layers real :: density_match_tol !< A relative tolerance for how well the densities must match !! with the target densities during detrainment when regularizing !! the near-surface layers [nondim] + real :: sufficient_adjustment !< The fraction of the target entrainment of mass to the mixed + !! and buffer layers that is enough for one timestep when regularizing + !! the near-surface layers [nondim]. No more mass will be sought from + !! deeper layers in the interior after this fraction is exceeded. real :: h_def_tol1 !< The value of the relative thickness deficit at !! which to start modifying the structure, 0.5 by !! default (or a thickness ratio of 5.83) [nondim]. @@ -75,7 +79,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a @@ -86,7 +90,7 @@ subroutine regularize_layers(h, tv, dt, ea, eb, G, GV, US, CS) !! this should be increased due to mixed layer !! entrainment [H ~> m or kg m-2]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure if (.not. CS%initialized) call MOM_error(FATAL, "MOM_regularize_layers: "//& "Module must be initialized before it is used.") @@ -107,7 +111,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2]. type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any !! available thermodynamic fields. Absent fields - !! have NULL ptrs. + !! have NULL pointers. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< The amount of fluid moved downward into a @@ -118,7 +122,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) !! this should be increased due to mixed layer !! entrainment [H ~> m or kg m-2]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -149,7 +153,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real, dimension(SZI_(G)) :: & p_ref_cv, & ! Reference pressure for the potential density which defines ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. - Rcv_tol, & ! A tolerence, relative to the target density differences + Rcv_tol, & ! A tolerance, relative to the target density differences ! between layers, for detraining into the interior [nondim]. h_add_tgt, & ! The target for the thickness to add to the mixed layers [H ~> m or kg m-2] h_add_tot, & ! The net thickness added to the mixed layers [H ~> m or kg m-2] @@ -161,7 +165,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real :: I_dtol ! The inverse of the tolerance changes [nondim]. real :: I_dtol34 ! The inverse of the tolerance changes [nondim]. real :: e_e, e_w, e_n, e_s ! Temporary interface heights [H ~> m or kg m-2]. - real :: wt ! The weight of the filted interfaces in setting the targets [nondim]. + real :: wt ! The weight of the filtered interfaces in setting the targets [nondim]. real :: scale ! A scaling factor [nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -321,7 +325,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) S_2d(i,nkmb) = (h_prev*S_2d(i,nkmb) + h_add*S_2d(i,k)) / h_2d(i,nkmb) if ((e_2d(i,nkmb+1) <= e_filt(i,nkmb+1)) .or. & - (h_add_tot(i) > 0.6*h_add_tgt(i))) then !### 0.6 is adjustable?. + (h_add_tot(i) > CS%sufficient_adjustment*h_add_tgt(i))) then more_ent_i(i) = .false. else cols_left = .true. @@ -602,7 +606,7 @@ end subroutine regularize_surface !> This subroutine determines the amount by which the harmonic mean !! thickness at velocity points differ from the arithmetic means, relative to -!! the the arithmetic means, after eliminating thickness variations that are +!! the arithmetic means, after eliminating thickness variations that are !! solely due to topography and aggregating all interior layers into one. subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -615,7 +619,7 @@ subroutine find_deficit_ratios(e, def_rat_u, def_rat_v, G, GV, CS, h) real, dimension(SZI_(G),SZJB_(G)), & intent(out) :: def_rat_v !< The thickness deficit ratio at v points, !! [nondim]. - type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(in) :: CS !< Regularize layer control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. @@ -710,7 +714,7 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) !! run-time parameters. type(diag_ctrl), target, intent(inout) :: diag !< A structure that is used to regulate !! diagnostic output. - type(regularize_layers_CS), intent(inout) :: CS !< Regularize layer control struct + type(regularize_layers_CS), intent(inout) :: CS !< Regularize layer control structure # include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. @@ -748,6 +752,11 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) "densities during detrainment when regularizing the near-surface layers. The "//& "default of 0.6 gives 20% overlaps in density", & units="nondim", default=0.6, do_not_log=just_read) + call get_param(param_file, mdl, "REG_SFC_SUFFICIENT_ADJ", CS%sufficient_adjustment, & + "The fraction of the target entrainment of mass to the mixed and buffer layers "//& + "that is enough for one timestep when regularizing the near-surface layers. "//& + "No more mass will be sought from deeper layers in the interior after this "//& + "fraction is exceeded.", units="nondim", default=0.6, do_not_log=just_read) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) From 44f4be420e9723a7bbda1a5f5008428c00cd8186 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 3 Jan 2023 11:01:47 -0500 Subject: [PATCH 137/629] +Add runtime parameter SALT_EXTRACTION_LIMIT Added the new runtime parameter SALT_EXTRACTION_LIMIT to specify a previously hard-coded limit on the fraction of the salt in a layer that can be extracted by the surface fluxes within a timestep. Also added do_not_log flags based on the value of ENABLE_THERMODYNAMICS to avoid logging parameters that are only used if thermodynamics are active in cases when it is not. In addition, the doxygen trailer describing this module had been inappropriately borrowed from another module, so it was completely rewritten to describe what the routines in this module actually do. The missing doxygen description of set_pen_shortwave was also added, and a number of spelling errors in comments were corrected. By default all answers are bitwise identical, but there is a new entry in the MOM_parameter_doc.all files for some configurations and meaningless entries have been removed from others. --- .../vertical/MOM_diabatic_aux.F90 | 132 ++++++++++-------- 1 file changed, 76 insertions(+), 56 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index c004b63d11..ba8ba0b805 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -43,6 +43,8 @@ module MOM_diabatic_aux logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff at the !! river mouths to a depth of "rivermix_depth" real :: rivermix_depth = 0.0 !< The depth to which rivers are mixed if do_rivermix = T [Z ~> m]. + real :: dSalt_frac_max !< An upper limit on the fraction of the salt in a layer that can be + !! lost to the net surface salt fluxes within a timestep [nondim] logical :: reclaim_frazil !< If true, try to use any frazil heat deficit to !! to cool the topmost layer down to the freezing !! point. The default is true. @@ -220,7 +222,7 @@ subroutine make_frazil(h, tv, G, GV, US, CS, p_surf, halo) end subroutine make_frazil !> This subroutine applies double diffusion to T & S, assuming no diapycnal mass -!! fluxes, using a simple triadiagonal solver. +!! fluxes, using a simple tridiagonal solver. subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -507,7 +509,7 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) real :: a_n(SZI_(G)), a_s(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] real :: a_e(SZI_(G)), a_w(SZI_(G)) ! Fractional weights of the neighboring velocity points [nondim] real :: sum_area ! A sum of adjacent areas [L2 ~> m2] - real :: Idenom ! The inverse of the denomninator in a weighted average [L-2 ~> m-2] + real :: Idenom ! The inverse of the denominator in a weighted average [L-2 ~> m-2] logical :: mix_vertically, zero_mixing integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -594,12 +596,15 @@ subroutine find_uv_at_h(u, v, h, u_h, v_h, G, GV, US, ea, eb, zero_mix) call cpu_clock_end(id_clock_uv_at_h) end subroutine find_uv_at_h - +!> Estimate the optical properties of the water column and determine the penetrating shortwave +!! radiation by band, extracting the relevant information from the fluxes type and storing it +!! in the optics type for later application. This routine is effectively a wrapper for +!! set_opacity with added error handling and diagnostics. subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow_CSp) type(optics_type), pointer :: optics !< An optics structure that has will contain !! information about shortwave fluxes and absorption. type(forcing), intent(inout) :: fluxes !< points to forcing fields - !! unused fields have NULL ptrs + !! unused fields have NULL pointers 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 @@ -702,7 +707,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, id_N2 = id_N2subML dH_subML = GV%Z_to_H*dz_subML else - call MOM_error(FATAL, "When the a diagnostic of the subML stratification is "//& + call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& "the distance over which to calculate that distance must also be provided.") endif @@ -737,10 +742,10 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! the cells that extend over at least dz_subML. if (id_N2>0) then do i=is,ie - if (MLD(i,j)==0.0) then ! Still in the mixed layer. + if (MLD(i,j) == 0.0) then ! Still in the mixed layer. H_subML(i) = H_subML(i) + h(i,j,k) elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. - if (dH_N2(i)==0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + if (dH_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. dH_N2(i) = 0.5 * h(i,j,k) @@ -761,8 +766,8 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, do i = is, ie deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) - if ((MLD(i,j)==0.) .and. (ddRho>0.) .and. & - (deltaRhoAtKm1(i)=densityDiff)) then + if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & + (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho MLD(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) endif @@ -770,7 +775,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, enddo ! i-loop enddo ! k-loop do i=is,ie - if ((MLD(i,j)==0.) .and. (deltaRhoAtK(i)0) then ! Now actually calculate stratification, N2, below the mixed layer. @@ -1293,7 +1298,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW do i=is,ie - if (G%mask2dT(i,j)>0.) then + if (G%mask2dT(i,j) > 0.) then ! A/ Update mass, temp, and salinity due to incoming mass flux. do k=1,1 @@ -1333,7 +1338,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! where River is in units of [Z T-1 ~> m s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow - ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. + ! drho_ds = The derivative of density with salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 @@ -1384,8 +1389,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) dTemp = fractionOfForcing*netHeat(i) - ! ### The 0.9999 here should become a run-time parameter? - dSalt = max( fractionOfForcing*netSalt(i), -0.9999*h2d(i,k)*tv%S(i,j,k)) + dSalt = max( fractionOfForcing*netSalt(i), -CS%dSalt_frac_max * h2d(i,k) * tv%S(i,j,k)) ! Update the forcing by the part to be consumed within the present k-layer. ! If fractionOfForcing = 1, then new netMassOut vanishes. @@ -1441,7 +1445,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo ! k ! Check if trying to apply fluxes over land points - elseif ((abs(netHeat(i))+abs(netSalt(i))+abs(netMassIn(i))+abs(netMassOut(i)))>0.) then + elseif ((abs(netHeat(i)) + abs(netSalt(i)) + abs(netMassIn(i)) + abs(netMassOut(i))) > 0.) then if (.not. CS%ignore_fluxes_over_land) then call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (land)') @@ -1579,7 +1583,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (CS%id_nonpenSW_diag > 0) call post_data(CS%id_nonpenSW_diag , CS%nonpenSW_diag , CS%diag) ! The following check will be ignored if ignore_fluxes_over_land = true - if (numberOfGroundings>0 .and. .not. CS%ignore_fluxes_over_land) then + if ((numberOfGroundings > 0) .and. .not.CS%ignore_fluxes_over_land) then do i = 1, min(numberOfGroundings, maxGroundings) call forcing_SinglePointPrint(fluxes,G,iGround(i),jGround(i),'applyBoundaryFluxesInOut (grounding)') write(mesg(1:45),'(3es15.3)') G%geoLonT( iGround(i), jGround(i) ), & @@ -1613,8 +1617,8 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori !! boundary layer scheme to determine the diffusivity !! in the surface boundary layer. -! This "include" declares and sets the variable "version". -#include "version_variable.h" + ! This "include" declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_diabatic_aux" ! This module's name. character(len=200) :: inputdir ! The directory where NetCDF input files character(len=240) :: chl_filename ! A file from which chl_a concentrations are to be read. @@ -1642,28 +1646,31 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori "The following parameters are used for auxiliary diabatic processes.") call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", use_temperature, & - "If true, temperature and salinity are used as state "//& - "variables.", default=.true.) + "If true, temperature and salinity are used as state variables.", default=.true.) call get_param(param_file, mdl, "RECLAIM_FRAZIL", CS%reclaim_frazil, & "If true, try to use any frazil heat deficit to cool any "//& "overlying layers down to the freezing point, thereby "//& "avoiding the creation of thin ice when the SST is above "//& - "the freezing point.", default=.true.) - call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", & - CS%pressure_dependent_frazil, & + "the freezing point.", default=.true., do_not_log=.not.use_temperature) + call get_param(param_file, mdl, "SALT_EXTRACTION_LIMIT", CS%dSalt_frac_max, & + "An upper limit on the fraction of the salt in a layer that can be lost to the "//& + "net surface salt fluxes within a timestep.", & + units="nondim", default=0.9999, do_not_log=.not.use_temperature) + CS%dSalt_frac_max = max(min(CS%dSalt_frac_max, 1.0), 0.0) + call get_param(param_file, mdl, "PRESSURE_DEPENDENT_FRAZIL", CS%pressure_dependent_frazil, & "If true, use a pressure dependent freezing temperature "//& "when making frazil. The default is false, which will be "//& "faster but is inappropriate with ice-shelf cavities.", & - default=.false.) + default=.false., do_not_log=.not.use_temperature) if (use_ePBL) then call get_param(param_file, mdl, "IGNORE_FLUXES_OVER_LAND", CS%ignore_fluxes_over_land,& - "If true, the model does not check if fluxes are being applied "//& - "over land points. This is needed when the ocean is coupled "//& - "with ice shelves and sea ice, since the sea ice mask needs to "//& - "be different than the ocean mask to avoid sea ice formation "//& - "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) + "If true, the model does not check if fluxes are being applied "//& + "over land points. This is needed when the ocean is coupled "//& + "with ice shelves and sea ice, since the sea ice mask needs to "//& + "be different than the ocean mask to avoid sea ice formation "//& + "under ice shelves. This flag only works when use_ePBL = True.", default=.false.) call get_param(param_file, mdl, "DO_RIVERMIX", CS%do_rivermix, & "If true, apply additional mixing wherever there is "//& "runoff, so that it is mixed down to RIVERMIX_DEPTH "//& @@ -1680,11 +1687,11 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & - default=.false.) + default=.false., do_not_log=.not.use_temperature) call get_param(param_file, mdl, "USE_CALVING_HEAT_CONTENT", CS%use_calving_heat_content, & "If true, use the fluxes%calving_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*froz_runoff.", & - default=.false.) + default=.false., do_not_log=.not.use_temperature) else CS%use_river_heat_content = .false. CS%use_calving_heat_content = .false. @@ -1778,32 +1785,45 @@ end subroutine diabatic_aux_end !> \namespace mom_diabatic_aux !! -!! This module contains the subroutines that, along with the -!! subroutines that it calls, implements diapycnal mass and momentum -!! fluxes and a bulk mixed layer. The diapycnal diffusion can be -!! used without the bulk mixed layer. +!! This module contains subroutines that apply various diabatic processes. Usually these +!! subroutines are called from the MOM_diabatic module. All of these routines use appropriate +!! limiters or logic to work properly with arbitrary layer thicknesses (including massless layers) +!! and an arbitrarily large timestep. +!! +!! The subroutine make_frazil facilitates the formation of frazil ice when the ocean water +!! drops below the in situ freezing point by heating the water to the freezing point and +!! accumulating the required heat for exchange with the sea-ice module. +!! +!! The subroutine adjust_salt adds salt as necessary to keep the salinity above a +!! specified minimum value, and keeps track of the cumulative additions. If the minimum +!! salinity is the natural value of 0, this routine should never do anything. +!! +!! The subroutine differential_diffuse_T_S solves a pair of tridiagonal equations for +!! the diffusion of temperatures and salinities with differing diffusivities. +!! +!! The subroutine triDiagTS solves a tridiagonal equations for the evolution of temperatures +!! and salinities due to net entrainment by layers and a diffusion with the same diffusivity. +!! +!! The subroutine triDiagTS_Eulerian solves a tridiagonal equations for the evolution of +!! temperatures and salinities due to diffusion with the same diffusivity, but no net entrainment. +!! +!! The subroutine find_uv_at_h interpolates velocities to thickness points, optionally also +!! using tridiagonal equations to solve for the impacts of net entrainment or mixing of +!! momentum between layers. +!! +!! The subroutine set_pen_shortwave determines the optical properties of the water column and +!! the net shortwave fluxes, and stores them in the optics type, working via calls to set_opacity. +!! +!! The subroutine diagnoseMLDbyDensityDifference diagnoses a mixed layer depth based on a +!! density difference criterion, and may also estimate the stratification of the water below +!! this diagnosed mixed layer. !! -!! diabatic first determines the (diffusive) diapycnal mass fluxes -!! based on the convergence of the buoyancy fluxes within each layer. -!! The dual-stream entrainment scheme of MacDougall and Dewar (JPO, -!! 1997) is used for combined diapycnal advection and diffusion, -!! calculated implicitly and potentially with the Richardson number -!! dependent mixing, as described by Hallberg (MWR, 2000). Diapycnal -!! advection is fundamentally the residual of diapycnal diffusion, -!! so the fully implicit upwind differencing scheme that is used is -!! entirely appropriate. The downward buoyancy flux in each layer -!! is determined from an implicit calculation based on the previously -!! calculated flux of the layer above and an estimated flux in the -!! layer below. This flux is subject to the following conditions: -!! (1) the flux in the top and bottom layers are set by the boundary -!! conditions, and (2) no layer may be driven below an Angstrom thick- -!! ness. If there is a bulk mixed layer, the buffer layer is treat- -!! ed as a fixed density layer with vanishingly small diffusivity. +!! The subroutine diagnoseMLDbyEnergy diagnoses a mixed layer depth based on a mixing-energy +!! criterion, as described by Reichl et al., 2022, JGR: Oceans, doi:10.1029/2021JC018140. !! -!! diabatic takes 5 arguments: the two velocities (u and v), the -!! thicknesses (h), a structure containing the forcing fields, and -!! the length of time over which to act (dt). The velocities and -!! thickness are taken as inputs and modified within the subroutine. -!! There is no limit on the time step. +!! The subroutine applyBoundaryFluxesInOut updates the layer thicknesses, temperatures and +!! salinities due to the application of the surface forcing. It may also calculate the implied +!! turbulent kinetic energy requirements for this forcing to be mixed over the model's finite +!! vertical resolution in the surface layers. end module MOM_diabatic_aux From 7e2c427404ffdeb0e0c45c68a2d845c95b5f4d61 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 3 Jan 2023 11:10:38 -0500 Subject: [PATCH 138/629] +Add runtime parameter MECH_TKE_FLOOR Added the new runtime parameter MECH_TKE_FLOOR to specify a previously hard-coded tiny positive value for the remaining TKE when the bulk mixed does not yet have HMIX_MIN of fluid during mechanical entrainment. By default all answers are bitwise identical, but the MOM_parameter_doc.all files for some configurations with a bulk mixed layer and HMIX_MIN > 0 have a new entry. --- .../vertical/MOM_bulk_mixed_layer.F90 | 25 +++++++++++++------ 1 file changed, 17 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index cb17884ee7..9d118f9096 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -51,6 +51,10 @@ module MOM_bulk_mixed_layer !! released mean kinetic energy becomes TKE [nondim]. real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. + real :: mech_TKE_floor !< A tiny floor on the amount of turbulent kinetic energy that is + !! used when the mixed layer does not yet contain HMIX_MIN fluid + !! [Z L2 T-2 ~> m3 s-2]. The default is so small that its actual + !! value is irrelevant, but it is detectably greater than 0. real :: H_limit_fluxes !< When the total ocean depth is less than this !! value [H ~> m or kg m-2], scale away all surface forcing to !! avoid boiling the ocean. @@ -1633,8 +1637,8 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif TKE(i) = TKE_full_ent - !### The minimum TKE value in this line may be problematically small. - if (TKE(i) <= 0.0) TKE(i) = 1.0e-150*US%m_to_Z*US%m_s_to_L_T**2 + + if (TKE(i) <= 0.0) TKE(i) = CS%mech_TKE_floor else ! The layer is only partially entrained. The amount that will be ! entrained is determined iteratively. No further layers will be @@ -2406,7 +2410,7 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, R0(i,kb2) = R0(i,kb1) - Rcv(i,kb2)=Rcv(i,kb1) ; T(i,kb2)=T(i,kb1) ; S(i,kb2)=S(i,kb1) + Rcv(i,kb2) = Rcv(i,kb1) ; T(i,kb2) = T(i,kb1) ; S(i,kb2) = S(i,kb1) if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then @@ -3175,9 +3179,8 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! the released buoyancy. With multiple buffer layers, much more ! graceful options are available. do i=is,ie ; if (h(i,nkmb) > 0.0) then - if ((R0(i,0) & - (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then + if ((R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb))) then + if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) else detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) @@ -3220,7 +3223,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e do k=nz-1,nkmb+1,-1 ; do i=is,ie if (splittable_BL(i)) then - if (RcvTgt(k)<=Rcv(i,nkmb)) then + if (RcvTgt(k) <= Rcv(i,nkmb)) then ! Estimate dR/drho, dTheta/dR, and dS/dR, where R is the coordinate variable ! and rho is in-situ (or surface) potential density. ! There is no "right" way to do this, so this keeps things reasonable, if @@ -3320,7 +3323,7 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) endif - endif ! RcvTgt(k)<=Rcv(i,nkmb) + endif ! (RcvTgt(k) <= Rcv(i,nkmb)) endif ! splittable_BL enddo ; enddo ! i & k loops @@ -3422,6 +3425,12 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=US%m_to_Z) CS%Hmix_min = GV%Z_to_H * Hmix_min_Z + call get_param(param_file, mdl, "MECH_TKE_FLOOR", CS%mech_TKE_floor, & + "A tiny floor on the amount of turbulent kinetic energy that is used when "//& + "the mixed layer does not yet contain HMIX_MIN fluid. The default is so "//& + "small that its actual value is irrelevant, so long as it is greater than 0.", & + units="m3 s-2", default=1.0e-150, scale=US%m_to_Z*US%m_s_to_L_T**2, & + do_not_log=(Hmix_min_Z<=0.0)) call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & "If true, limit the detrainment from the buffer layers "//& From 3cecac4dc7a67aadc4bc73ca7ac0e3bc5e0522dc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 3 Jan 2023 18:22:06 -0500 Subject: [PATCH 139/629] +Add runtime parameter VARYING_SPONGE_MASK_THICKNESS Added the new runtime parameter VARYING_SPONGE_MASK_THICKNESS to specify a previously hard-coded input file thickness below which the target values in time-varying sponges are replaced with those from the layer above. By default all answers are bitwise identical, but the MOM_parameter_doc.all files for configurations with time-varying sponges have a new entry. --- .../vertical/MOM_ALE_sponge.F90 | 42 +++++++++++-------- 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 740c42f16a..7ff3bd3701 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -131,7 +131,10 @@ module MOM_ALE_sponge !! been rearranged for rotational invariance. logical :: time_varying_sponges !< True if using newer sponge code - logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid + logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid + real :: varying_input_h_mask !< An input file thickness below which the target values with time-varying + !! sponges are replaced by the value above [H ~> m or kg m-2]. + !! It is not clear why this needs to be greater than 0. !>@{ Diagnostic IDs integer, dimension(MAX_FIELDS_) :: id_sp_tendency !< Diagnostic ids for tracers @@ -444,7 +447,7 @@ end subroutine get_ALE_sponge_thicknesses subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Iresttime_u_in, Iresttime_v_in) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse !! for model parameter values. @@ -502,6 +505,11 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "VARYING_SPONGE_MASK_THICKNESS", CS%varying_input_h_mask, & + "An input file thickness below which the target values with "//& + "time-varying sponges are replaced by the value above.", & + units="m", default=0.001, scale=GV%m_to_H) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -893,7 +901,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename else CS%Ref_val_u%id = init_external_field(filename_u, fieldname_u) endif - fld_sz(1:4)=-1 + fld_sz(1:4) = -1 call get_external_field_info(CS%Ref_val_u%id, size=fld_sz) CS%Ref_val_u%nz_data = fld_sz(3) CS%Ref_val_u%num_tlevs = fld_sz(4) @@ -904,7 +912,7 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename else CS%Ref_val_v%id = init_external_field(filename_v, fieldname_v) endif - fld_sz(1:4)=-1 + fld_sz(1:4) = -1 call get_external_field_info(CS%Ref_val_v%id, size=fld_sz) CS%Ref_val_v%nz_data = fld_sz(3) CS%Ref_val_v%num_tlevs = fld_sz(4) @@ -943,20 +951,20 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts [nondim] real, allocatable, dimension(:,:,:) :: mask_v ! A temporary array for field mask at v pts [nondim] real, allocatable, dimension(:,:,:) :: tmp !< A temporary array for thermodynamic sponge tendency - !! diagnostics [various] + !! diagnostics [various] then in [various T-1 ~> various s-1] real, allocatable, dimension(:,:,:) :: tmp_u !< A temporary array for u sponge acceleration diagnostics !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. ! Local variables for ALE remapping - real, dimension(:), allocatable :: tmpT1d + real, dimension(:), allocatable :: tmpT1d ! A temporary variable for ALE remapping [various] integer :: c, m, i, j, k, is, ie, js, je, nz, nz_data real, allocatable, dimension(:), target :: z_in ! The depths (positive downward) in the input file [Z ~> m] real, allocatable, dimension(:), target :: z_edges_in ! The depths (positive downward) of the ! edges in the input file [Z ~> m] real :: missing_value ! The missing value in the input data field [various] - real :: Idt ! The inverse of the timestep [T-1 ~> s-1] + real :: Idt ! The inverse of the timestep [T-1 ~> s-1] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. real :: sp_val_u ! Interpolation of sp_val to u-points, often a velocity in [L T-1 ~> m s-1] @@ -986,6 +994,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate( hsrc(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col + ! Set i and j to the structured indices of column c. i = CS%col_i(c) ; j = CS%col_j(c) CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) ! Build the source grid @@ -1001,7 +1010,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) tmpT1d(k) = -99.9 endif hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 + if (hsrc(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model @@ -1009,7 +1018,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val(m)%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) CS%Ref_val(m)%p(1:nz_data,c) = tmpT1d(1:nz_data) do k=2,nz_data - if (CS%Ref_val(m)%h(k,c) <= 0.001*GV%m_to_H) & + if (CS%Ref_val(m)%h(k,c) <= CS%varying_input_h_mask) & ! some confusion here about why the masks are not correct returning from horiz_interp ! reverting to using a minimum thickness criteria CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) @@ -1027,14 +1036,13 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate(tmp(G%isd:G%ied,G%jsd:G%jed,nz), source=0.0) endif do c=1,CS%num_col - ! c is an index for the next 3 lines but a multiplier for the rest of the loop - ! Therefore we use c as per C code and increment the index where necessary. + ! Set i and j to the structured indices of column c. i = CS%col_i(c) ; j = CS%col_j(c) damp = dt * CS%Iresttime_col(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) do k=1,nz - h_col(k)=h(i,j,k) + h_col(k) = h(i,j,k) enddo if (CS%time_varying_sponges) then @@ -1081,8 +1089,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) allocate( hsrc(nz_data) ) do c=1,CS%num_col_u - ! c is an index for the next 3 lines but a multiplier for the rest of the loop - ! Therefore we use c as per C code and increment the index where necessary. + ! Set i and j to the structured indices of column c. i = CS%col_i_u(c) ; j = CS%col_j_u(c) if (mask_u(i,j,1) == 1.0) then do k=1,nz_data @@ -1102,7 +1109,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) else ! This next block should only ever be reached over land endif hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 + if (hsrc(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model @@ -1129,8 +1136,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) !call pass_var(mask_z,G%Domain) allocate( hsrc(nz_data) ) do c=1,CS%num_col_v - ! c is an index for the next 3 lines but a multiplier for the rest of the loop - ! Therefore we use c as per C code and increment the index where necessary. + ! Set i and j to the structured indices of column c. i = CS%col_i_v(c) ; j = CS%col_j_v(c) if (mask_v(i,j,1) == 1.0) then do k=1,nz_data @@ -1150,7 +1156,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) else ! This next block should only ever be reached over land endif hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k)>0.) nPoints = nPoints + 1 + if (hsrc(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model From d7d1351b4e9d90d19a13297a8e810f81cd7b3635 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 6 Jan 2023 13:42:31 -0500 Subject: [PATCH 140/629] Standardize the output of tiny real values Added code to harmonize differences in how different compilers format the output of tiny (< 1e-99) or huge (>= 1e100) real values. All answers are bitwise identical, but output could change with the PGI compiler for any cases that are writing out such extreme values. --- src/framework/MOM_document.F90 | 30 ++++++++++++++++++++++-------- 1 file changed, 22 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_document.F90 b/src/framework/MOM_document.F90 index a68a725feb..f32573815f 100644 --- a/src/framework/MOM_document.F90 +++ b/src/framework/MOM_document.F90 @@ -637,19 +637,33 @@ function real_string(val) elseif (val == 0.) then real_string = "0.0" else - if ((abs(val) <= 1.0e-100) .or. (abs(val) >= 1.0e100)) then - write(real_string(1:32), '(ES24.14E3)') val - if (.not.testFormattedFloatIsReal(real_string,val)) & - write(real_string(1:32), '(ES24.15E3)') val + if ((abs(val) < 1.0e-99) .or. (abs(val) >= 1.0e100)) then + write(real_string(1:32), '(ES24.14E4)') val + if (scan(real_string, "eE") == 0) then ! Fix a bug with a missing E in PGI formatting + ind = scan(real_string, "-+", back=.true.) + if (ind > index(real_string, ".") ) & ! Avoid changing a leading sign. + real_string = real_string(1:ind-1)//"E"//real_string(ind:) + endif + if (.not.testFormattedFloatIsReal(real_string, val)) then + write(real_string(1:32), '(ES25.15E4)') val + if (scan(real_string, "eE") == 0) then ! Fix a bug with a missing E in PGI formatting + ind = scan(real_string, "-+", back=.true.) + if (ind > index(real_string, ".") ) & ! Avoid changing a leading sign. + real_string = real_string(1:ind-1)//"E"//real_string(ind:) + endif + endif + ! Remove a leading 0 from the exponent, if it is there. + ind = max(index(real_string, "E+0"), index(real_string, "E-0")) + if (ind > 0) real_string = real_string(1:ind+1)//real_string(ind+3:) else write(real_string(1:32), '(ES23.14)') val - if (.not.testFormattedFloatIsReal(real_string,val)) & + if (.not.testFormattedFloatIsReal(real_string, val)) & write(real_string(1:32), '(ES23.15)') val endif - do - ind = index(real_string,"0E") + do ! Remove extra trailing 0s before the exponent. + ind = index(real_string, "0E") if (ind == 0) exit - if (real_string(ind-1:ind-1) == ".") exit + if (real_string(ind-1:ind-1) == ".") exit ! Leave at least one digit after the decimal point. real_string = real_string(1:ind-1)//real_string(ind+1:) enddo endif From ca72fcc860b1812c803114eec5153fb05082ab97 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 23 Dec 2022 04:48:15 -0500 Subject: [PATCH 141/629] *+Use runtime params in adjustment_initialization This commit replaces previously hard-coded values for dRho_dS and the temperature range for the sloshing test case with values read in from the existing runtime parameters DRHO_DS and the previously unused parameter T_RANGE that was already being read in for this configuration. The default value for dRho_dS from the EOS code (0.8 kg m-3 ppt-1) does not match hard coded value here (1 kg m-3 ppt-1), but in the existing tests using adjustment_initialization DRHO_DS was being explicitly set to the hard-coded value here, so I have chosen to reuse the same parameter with the same default value as is used elsewhere even though it could change answers in cases that do not set DRHO_DS consistently with the previous hard coded parameter. In addition, the previous default value for T_RANGE read into this module (0 degC) did not match the hard-coded range that was being used (1 degC). In this case I have chosen to change the default value for T_RANGE in this module so that by default this will reproduce the previous answers. As a result, there will be changes in the MOM_parameter doc all files for cases (like adjustment2d) that use the adjustment_initialization routines. This commit will change answers in some cases, but in the existing adjustment2d test cases in the MOM6-examples test suite, the answers are bitwise identical without any changes to the existing input parameter files. --- src/user/adjustment_initialization.F90 | 28 ++++++++++++++------------ 1 file changed, 15 insertions(+), 13 deletions(-) diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 92a7faf29e..a958ebdebb 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -4,15 +4,15 @@ module adjustment_initialization ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, is_root_pe -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_get_input, only : directories -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_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE -use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR -use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_get_input, only : directories +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_consts, only : coordinateMode, DEFAULT_COORDINATE_MODE +use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR +use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA implicit none ; private @@ -79,6 +79,9 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity with a linear equation of state.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) ! Parameters specific to this experiment configuration call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & @@ -117,7 +120,6 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER, REGRIDDING_RHO ) - dRho_dS = 1.0*US%kg_m3_to_R*US%S_to_ppt if (delta_S_strat /= 0.) then ! This was previously coded ambiguously. adjustment_delta = (adjustment_deltaS / delta_S_strat) * G%max_depth @@ -243,7 +245,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range', & default=2.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - default=0.0, units='C', scale=US%degC_to_C, do_not_log=just_read) + default=1.0, units='degC', scale=US%degC_to_C, do_not_log=just_read) ! Parameters specific to this experiment configuration BUT logged in previous s/r call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) @@ -292,7 +294,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, S(i,j,k) = S_ref + delta_S + 0.5 * ( eta1D(k)+eta1D(k+1) ) * dSdz x = abs(S(i,j,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) x = 1. - min(1., x) - T(i,j,k) = US%degC_to_C * x + T(i,j,k) = T_range * x enddo ! x = GV%H_to_Z*sum(T(i,j,:)*h(i,j,:)) ! T(i,j,:) = (T(i,j,:) / x) * (G%max_depth*1.5/real(nz)) @@ -303,7 +305,7 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, S(:,:,k) = S_ref + S_range * ( (real(k)-0.5) / real( nz ) ) ! x = abs(S(1,1,k) - 0.5*real(nz-1)/real(nz)*S_range)/S_range*real(2*nz) ! x = 1.-min(1., x) - ! T(:,:,k) = x + ! T(:,:,k) = T_range * x enddo case default From b3633f5932d135e8e1cfe815376a70997ca6c0ec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Jan 2023 07:27:47 -0500 Subject: [PATCH 142/629] Remove La_SL from wave_parameters_CS Removed the unused element La_SL from the wave_parameters_CS. Also added or renamed a few internal variables or amended the comments describing them to clarify what the code is doing. All answers are bitwise identical. --- src/user/MOM_wave_interface.F90 | 129 +++++++++++++++----------------- 1 file changed, 61 insertions(+), 68 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 70c0b4c71f..f0cbfd4e10 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -107,24 +107,24 @@ module MOM_wave_interface !! 2 - DHH85 !! 3 - LF17 !! -99 - No waves computed, but empirical Langmuir number used. - logical :: LagrangianMixing !< This feature is in development and not ready - !! True if Stokes drift is present and mixing - !! should be applied to Lagrangian current - !! (mean current + Stokes drift). - !! See Reichl et al., 2016 KPP-LT approach - logical :: StokesMixing !< This feature is in development and not ready. - !! True if vertical mixing of momentum - !! should be applied directly to Stokes current - !! (with separate mixing parameter for Eulerian - !! mixing contribution). - !! See Harcourt 2013, 2015 Second-Moment approach - logical :: CoriolisStokes !< This feature is in development and not ready. - ! True if Coriolis-Stokes acceleration should be applied. - integer :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points - !! or layer averaged. Set to 0 if mid-point and set to - !! 1 if average value of Stokes drift over level. - !! If advecting with Stokes transport, 1 is the correct - !! approach. + logical :: LagrangianMixing !< This feature is in development and not ready + !! True if Stokes drift is present and mixing + !! should be applied to Lagrangian current + !! (mean current + Stokes drift). + !! See Reichl et al., 2016 KPP-LT approach + logical :: StokesMixing !< This feature is in development and not ready. + !! True if vertical mixing of momentum + !! should be applied directly to Stokes current + !! (with separate mixing parameter for Eulerian + !! mixing contribution). + !! See Harcourt 2013, 2015 Second-Moment approach + logical :: CoriolisStokes !< This feature is in development and not ready. + ! True if Coriolis-Stokes acceleration should be applied. + integer :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points + !! or layer averaged. Set to 0 if mid-point and set to + !! 1 if average value of Stokes drift over level. + !! If advecting with Stokes transport, 1 is the correct + !! approach. ! Options if WaveMethod is Surface Stokes Drift Bands (1) integer :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers @@ -159,10 +159,7 @@ module MOM_wave_interface PrescribedSurfStkX !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] real, allocatable, dimension(:) :: & PrescribedSurfStkY !< Surface Stokes drift if prescribed [L T-1 ~> m s-1] - !### It appears that La_SL is never used. Can it be removed? real, allocatable, dimension(:,:) :: & - La_SL, & !< SL Langmuir number (directionality factored later) [nondim] - !! Horizontal -> H points La_Turb !< Aligned Turbulent Langmuir number [nondim] !! Horizontal -> H points real, allocatable, dimension(:,:) :: & @@ -180,12 +177,11 @@ module MOM_wave_interface !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - !> An arbitrary lower-bound on the Langmuir number [nondim]. Run-time parameter. - !! Langmuir number is sqrt(u_star/u_stokes). When both are small - !! but u_star is orders of magnitude smaller the Langmuir number could - !! have unintended consequences. Since both are small it can be safely capped - !! to avoid such consequences. - real :: La_min = 0.05 + real :: La_min = 0.05 !< An arbitrary lower-bound on the Langmuir number [nondim]. + !! Langmuir number is sqrt(u_star/u_stokes). When both are small + !! but u_star is orders of magnitude smaller, the Langmuir number could + !! have unintended consequences. Since both are small it can be safely + !! capped to avoid such consequences. ! Parameters used in estimating the wind speed or wave properties from the friction velocity real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] @@ -274,7 +270,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar "If true, enables surface wave modules.", default=.false.) ! Check if using LA_LI2016 - call get_param(param_file,mdl,"USE_LA_LI2016",StatisticalWaves, & + call get_param(param_file, mdl, "USE_LA_LI2016", StatisticalWaves, & do_not_log=.true.,default=.false.) if (.not.(use_waves .or. StatisticalWaves)) return @@ -491,7 +487,6 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar allocate(CS%US0_x(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) allocate(CS%US0_y(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) ! c. Langmuir number - allocate(CS%La_SL(G%isc:G%iec,G%jsc:G%jec), source=0.0) allocate(CS%La_turb(G%isc:G%iec,G%jsc:G%jec), source=0.0) ! d. Viscosity for Stokes drift if (CS%StokesMixing) then @@ -676,13 +671,12 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) real :: PI ! 3.1415926535... [nondim] real :: La ! The local Langmuir number [nondim] integer :: ii, jj, kk, b, iim1, jjm1 - real :: idt ! 1 divided by the time step [T-1 ~> s-1] + real :: I_dt ! The inverse of the time step [T-1 ~> s-1] if (CS%WaveMethod==EFACTOR) return ! The following thickness cut-off would not be needed with the refactoring marked with '###' below. min_level_thick_avg = 1.e-3*US%m_to_Z - idt = 1.0/dt if (allocated(CS%US_x) .and. allocated(CS%US_y)) then call pass_vector(CS%US_x(:,:,:),CS%US_y(:,:,:), G%Domain) @@ -747,7 +741,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! -> Stokes drift in thin layers not averaged. if (level_thick>min_level_thick_avg) then do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) @@ -767,8 +761,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC enddo - else - ! Take the value at the midpoint + else ! Take the value at the midpoint do b = 1,CS%NumBands if (CS%PartitionMode==0) then CMN_FAC = exp(MidPoint * 2. * CS%WaveNum_Cen(b)) @@ -781,6 +774,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) enddo enddo enddo + ! Computing Y direction Stokes drift do JJ = G%jscB,G%jecB do ii = G%isc,G%iec @@ -799,17 +793,17 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! -> Stokes drift in thin layers not averaged. if (level_thick>min_level_thick_avg) then do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) !### For accuracy and numerical stability rewrite this as: ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif (CS%PartitionMode==1) then - if (CS%StkLevelMode==0) then + elseif (CS%PartitionMode == 1) then + if (CS%StkLevelMode == 0) then ! Take the value at the midpoint CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif (CS%StkLevelMode==1) then + elseif (CS%StkLevelMode == 1) then ! Use a numerical integration and then divide by layer thickness WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) @@ -819,8 +813,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC enddo - else - ! Take the value at the midpoint + else ! Take the value at the midpoint do b = 1,CS%NumBands if (CS%PartitionMode==0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) @@ -910,8 +903,9 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! Finding tendency of Stokes drift over the time step to apply ! as an acceleration to the models current. if ( dynamics_step .and. CS%Stokes_DDT ) then - CS%ddt_us_x(:,:,:) = (CS%US_x(:,:,:) - CS%US_x_prev(:,:,:)) * idt - CS%ddt_us_y(:,:,:) = (CS%US_y(:,:,:) - CS%US_y_prev(:,:,:)) * idt + I_dt = 1.0 / dt + CS%ddt_us_x(:,:,:) = (CS%US_x(:,:,:) - CS%US_x_prev(:,:,:)) * I_dt + CS%ddt_us_y(:,:,:) = (CS%US_y(:,:,:) - CS%US_y_prev(:,:,:)) * I_dt CS%US_x_prev(:,:,:) = CS%US_x(:,:,:) CS%US_y_prev(:,:,:) = CS%US_y(:,:,:) endif @@ -1159,17 +1153,14 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & call get_StokesSL_LiFoxKemper(ustar, hbl*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) elseif (Waves%WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& - "Suggest to make sure USE_LT is set/overridden to False or "//& - "choose a wave method (or set USE_LA_LI2016 to use statistical "//& - "waves.") + "Suggest to make sure USE_LT is set/overridden to False or choose "//& + "a wave method (or set USE_LA_LI2016 to use statistical waves).") endif if (.not.(Waves%WaveMethod==LF17)) then - ! This is an arbitrary lower bound on Langmuir number. - ! We shouldn't expect values lower than this, but - ! there is also no good reason to cap it here other then - ! to prevent large enhancements in unconstrained parts of - ! the curve fit parameterizations. + ! This expression uses an arbitrary lower bound on Langmuir number. + ! We shouldn't expect values lower than this, but there is also no good reason to cap it here + ! other than to prevent large enhancements in unconstrained parts of the curve fit parameterizations. ! Note the dimensional constant background Stokes velocity of 10^-10 m s-1. LA = max(Waves%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + 1.e-10*US%m_s_to_L_T))) endif @@ -1282,21 +1273,21 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! the general peak wavenumber for Phillips' spectrum ! (Breivik et al., 2016) with correction of directional spreading kphil = 0.176 * UStokes / vstokes - ! - ! surface layer averaged Stokes drift with Stokes drift profile - ! estimated from Phillips' spectrum (Breivik et al., 2016) - ! the directional spreading effect from Webb and Fox-Kemper, 2015 - ! is also included - kstar = kphil * 2.56 + + ! Combining all of the expressions above gives kPhil as the following + ! where the first two lines are just a constant: + ! kphil = ((0.176 * us_to_u10 * u19p5_to_u10) / & + ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * CS%SWH_from_u10sq**2)) / & + ! (GV%g_Earth * u10**2) + ! surface layer z0 = abs(hbl) z0i = 1.0 / z0 - ! Combining all of the expressions above gives kPhil as the following - ! where the first two lines are just a constant: - ! kPhil = ((0.176 * us_to_u10 * u19p5_to_u10) / & - ! (0.5*0.125 * r_loss * fm_into_fp * 0.877 * 0.0246**2)) * & - ! (US%T_to_s*US%m_s_to_L_T)**2 / (CS%g_Earth * u10**2) + ! Surface layer averaged Stokes drift with Stokes drift profile + ! estimated from Phillips' spectrum (Breivik et al., 2016) + ! The directional spreading effect from Webb and Fox-Kemper, 2015 is also included. + kstar = kphil * 2.56 ! Terms 1 to 4, as written in the appendix of Li et al. (2017) r1 = ( 0.151 / kphil * z0i - 0.84 ) * & @@ -1861,9 +1852,11 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) ! Local variables real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] + real :: ten_m_scale ! The 10 m reference height, in rescaled units [Z ~> m] real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] - real :: alpha ! A nondimensional factor in a parameterization [nondim] - real :: CD ! The drag coefficient [nondim] + real :: alpha ! The Charnock coeffient relating the wind friction velocity squared to the + ! roughness length [nondim] + real :: Cd2 ! The square of the drag coefficient [nondim] integer :: CT ! Uses empirical formula for z0 to convert ustar_air to u10 based on the @@ -1876,10 +1869,11 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) "ust_2_u10_coare3p5 called with a negative value of Waves%vonKar") z0sm = 0.11 * CS%nu_air / USTair ! Compute z0smooth from ustar guess - u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 - !### For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. + u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 + !### For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . + ten_m_scale = 10.0*US%m_to_Z CT=0 do while (abs(u10a/u10 - 1.) > 0.001) !### Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. CT=CT+1 @@ -1887,8 +1881,8 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) alpha = min(0.028, 0.0017*US%L_T_to_m_s * u10 - 0.005) z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess z0 = z0sm + z0rough - CD = ( CS%vonKar / log(10.*US%m_to_Z / z0) )**2 ! Compute CD from derived roughness - u10 = US%Z_to_L*USTair/sqrt(CD) ! Compute new u10 from derived CD, while loop + Cd2 = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute CD from derived roughness + u10 = US%Z_to_L*USTair/sqrt(Cd2) ! Compute new u10 from derived CD, while loop ! ends and checks for convergence...CT counter ! makes sure loop doesn't run away if function ! doesn't converge. This code was produced offline @@ -1911,7 +1905,6 @@ subroutine Waves_end(CS) if (allocated(CS%Freq_Cen)) deallocate( CS%Freq_Cen ) if (allocated(CS%Us_x)) deallocate( CS%Us_x ) if (allocated(CS%Us_y)) deallocate( CS%Us_y ) - if (allocated(CS%La_SL)) deallocate( CS%La_SL ) if (allocated(CS%La_turb)) deallocate( CS%La_turb ) if (allocated(CS%STKx0)) deallocate( CS%STKx0 ) if (allocated(CS%STKy0)) deallocate( CS%STKy0 ) From 8201db4c9d2743d80b0149b17628d0223e0dd4c5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Jan 2023 07:46:04 -0500 Subject: [PATCH 143/629] +Add 3 Charnock coefficient runtime parameters Add 3 runtime parameters (CHARNOCK_MIN, CHARNOCK_SLOPE_U10 and CHARNOCK_0_WIND_INTERCEPT) to specify the curve fit in the Charnock coefficient calculation. By default all answers are bitwise identical, but there are 3 new runtime parameters in some MOM_parameter_doc.all files. --- src/user/MOM_wave_interface.F90 | 27 ++++++++++++++++++++++++++- 1 file changed, 26 insertions(+), 1 deletion(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index f0cbfd4e10..f55308358c 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -189,6 +189,16 @@ module MOM_wave_interface real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the !! significant wave height [Z T2 L-2 ~> s m-2] + real :: Charnock_min !< The minimum value of the Charnock coefficient, which relates the square of + !! the air friction velocity divided by the gravitational acceleration to the + !! wave roughness length [nondim] + real :: Charnock_slope_U10 !< The partial derivative of the Charnock coefficient with the 10 m wind + !! speed [T L-1 ~> s m-1]. Note that in eq. 13 of the Edson et al. 2013 describing + !! the COARE 3.5 bulk flux algorithm, this slope is given as 0.017. However, 0.0017 + !! reproduces the curve in their figure 6, so that is the default value used in MOM6. + real :: Charnock_intercept !< The intercept of the fit for the Charnock coefficient in the limit of + !! no wind [nondim]. Note that this can be negative because CHARNOCK_MIN will keep + !! the final value for the Charnock coefficient from being from being negative. ! Options used with the test profile real :: TP_STKX0 !< Test profile x-stokes drift amplitude [L T-1 ~> m s-1] @@ -550,6 +560,21 @@ subroutine set_LF17_wave_params(param_file, mdl, US, CS) "A factor relating the square of the 10 m wind speed to the significant "//& "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & units="s m-2", default=0.0246, scale=US%m_to_Z*US%L_T_to_m_s**2) + call get_param(param_file, mdl, "CHARNOCK_MIN", CS%Charnock_min, & + "The minimum value of the Charnock coefficient, which relates the square of "//& + "the air friction velocity divided by the gravitational acceleration to the "//& + "wave roughness length.", units="nondim", default=0.028) + call get_param(param_file, mdl, "CHARNOCK_SLOPE_U10", CS%Charnock_slope_U10, & + "The partial derivative of the Charnock coefficient with the 10 m wind speed. "//& + "Note that in eq. 13 of the Edson et al. 2013 describing the COARE 3.5 bulk "//& + "flux algorithm, this slope is given as 0.017. However, 0.0017 reproduces "//& + "the curve in their figure 6, so that is the default value used in MOM6.", & + units="s m-1", default=0.0017, scale=US%L_T_to_m_s) + call get_param(param_file, mdl, "CHARNOCK_0_WIND_INTERCEPT", CS%Charnock_intercept, & + "The intercept of the fit for the Charnock coefficient in the limit of no wind. "//& + "Note that this can be negative because CHARNOCK_MIN will keep the final "//& + "value for the Charnock coefficient from being from being negative.", & + units="nondim", default=-0.005) end subroutine set_LF17_wave_params @@ -1878,7 +1903,7 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) do while (abs(u10a/u10 - 1.) > 0.001) !### Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. CT=CT+1 u10a = u10 - alpha = min(0.028, 0.0017*US%L_T_to_m_s * u10 - 0.005) + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess z0 = z0sm + z0rough Cd2 = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute CD from derived roughness From cfc2ed99c1eaf0f281a90a16caccc9889f388237 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Jan 2023 08:15:18 -0500 Subject: [PATCH 144/629] +Add LANGMUIR_STOKES_BACKGROUND runtime parameter Added three new runtime parameters (LANGMUIR_STOKES_BACKGROUND, SURFBAND_MIN_THICK_AVG and SURFBAND_OVERRIDE_LAND_SPEED) to replace previously hard-coded dimensional parameter in the Langmuir number and Stokes drift calculations. By default all answers are bitwise identical, but there are new runtime parameters in some MOM_parameter_doc.all files. --- src/user/MOM_wave_interface.F90 | 36 ++++++++++++++++++++++++--------- 1 file changed, 26 insertions(+), 10 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index f55308358c..cfa409068d 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -125,6 +125,9 @@ module MOM_wave_interface !! 1 if average value of Stokes drift over level. !! If advecting with Stokes transport, 1 is the correct !! approach. + real :: Stokes_min_thick_avg !< A layer thickness below which the cell-center Stokes drift is + !! used instead of the cell average [Z ~> m]. This is only used if + !! WAVE_INTERFACE_ANSWER_DATE < 20230101. ! Options if WaveMethod is Surface Stokes Drift Bands (1) integer :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers @@ -137,6 +140,9 @@ module MOM_wave_interface ! Options if using FMS DataOverride Routine character(len=40) :: SurfBandFileName !< Filename if using DataOverride + real :: land_speed !< A large Stokes velocity that can be used to indicate land values in + !! a data override file [L T-1 ~> m s-1]. Stokes drift components larger + !! than this are set to zero in data override calls for the Stokes drift. logical :: DataOver_initialized !< Flag for DataOverride Initialization ! Options for computing Langmuir number @@ -177,11 +183,13 @@ module MOM_wave_interface !! Horizontal -> V points !! 3rd dimension -> Freq/Wavenumber - real :: La_min = 0.05 !< An arbitrary lower-bound on the Langmuir number [nondim]. + real :: La_min !< An arbitrary lower-bound on the Langmuir number [nondim]. !! Langmuir number is sqrt(u_star/u_stokes). When both are small !! but u_star is orders of magnitude smaller, the Langmuir number could !! have unintended consequences. Since both are small it can be safely !! capped to avoid such consequences. + real :: La_Stk_backgnd !< A small background Stokes velocity used in the denominator of + !! some expressions for the Langmuir number [L T-1 ~> m s-1] ! Parameters used in estimating the wind speed or wave properties from the friction velocity real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] @@ -390,6 +398,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar units='m', default=50.0, scale=US%m_to_Z) case (SURFBANDS_STRING)! Surface Stokes Drift Bands CS%WaveMethod = SURFBANDS + call get_param(param_file, mdl, "SURFBAND_MIN_THICK_AVG", CS%Stokes_min_thick_avg, & + "A layer thickness below which the cell-center Stokes drift is used instead of "//& + "the cell average. This is only used if WAVE_INTERFACE_ANSWER_DATE < 20230101.", & + units="m", default=0.1, scale=US%m_to_Z) !, do_not_log=(CS%answer_date>=20230101)) call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"//& " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& @@ -403,6 +415,11 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar CS%DataSource = DATAOVR call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, & "Filename of surface Stokes drift input band data.", default="StkSpec.nc") + call get_param(param_file, mdl, "SURFBAND_OVERRIDE_LAND_SPEED", CS%land_speed, & + "A large Stokes velocity that can be used to indicate land values in "//& + "a data override file. Stokes drift components larger than this are "//& + "set to zero in data override calls for the Stokes drift.", & + units="m s-1", default=10.0, scale=US%m_s_to_L_T) case (COUPLER_STRING)! Reserved for coupling CS%DataSource = COUPLER ! This is just to make something work, but it needs to be read from the wavemodel. @@ -480,6 +497,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar "but is likely only encountered when the wind is very small and "//& "therefore its effects should be mostly benign.", & units="nondim", default=0.05) + call get_param(param_file, mdl, "LANGMUIR_STOKES_BACKGROUND", CS%La_Stk_backgnd, & + "A small background Stokes velocity used in the denominator of some "//& + "expressions for the Langmuir number.", & + units="m s-1", default=1.0e-10, scale=US%m_s_to_L_T, do_not_log=(CS%WaveMethod==LF17)) ! Allocate and initialize ! a. Stokes driftProfiles @@ -688,7 +709,6 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! Local Variables real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] real :: level_thick ! The thickness of each layer [Z ~> m] - real :: min_level_thick_avg ! A minimum layer thickness for inclusion in the average [Z ~> m] real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] real :: CMN_FAC ! A nondimensional factor [nondim] real :: WN ! Model wavenumber [Z-1 ~> m-1] @@ -700,9 +720,6 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) if (CS%WaveMethod==EFACTOR) return - ! The following thickness cut-off would not be needed with the refactoring marked with '###' below. - min_level_thick_avg = 1.e-3*US%m_to_Z - if (allocated(CS%US_x) .and. allocated(CS%US_y)) then call pass_vector(CS%US_x(:,:,:),CS%US_y(:,:,:), G%Domain) endif @@ -764,7 +781,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick ! -> Stokes drift in thin layers not averaged. - if (level_thick>min_level_thick_avg) then + if (level_thick > CS%Stokes_min_thick_avg) then do b = 1,CS%NumBands if (CS%PartitionMode == 0) then ! In wavenumber we are averaging over level @@ -816,7 +833,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick ! -> Stokes drift in thin layers not averaged. - if (level_thick>min_level_thick_avg) then + if (level_thick > CS%Stokes_min_thick_avg) then do b = 1,CS%NumBands if (CS%PartitionMode == 0) then ! In wavenumber we are averaging over level @@ -1060,7 +1077,7 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) ! Filter land values do j = G%jsd,G%jed do i = G%Isd,G%Ied - if ((abs(temp_x(i,j)) > 10.0*US%m_s_to_L_T) .or. (abs(temp_y(i,j)) > 10.0*US%m_s_to_L_T)) then + if ((abs(temp_x(i,j)) > CS%land_speed) .or. (abs(temp_y(i,j)) > CS%land_speed)) then ! Assume land-mask and zero out temp_x(i,j) = 0.0 temp_y(i,j) = 0.0 @@ -1186,8 +1203,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & ! This expression uses an arbitrary lower bound on Langmuir number. ! We shouldn't expect values lower than this, but there is also no good reason to cap it here ! other than to prevent large enhancements in unconstrained parts of the curve fit parameterizations. - ! Note the dimensional constant background Stokes velocity of 10^-10 m s-1. - LA = max(Waves%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + 1.e-10*US%m_s_to_L_T))) + LA = max(Waves%La_min, sqrt(US%Z_to_L*ustar / (LA_STK + Waves%La_Stk_backgnd))) endif if (Use_MA) then From 85fffee7d5dbb4874f48a033c34dc4c21ebf632c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Jan 2023 09:06:39 -0500 Subject: [PATCH 145/629] +Add WAVE_INTERFACE_ANSWER_DATE runtime parameter Added the new runtime parameter WAVE_INTERFACE_ANSWER_DATE, with a default value that is temporarily set to use the previous answers. This is used to select a more efficient option in ust_2_u10_coare3p5. The answers with this new option differ at roundoff, but are otherwise very similar. By default all answers are bitwise identical, but there is a new runtime parameters in some MOM_parameter_doc.all files. --- src/user/MOM_wave_interface.F90 | 86 ++++++++++++++++++++++++--------- 1 file changed, 64 insertions(+), 22 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index cfa409068d..8b95c54199 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -128,6 +128,11 @@ module MOM_wave_interface real :: Stokes_min_thick_avg !< A layer thickness below which the cell-center Stokes drift is !! used instead of the cell average [Z ~> m]. This is only used if !! WAVE_INTERFACE_ANSWER_DATE < 20230101. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! surface wave calculations. Values below 20230101 recover the + !! answers from the end of 2022, while higher values use updated + !! and more robust forms of the same expressions. + ! Options if WaveMethod is Surface Stokes Drift Bands (1) integer :: PartitionMode !< Method for partition mode (meant to check input) !! 0 - wavenumbers @@ -156,6 +161,8 @@ module MOM_wave_interface real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] + real :: I_g_Earth !< The inversse of the gravitational acceleration, with dimensional rescaling + !! appropriate for deep-water gravity waves [T2 Z-1 ~> s2 m-1] ! Surface Wave Dependent 1d/2d/3d vars real, allocatable, dimension(:) :: & WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] @@ -275,6 +282,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar character*(12), parameter :: DATAOVR_STRING = "DATAOVERRIDE" character*(7), parameter :: COUPLER_STRING = "COUPLER" character*(5), parameter :: INPUT_STRING = "INPUT" + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags logical :: use_waves logical :: StatisticalWaves @@ -298,12 +306,23 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar CS%Time => Time CS%g_Earth = US%L_to_Z**2*GV%g_Earth + CS%I_g_Earth = 1.0 / CS%g_Earth ! Add any initializations needed here CS%DataOver_initialized = .false. call log_version(param_file, mdl, version) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + + call get_param(param_file, mdl, "WAVE_INTERFACE_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the surface wave "//& + "calculations. Values below 20230101 recover the answers from the end of 2022, "//& + "while higher values use updated and more robust forms of the same expressions.", & + default=20221232) !### default=default_answer_date) + ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & "The depth (normalized by BLD) to average Stokes drift over in "//& @@ -1894,10 +1913,13 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) ! Local variables real :: z0sm, z0, z0rough ! Roughness lengths [Z ~> m] real :: ten_m_scale ! The 10 m reference height, in rescaled units [Z ~> m] + real :: I_ten_m_scale ! The inverse of the 10 m reference height, in rescaled units [Z-1 ~> m-1] real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] real :: alpha ! The Charnock coeffient relating the wind friction velocity squared to the ! roughness length [nondim] real :: Cd2 ! The square of the drag coefficient [nondim] + real :: I_Cd ! The inverse of the drag coefficient [nondim] + real :: I_vonKar ! The inverse of the von Karman coefficient [nondim] integer :: CT ! Uses empirical formula for z0 to convert ustar_air to u10 based on the @@ -1912,29 +1934,49 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) z0sm = 0.11 * CS%nu_air / USTair ! Compute z0smooth from ustar guess u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. - u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 - !### For efficiency change the line above to USTair * sqrt(1000.0) or USTair * 31.6227766 . + if (CS%answer_date < 20230101) then + u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 ten_m_scale = 10.0*US%m_to_Z - CT=0 - do while (abs(u10a/u10 - 1.) > 0.001) !### Change this to (abs(u10a - u10) > 0.001*u10) for efficiency. - CT=CT+1 - u10a = u10 - alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) - z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess - z0 = z0sm + z0rough - Cd2 = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute CD from derived roughness - u10 = US%Z_to_L*USTair/sqrt(Cd2) ! Compute new u10 from derived CD, while loop - ! ends and checks for convergence...CT counter - ! makes sure loop doesn't run away if function - ! doesn't converge. This code was produced offline - ! and converged rapidly (e.g. 2 cycles) - ! for ustar=0.0001:0.0001:10. - if (CT>20) then - u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just - ! in case it will output a reasonable value. - exit - endif - enddo + CT=0 + do while (abs(u10a/u10 - 1.) > 0.001) + CT=CT+1 + u10a = u10 + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) + z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess + z0 = z0sm + z0rough + Cd2 = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute CD from derived roughness + u10 = US%Z_to_L*USTair/sqrt(Cd2) ! Compute new u10 from derived CD, while loop + ! ends and checks for convergence...CT counter + ! makes sure loop doesn't run away if function + ! doesn't converge. This code was produced offline + ! and converged rapidly (e.g. 2 cycles) + ! for ustar=0.0001:0.0001:10. + if (CT>20) then + u10 = US%Z_to_L*USTair/sqrt(0.0015) ! I don't expect to get here, but just + ! in case it will output a reasonable value. + exit + endif + enddo + + else ! Use more efficient expressions that are mathematically equivalent to those above. + u10 = US%Z_to_L*USTair * sqrt(1000.0) ! Guess for u10. Is 1000 here the ratio of the densities of water and air? + I_vonKar = 1.0 / CS%vonKar + I_ten_m_scale = 0.1*US%Z_to_m + + do CT=1,20 + if (abs(u10a - u10) <= 0.001*u10) exit ! Check for convergence. + u10a = u10 + alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) + z0rough = alpha * (CS%I_g_Earth * USTair**2) ! Compute z0rough from ustar guess + z0 = z0sm + z0rough + I_Cd = abs(log(z0 * I_ten_m_scale)) * I_vonKar ! Compute CD from derived roughness + u10 = US%Z_to_L*USTair * I_Cd ! Compute new u10 from the derived CD. + enddo + + ! Output a reasonable estimate of u10 if the iteration has not converged. The hard-coded + ! number 25.82 is 1/sqrt(0.0015) to 4 decimal places, but the exact value should not matter. + if (abs(u10a - u10) > 0.001*u10) u10 = US%Z_to_L*USTair * 25.82 + endif end subroutine ust_2_u10_coare3p5 From 504769246b6a014b5184f5ef81dc95980b05509f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Jan 2023 11:04:02 -0500 Subject: [PATCH 146/629] +Make get_StokesSL_LiFoxKemper more robust Modified get_StokesSL_LiFoxKemper to use more robust expressions when WAVE_INTERFACE_ANSWER_DATE >= 20230102, and reset the value to change the answers to ust_2_u10_coare3p5 when WAVE_INTERFACE_ANSWER_DATE >= 20230103. Both options have been tested independently, and give answers that are similar to but more robust than the previous expressions. By default all answers are bitwise identical, but there is a new use of the runtime parameter WAVE_INTERFACE_ANSWER_DATE. --- src/user/MOM_wave_interface.F90 | 89 ++++++++++++++++++--------------- 1 file changed, 48 insertions(+), 41 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 8b95c54199..ec92de329a 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -321,7 +321,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar "The vintage of the order of arithmetic and expressions in the surface wave "//& "calculations. Values below 20230101 recover the answers from the end of 2022, "//& "while higher values use updated and more robust forms of the same expressions.", & - default=20221232) !### default=default_answer_date) + default=20221231) !### default=default_answer_date) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & @@ -1298,9 +1298,9 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real :: z0 ! The boundary layer depth [Z ~> m] real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] - ! real :: r5 ! A single expression that combines r3 and r4 [nondim] - ! real :: root_2kz ! The square root of twice the peak wavenumber times the - ! ! boundary layer depth [nondim] + real :: r5 ! A single expression that combines r2 and r4 [nondim] + real :: root_2kz ! The square root of twice the peak wavenumber times the + ! boundary layer depth [nondim] real :: u10 ! The 10 m wind speed [L T-1 ~> m s-1] real :: PI ! 3.1415926535... [nondim] @@ -1342,48 +1342,55 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! surface layer z0 = abs(hbl) - z0i = 1.0 / z0 + + if (CS%answer_date < 20230102) then + z0i = 1.0 / z0 ! Surface layer averaged Stokes drift with Stokes drift profile ! estimated from Phillips' spectrum (Breivik et al., 2016) ! The directional spreading effect from Webb and Fox-Kemper, 2015 is also included. kstar = kphil * 2.56 - ! Terms 1 to 4, as written in the appendix of Li et al. (2017) - r1 = ( 0.151 / kphil * z0i - 0.84 ) * & - ( 1.0 - exp(-2.0 * kphil * z0) ) - r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & - sqrt( 2.0 * PI * kphil * z0 ) * & - erfc( sqrt( 2.0 * kphil * z0 ) ) - r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & - (1.0 - exp(-2.0 * kstar * z0) ) - r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & - sqrt( 2.0 * PI * kstar * z0) * & - erfc( sqrt( 2.0 * kstar * z0 ) ) - UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) - - ! The following is equivalent to the code above, but avoids singularities -! r1 = ( 0.302 - 1.68*kphil*z0 ) * one_minus_exp_x(2.0*kphil * z0) -! r3 = ( 0.1264 + 0.64*kphil*z0 ) * one_minus_exp_x(5.12*kphil * z0) -! root_2kz = sqrt(2.0 * kphil * z0) -! ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) -! ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI)* root_2kz * erfc( 1.6 * root_2kz ) -! -! ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): -! ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without -! ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . -! ! It has been verified that these two expressions for r5 are the same to 6 decimal places for -! ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. -! if (root_2kz > 1e-3) then -! r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & -! 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) -! else -! ! It is more accurate to replace erf with the first two terms of its Taylor series -! ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) -! ! and then cancel or combine common terms and drop negligibly small terms. -! r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) -! endif -! UStokes_sl = UStokes * (0.715 + ((r1 + r2) + r5)) + ! Terms 1 to 4, as written in the appendix of Li et al. (2017) + r1 = ( 0.151 / kphil * z0i - 0.84 ) * & + ( 1.0 - exp(-2.0 * kphil * z0) ) + r2 = -( 0.84 + 0.0591 / kphil * z0i ) * & + sqrt( 2.0 * PI * kphil * z0 ) * & + erfc( sqrt( 2.0 * kphil * z0 ) ) + r3 = ( 0.0632 / kstar * z0i + 0.125 ) * & + (1.0 - exp(-2.0 * kstar * z0) ) + r4 = ( 0.125 + 0.0946 / kstar * z0i ) * & + sqrt( 2.0 * PI * kstar * z0) * & + erfc( sqrt( 2.0 * kstar * z0 ) ) + UStokes_sl = UStokes * (0.715 + r1 + r2 + r3 + r4) + else + ! The following is equivalent to the code above, but avoids singularities + r1 = ( 0.302 - 1.68*(kphil*z0) ) * one_minus_exp_x(2.0 * (kphil * z0)) + r3 = ( 0.1264 + 0.64*(kphil*z0) ) * one_minus_exp_x(5.12 * (kphil * z0)) + + root_2kz = sqrt(2.0 * kphil * z0) + ! r2 = -( 0.84 + 0.0591 / (kphil * z0) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) + ! r4 = ( 0.2 + 0.059125 / (kphil * z0) ) * sqrt(PI) * root_2kz * erfc( 1.6 * root_2kz ) + + ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) + ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( 1.6 * root_2kz ) + + ! r5 = r2 + r4 (with a small correction to one coefficient to avoid a singularity when z0 = 0): + ! The correction leads to <1% relative differences in (r2+r4) for root_2kz > 0.05, but without + ! it the values of r2 + r4 are qualitatively wrong (>50% errors) for root_2kz < 0.0015 . + ! It has been verified that these two expressions for r5 are the same to 6 decimal places for + ! root_2kz between 1e-10 and 1e-3, but that the first one degrades for smaller values. + if (root_2kz > 1e-3) then + r5 = sqrt(PI) * (root_2kz * (-0.84 * erfc(root_2kz) + 0.2 * erfc(1.6*root_2kz)) + & + 0.1182 * (erfc(1.6*root_2kz) - erfc(root_2kz)) / root_2kz) + else + ! It is more accurate to replace erf with the first two terms of its Taylor series + ! erf(z) = (2/sqrt(pi)) * z * (1. - (1/3)*z**2 + (1/10)*z**4 - (1/42)*z**6 + ...) + ! and then cancel or combine common terms and drop negligibly small terms. + r5 = -0.64*sqrt(PI)*root_2kz + (-0.14184 + 1.0839648 * root_2kz**2) + endif + UStokes_sl = UStokes * (0.715 + ((r1 + r3) + r5)) + endif if (UStokes_sl /= 0.0) LA = sqrt(US%Z_to_L*ustar / UStokes_sl) endif @@ -1934,7 +1941,7 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) z0sm = 0.11 * CS%nu_air / USTair ! Compute z0smooth from ustar guess u10a = 1000.0*US%m_s_to_L_T ! An insanely large upper bound for u10. - if (CS%answer_date < 20230101) then + if (CS%answer_date < 20230103) then u10 = US%Z_to_L*USTair / sqrt(0.001) ! Guess for u10 ten_m_scale = 10.0*US%m_to_Z CT=0 From 60961661f29a3a4d42bf3d0525fdec36cfc5b90b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 1 Jan 2023 11:33:50 -0500 Subject: [PATCH 147/629] +Make Update_Stokes_Drift more robust Modified Update_Stokes_Drift to use more robust expressions when WAVE_INTERFACE_ANSWER_DATE >= 20230101. This new option may not be as fully tested as it should be, but it appears to give answers that are similar to but more robust than the previous expressions. By default all answers are bitwise identical, but there is a new use of the runtime parameter WAVE_INTERFACE_ANSWER_DATE. --- src/user/MOM_wave_interface.F90 | 96 ++++++++++++++++++++------------- 1 file changed, 58 insertions(+), 38 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index ec92de329a..745d529c1d 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -420,7 +420,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar call get_param(param_file, mdl, "SURFBAND_MIN_THICK_AVG", CS%Stokes_min_thick_avg, & "A layer thickness below which the cell-center Stokes drift is used instead of "//& "the cell average. This is only used if WAVE_INTERFACE_ANSWER_DATE < 20230101.", & - units="m", default=0.1, scale=US%m_to_Z) !, do_not_log=(CS%answer_date>=20230101)) + units="m", default=0.1, scale=US%m_to_Z, do_not_log=(CS%answer_date>=20230101)) call get_param(param_file, mdl, "SURFBAND_SOURCE", TMPSTRING2, & "Choice of SURFACE_BANDS data mode, valid options include: \n"//& " DATAOVERRIDE - Read from NetCDF using FMS DataOverride. \n"//& @@ -433,7 +433,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar case (DATAOVR_STRING)! Using Data Override CS%DataSource = DATAOVR call get_param(param_file, mdl, "SURFBAND_FILENAME", CS%SurfBandFileName, & - "Filename of surface Stokes drift input band data.", default="StkSpec.nc") + "Filename of surface Stokes drift input band data.", default="StkSpec.nc") call get_param(param_file, mdl, "SURFBAND_OVERRIDE_LAND_SPEED", CS%land_speed, & "A large Stokes velocity that can be used to indicate land values in "//& "a data override file. Stokes drift components larger than this are "//& @@ -799,26 +799,38 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick - ! -> Stokes drift in thin layers not averaged. - if (level_thick > CS%Stokes_min_thick_avg) then + + if (CS%answer_date >= 20230101) then + ! Use more accurate and numerically stable expressions that work even for vanished layers. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! Average over a layer using the bin's central wavenumber. + CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==0)) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint * 2. * (CS%Freq_Cen(b)**2 * CS%I_g_Earth)) + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==1)) then + ! Use an analytic expression for the average of an exponential over a layer + WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth + CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) + endif + CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + enddo + + elseif (level_thick > CS%Stokes_min_thick_avg) then + ! -> Stokes drift in thin layers not averaged. do b = 1,CS%NumBands if (CS%PartitionMode == 0) then ! In wavenumber we are averaging over level - CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif (CS%PartitionMode==1) then - if (CS%StkLevelMode==0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif (CS%StkLevelMode==1) then - ! Use a numerical integration and then divide by layer thickness - WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) - endif + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode == 0)) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==1)) then + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC enddo @@ -851,26 +863,37 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick - ! -> Stokes drift in thin layers not averaged. - if (level_thick > CS%Stokes_min_thick_avg) then + + if (CS%answer_date >= 20230101) then + ! Use more accurate and numerically stable expressions that work even for vanished layers. do b = 1,CS%NumBands if (CS%PartitionMode == 0) then - ! In wavenumber we are averaging over level - CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b)))& + ! Average over a layer using the bin's central wavenumber. + CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==0)) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint * 2. * (CS%Freq_Cen(b)**2 * CS%I_g_Earth)) + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==1)) then + ! Use an analytic expression for the average of an exponential over a layer + WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth + CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) + endif + CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + enddo + elseif (level_thick > CS%Stokes_min_thick_avg) then + ! -> Stokes drift in thin layers not averaged. + do b = 1,CS%NumBands + if (CS%PartitionMode == 0) then + ! In wavenumber we are averaging over level + CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif (CS%PartitionMode == 1) then - if (CS%StkLevelMode == 0) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif (CS%StkLevelMode == 1) then - ! Use a numerical integration and then divide by layer thickness - WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g - CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) - !### For accuracy and numerical stability rewrite this as: - ! CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) - endif + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode == 0)) then + ! Take the value at the midpoint + CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) + elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode == 1)) then + ! Use a numerical integration and then divide by layer thickness + WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g + CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC enddo @@ -1369,9 +1392,6 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) r3 = ( 0.1264 + 0.64*(kphil*z0) ) * one_minus_exp_x(5.12 * (kphil * z0)) root_2kz = sqrt(2.0 * kphil * z0) - ! r2 = -( 0.84 + 0.0591 / (kphil * z0) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) - ! r4 = ( 0.2 + 0.059125 / (kphil * z0) ) * sqrt(PI) * root_2kz * erfc( 1.6 * root_2kz ) - ! r2 = -( 0.84 + 0.0591*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( root_2kz ) ! r4 = ( 0.2 + 0.059125*2.0 / (root_2kz**2) ) * sqrt(PI) * root_2kz * erfc( 1.6 * root_2kz ) From 758c792e8c0a9450ad14ff6646c565ef51cef832 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 2 Jan 2023 06:17:59 -0500 Subject: [PATCH 148/629] +Eliminate wave_parameters_CS%StkLevelMode Eliminated the hard-coded wave_parameters_CS StkLevelMode element and associated code. Also modified the description of WAVE_INTERFACE_ANSWER_DATE to describe the meaning of its various settings. A handful of spelling errors were also corrected. All answers are bitwise identical, but there are changes to some MOM_parameter_doc files. --- src/user/MOM_wave_interface.F90 | 57 +++++++++++++-------------------- 1 file changed, 22 insertions(+), 35 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 745d529c1d..53cf2aea8c 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -120,11 +120,6 @@ module MOM_wave_interface !! See Harcourt 2013, 2015 Second-Moment approach logical :: CoriolisStokes !< This feature is in development and not ready. ! True if Coriolis-Stokes acceleration should be applied. - integer :: StkLevelMode=1 !< Sets if Stokes drift is defined at mid-points - !! or layer averaged. Set to 0 if mid-point and set to - !! 1 if average value of Stokes drift over level. - !! If advecting with Stokes transport, 1 is the correct - !! approach. real :: Stokes_min_thick_avg !< A layer thickness below which the cell-center Stokes drift is !! used instead of the cell average [Z ~> m]. This is only used if !! WAVE_INTERFACE_ANSWER_DATE < 20230101. @@ -161,7 +156,7 @@ module MOM_wave_interface real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] - real :: I_g_Earth !< The inversse of the gravitational acceleration, with dimensional rescaling + real :: I_g_Earth !< The inverse of the gravitational acceleration, with dimensional rescaling !! appropriate for deep-water gravity waves [T2 Z-1 ~> s2 m-1] ! Surface Wave Dependent 1d/2d/3d vars real, allocatable, dimension(:) :: & @@ -320,8 +315,12 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar call get_param(param_file, mdl, "WAVE_INTERFACE_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the surface wave "//& "calculations. Values below 20230101 recover the answers from the end of 2022, "//& - "while higher values use updated and more robust forms of the same expressions.", & - default=20221231) !### default=default_answer_date) + "while higher values use updated and more robust forms of the same expressions:\n"//& + "\t < 20230101 - Original answers for wave interface routines\n"//& + "\t >= 20230101 - More robust expressions for Update_Stokes_Drift\n"//& + "\t >= 20230102 - More robust expressions for get_StokesSL_LiFoxKemper\n"//& + "\t >= 20230103 - More robust expressions for ust_2_u10_coare3p5", & + default=20221231) ! In due course change the default to default=default_answer_date) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & @@ -509,7 +508,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar ! Langmuir number Options (Note that CS%LA_FracHBL is set above.) call get_param(param_file, mdl, "LA_MISALIGNMENT", CS%LA_Misalignment, & - "Flag (logical) if using misalignment bt shear and waves in LA", & + "Flag (logical) if using misalignment between shear and waves in LA", & default=.false.) call get_param(param_file, mdl, "MIN_LANGMUIR", CS%La_min, & "A minimum value for all Langmuir numbers that is not physical, "//& @@ -806,10 +805,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) if (CS%PartitionMode == 0) then ! Average over a layer using the bin's central wavenumber. CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==0)) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * (CS%Freq_Cen(b)**2 * CS%I_g_Earth)) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==1)) then + else ! Use an analytic expression for the average of an exponential over a layer WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) @@ -824,10 +820,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode == 0)) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==1)) then + else ! Use a numerical integration and then divide by layer thickness WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) @@ -836,9 +829,9 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) enddo else ! Take the value at the midpoint do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then CMN_FAC = exp(MidPoint * 2. * CS%WaveNum_Cen(b)) - elseif (CS%PartitionMode==1) then + else CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC @@ -870,10 +863,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) if (CS%PartitionMode == 0) then ! Average over a layer using the bin's central wavenumber. CMN_FAC = exp(2.*CS%WaveNum_Cen(b)*Top) * one_minus_exp_x(2.*CS%WaveNum_Cen(b)*level_thick) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==0)) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * (CS%Freq_Cen(b)**2 * CS%I_g_Earth)) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode==1)) then + else ! Use an analytic expression for the average of an exponential over a layer WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) @@ -887,10 +877,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! In wavenumber we are averaging over level CMN_FAC = (exp(Top*2.*CS%WaveNum_Cen(b))-exp(Bottom*2.*CS%WaveNum_Cen(b))) & / ((Top-Bottom)*(2.*CS%WaveNum_Cen(b))) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode == 0)) then - ! Take the value at the midpoint - CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) - elseif ((CS%PartitionMode == 1) .and. (CS%StkLevelMode == 1)) then + else ! Use a numerical integration and then divide by layer thickness WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) @@ -899,9 +886,9 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) enddo else ! Take the value at the midpoint do b = 1,CS%NumBands - if (CS%PartitionMode==0) then + if (CS%PartitionMode == 0) then CMN_FAC = exp(MidPoint*2.*CS%WaveNum_Cen(b)) - elseif (CS%PartitionMode==1) then + else CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC @@ -1041,7 +1028,7 @@ subroutine Surface_Bands_by_data_override(Time, G, GV, US, CS) ! Local variables real :: temp_x(SZI_(G),SZJ_(G)) ! Pseudo-zonal Stokes drift of band at h-points [L T-1 ~> m s-1] - real :: temp_y(SZI_(G),SZJ_(G)) ! Psuedo-meridional Stokes drift of band at h-points [L T-1 ~> m s-1] + real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional Stokes drift of band at h-points [L T-1 ~> m s-1] integer, dimension(4) :: sizes ! The sizes of the various dimensions of the variable. character(len=48) :: dim_name(4) ! The names of the dimensions of the variable. character(len=20) :: varname ! The name of an input variable for data override. @@ -1288,7 +1275,7 @@ end function get_wave_method !! !! Update (Jan/25): !! - Converted from function to subroutine, now returns Langmuir number. -!! - Computs 10m wind internally, so only ustar and hbl need passed to +!! - Compute 10m wind internally, so only ustar and hbl need passed to !! subroutine. !! !! Qing Li, 160606 @@ -1319,7 +1306,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) real :: kstar ! A rescaled wavenumber? [Z-1 ~> m-1] real :: vstokes ! The total Stokes transport [Z L T-1 ~> m2 s-1] real :: z0 ! The boundary layer depth [Z ~> m] - real :: z0i ! The inverse of theboundary layer depth [Z-1 ~> m-1] + real :: z0i ! The inverse of the boundary layer depth [Z-1 ~> m-1] real :: r1, r2, r3, r4 ! Nondimensional ratios [nondim] real :: r5 ! A single expression that combines r2 and r4 [nondim] real :: root_2kz ! The square root of twice the peak wavenumber times the @@ -1730,7 +1717,7 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) if (CS%id_P_deltaStokes_L > 0) P_deltaStokes_L(:,:,:) = 0.0 ! First compute PGFu. The Stokes-induced pressure anomaly diagnostic is stored from this calculation. - ! > Seeking PGFx at (I,j), meanining we need to compute pressure at h-points (i,j) and (i+1,j). + ! > Seeking PGFx at (I,j), meaning we need to compute pressure at h-points (i,j) and (i+1,j). ! UL(i,j) -> found as average of I-1 & I on j ! UR(i+1,j) -> found as average of I & I+1 on j ! VL(i,j) -> found on i as average of J-1 & J @@ -1826,7 +1813,7 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) enddo ; enddo ! Next compute PGFv. The Stokes-induced pressure anomaly diagnostic is stored from this calculation. - ! > Seeking PGFy at (i,J), meanining we need to compute pressure at h-points (i,j) and (i,j+1). + ! > Seeking PGFy at (i,J), meaning we need to compute pressure at h-points (i,j) and (i,j+1). ! UL(i,j) -> found as average of I-1 & I on j ! UR(i,j+1) -> found as average of I-1 & I on j+1 ! VL(i,j) -> found on i as average of J-1 & J @@ -2084,7 +2071,7 @@ end subroutine waves_register_restarts !! interpret surface wave data for MOM6. In its original form, the !! capabilities include setting the Stokes drift in the model (from a !! variety of sources including prescribed, empirical, and input -!! files). In short order, the plan is to also ammend the subroutine +!! files). In short order, the plan is to also amend the subroutine !! to accept Stokes drift information from an external coupler. !! Eventually, it will be necessary to break this file apart so that !! general wave information may be stored in the control structure From 78c91cd8d440eaf108bb1223a02a18a7a985bdb0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Jan 2023 07:06:40 -0500 Subject: [PATCH 149/629] +Renamed internal Cd variables Renamed two internal variables to Cd and I_sqrtCd in ust_2_u10_coare3p5 for greater clarity and corrected their descriptions in comments, following advice from the review of the pull request that this is a part of. Also added the missing units description "nondim" to the get_param call for DHH85_AGE. All answers are bitwise identical. --- src/user/MOM_wave_interface.F90 | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 53cf2aea8c..f99ca27994 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -485,7 +485,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar "Choose true to use waveage in peak frequency.", default=.false.) call get_param(param_file, mdl, "DHH85_AGE", CS%WaveAge, & "Wave Age for DHH85 spectrum.", & - units='', default=1.2) + units='nondim', default=1.2) call get_param(param_file, mdl, "DHH85_WIND", CS%WaveWind, & "Wind speed for DHH85 spectrum.", & units='m s-1', default=10.0, scale=US%m_s_to_L_T) @@ -1931,8 +1931,8 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) real :: u10a ! The previous guess for u10 [L T-1 ~> m s-1] real :: alpha ! The Charnock coeffient relating the wind friction velocity squared to the ! roughness length [nondim] - real :: Cd2 ! The square of the drag coefficient [nondim] - real :: I_Cd ! The inverse of the drag coefficient [nondim] + real :: Cd ! The drag coefficient [nondim] + real :: I_sqrtCd ! The inverse of the square root of the drag coefficient [nondim] real :: I_vonKar ! The inverse of the von Karman coefficient [nondim] integer :: CT @@ -1958,8 +1958,8 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) z0rough = alpha * (US%Z_to_L*USTair)**2 / GV%g_Earth ! Compute z0rough from ustar guess z0 = z0sm + z0rough - Cd2 = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute CD from derived roughness - u10 = US%Z_to_L*USTair/sqrt(Cd2) ! Compute new u10 from derived CD, while loop + Cd = ( CS%vonKar / log(ten_m_scale / z0) )**2 ! Compute Cd from derived roughness + u10 = US%Z_to_L*USTair/sqrt(Cd) ! Compute new u10 from derived Cd, while loop ! ends and checks for convergence...CT counter ! makes sure loop doesn't run away if function ! doesn't converge. This code was produced offline @@ -1973,7 +1973,8 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) enddo else ! Use more efficient expressions that are mathematically equivalent to those above. - u10 = US%Z_to_L*USTair * sqrt(1000.0) ! Guess for u10. Is 1000 here the ratio of the densities of water and air? + u10 = US%Z_to_L*USTair * sqrt(1000.0) ! First guess for u10. + ! In the line above 1000 is the inverse of a plausible first guess of the drag coefficient. I_vonKar = 1.0 / CS%vonKar I_ten_m_scale = 0.1*US%Z_to_m @@ -1983,8 +1984,8 @@ subroutine ust_2_u10_coare3p5(USTair, U10, GV, US, CS) alpha = min(CS%Charnock_min, CS%Charnock_slope_U10 * u10 + CS%Charnock_intercept) z0rough = alpha * (CS%I_g_Earth * USTair**2) ! Compute z0rough from ustar guess z0 = z0sm + z0rough - I_Cd = abs(log(z0 * I_ten_m_scale)) * I_vonKar ! Compute CD from derived roughness - u10 = US%Z_to_L*USTair * I_Cd ! Compute new u10 from the derived CD. + I_sqrtCd = abs(log(z0 * I_ten_m_scale)) * I_vonKar ! Compute Cd from derived roughness + u10 = US%Z_to_L*USTair * I_sqrtCd ! Compute new u10 from the derived Cd. enddo ! Output a reasonable estimate of u10 if the iteration has not converged. The hard-coded From 3f57d75f39ea82f33270157e75618c8f671e9524 Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Mon, 9 Jan 2023 07:16:09 -0700 Subject: [PATCH 150/629] Add GL90 diagnostics (#293) * Add GL90 parameterization in stacked shallow water This adds a new vertical viscosity parameterization as in Greatbatch and Lamb (1990), Ferreira & Marshall (2006) and Zhao & Vallis (2008), hereafter referred to as the GL90 vertical viscosity parameterization. This vertical viscosity scheme redistributes momentum in the vertical, and is the equivalent of the Gent & McWilliams (1990) parameterization, but in a TWA (thickness-weighted averaged) set of equations. The vertical viscosity coefficient nu is computed from kappa_GM via thermal wind balance, and the following relation: nu = kappa_GM * f^2 / N^2. The vertical viscosity del_z ( nu del_z u) is applied to the momentum equation with stress-free boundary conditions at the top and bottom. In the current implementation, kappa_GM is assumed either (a) constant or as (b) having an EBT structure. A third possible formulation of nu is depth-independent: nu = f^2 * alpha The latter formulation would be equivalent to a kappa_GM that varies as N^2 with depth. Currently, the GL90 parameterization is only implemented in stacked shallow water (SSW) mode, in which case we have 1/N^2 = h/g'. More specifically, this commit adds a new subroutine that computes the couping coefficient associated with GL90 via a_cpl_gl90 = nu / h = kappa_GM * f^2 / g' or a_cpl_gl90 = nu / h = f^2 * alpha / h. Further, a_cpl_gl90 is multiplied by a function (botfn), which is 0 within the GL90 bottom boundary layer, whose depth is set by Hbbl_gl90, and 1 otherwise. This modification is necessary to avlid fluxing momentum into vanished layers that ride over steep topography. Finally, a_cpl_gl90 is added to a_cpl, where the latter is the coupling coefficient associated with the remaining vertical stresses, used in the vertical viscosity solver. More information can be found in Loose et al. (https://www.essoar.org/doi/abs/10.1002/essoar.10512867.1), Appendix B. New diagnostics: * au_gl90_visc: zonal viscous coupling coefficient associated with GL90, is contained in au_visc * av_gl90_visc: meridional viscous coupling coefficient associated with GL90, is contained in av_visc * Kv_gl90_u: GL90 vertical viscosity at u-points, is contained in Kv_u * Kv_gl90_v: GL90 vertical viscosity at v-points, is contained in Kv_v * du_dt_visc_gl90: zonal acceleration due to GL90 vertical viscosity, included in du_dt_visc * dv_dt_visc_gl90: meridional acceleration due to GL90 vertical viscosity, included in dv_dt_visc * GLwork: Kinetic Energy Source from GL90 Vertical Viscosity The energetics of the GL90 parameterization (named "GLwork") are intentionally computed in MOM_vert_friction, rather than in MOM_diagnostics, where the reamining kinetic energy budget terms are computed. We have to do the computation in MOM_vert_friction to ensure sign- definiteness when GLwork is summed in the vertical. Indeed, MOM_diagnostics does not have access to the velocities and thicknesses used in the vertical solver, but rather uses a time-mean barotropic transport [uv]h to compute the energy budget diagnostics. A detailed discussion and exploration of this issue can be found in https://github.com/ocean-eddy-cpt/MOM6/issues/25. As a result of not computing the energetics in MOM_diagnostics, GLwork is not exactly contained in KE_visc. KE_visc represents the energetics of all vertical viscosity contributions, including the GL90 vertical viscosity. We could implement a term "KE_visc_gl90" that can be 1-to-1 compared to KE_visc; that is, KE_visc - KE_visc_gl90 would represent exactly the energetics of all viscosity contributions EXCEPT the GL90 viscosity. If we implemented KE_visc_gl90, this term would in practice be very similar as GLwork, but sign-definiteness is not ensured, see above. --- src/core/MOM_variables.F90 | 4 + .../vertical/MOM_vert_friction.F90 | 184 +++++++++++++++++- 2 files changed, 182 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 8279afa954..35cdf3038a 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -168,6 +168,10 @@ module MOM_variables PFv => NULL(), & !< Meridional acceleration due to pressure forces [L T-2 ~> m s-2] du_dt_visc => NULL(), &!< Zonal acceleration due to vertical viscosity [L T-2 ~> m s-2] dv_dt_visc => NULL(), &!< Meridional acceleration due to vertical viscosity [L T-2 ~> m s-2] + du_dt_visc_gl90 => NULL(), &!< Zonal acceleration due to GL90 vertical viscosity + ! (is included in du_dt_visc) [L T-2 ~> m s-2] + dv_dt_visc_gl90 => NULL(), &!< Meridional acceleration due to GL90 vertical viscosity + ! (is included in dv_dt_visc) [L T-2 ~> m s-2] du_dt_str => NULL(), & !< Zonal acceleration due to the surface stress (included !! in du_dt_visc) [L T-2 ~> m s-2] dv_dt_str => NULL(), & !< Meridional acceleration due to the surface stress (included diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index bc8ef7e893..88be824885 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -7,6 +7,8 @@ module MOM_vert_friction use MOM_diag_mediator, only : post_product_u, post_product_sum_u use MOM_diag_mediator, only : post_product_v, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, query_averaging_enabled +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : To_North, To_East use MOM_debugging, only : uvchksum, hchksum use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -156,11 +158,14 @@ module MOM_vert_friction real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 T-1 ~> m2 s-1] !>@{ Diagnostic identifiers - integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_au_vv = -1, id_av_vv = -1 + integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_du_dt_visc_gl90 = -1, id_dv_dt_visc_gl90 = -1 + integer :: id_GLwork = -1 + integer :: id_au_vv = -1, id_av_vv = -1, id_au_gl90_vv = -1, id_av_gl90_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 integer :: id_Kv_slow = -1, id_Kv_u = -1, id_Kv_v = -1 + integer :: id_Kv_gl90_u = -1, id_Kv_gl90_v = -1 ! integer :: id_hf_du_dt_visc = -1, id_hf_dv_dt_visc = -1 integer :: id_h_du_dt_visc = -1, id_h_dv_dt_visc = -1 integer :: id_hf_du_dt_visc_2d = -1, id_hf_dv_dt_visc_2d = -1 @@ -171,6 +176,7 @@ module MOM_vert_friction type(PointAccel_CS), pointer :: PointAccel_CSp => NULL() !< A pointer to the control structure !! for recording accelerations leading to velocity truncations + type(group_pass_type) :: pass_KE_uv !< A handle used for group halo passes end type vertvisc_CS contains @@ -359,6 +365,12 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: zDS, hfr, h_a ! Temporary variables used with direct_stress. real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real, allocatable, dimension(:,:,:) :: KE_term ! A term in the kinetic energy budget + ! [H L2 T-3 ~> m3 s-3 or W m-2] + real, allocatable, dimension(:,:,:) :: KE_u ! 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, allocatable, dimension(:,:,:) :: KE_v ! 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] logical :: do_i(SZIB_(G)) logical :: DoStokesMixing @@ -373,6 +385,14 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(visc): "// & "Module must be initialized before it is used.") + if (CS%id_GLwork > 0) then + allocate(KE_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + allocate(KE_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + allocate(KE_term(G%isd:G%ied,G%jsd:G%jed,GV%ke), source=0.0) + if (.not.G%symmetric) & + call create_group_pass(CS%pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + endif + if (CS%direct_stress) then Hmix = CS%Hmix_stress I_Hmix = 1.0 / Hmix @@ -412,7 +432,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = u(I,j,k) enddo ; enddo ; endif - + if (associated(ADp%du_dt_visc_gl90)) then ; do k=1,nz ; do I=Isq,Ieq + ADp%du_dt_visc_gl90(I,j,k) = u(I,j,k) + enddo ; enddo ; endif if (associated(ADp%du_dt_str)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_str(I,j,k) = 0.0 enddo ; enddo ; endif @@ -501,6 +523,46 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & endif ; enddo ; enddo endif + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting u, + ! use ADp%du_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%du_dt_visc_gl90)) then + do I=Isq,Ieq ; if (do_i(I)) then + b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero + b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u_gl90(I,j,2)) + d1(I) = b_denom_1 * b1(I) + ADp%du_dt_visc_gl90(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) + endif ; enddo + do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then + c1(I,k) = dt_Z_to_H * CS%a_u_gl90(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (CS%a_u_gl90(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u_gl90(I,j,K+1)) + d1(I) = b_denom_1 * b1(I) + ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) + & + dt_Z_to_H * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) + endif ; enddo ; enddo + ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 + do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then + ADp%du_dt_visc_gl90(I,j,k) = ADp%du_dt_visc_gl90(I,j,k) + c1(I,k+1) * ADp%du_dt_visc_gl90(I,j,k+1) + endif ; enddo ; enddo ! i and k loops + do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then + ! now fill ADp%du_dt_visc_gl90(I,j,k) with actual velocity tendency due to GL90; + ! note that on RHS: ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + ! and ADp%du_dt_visc_gl90(I,j,k) the updated velocity due to GL90 + ADp%du_dt_visc_gl90(I,j,k) = (ADp%du_dt_visc_gl90(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt + if (abs(ADp%du_dt_visc_gl90(I,j,k)) < accel_underflow) ADp%du_dt_visc_gl90(I,j,k) = 0.0 + endif ; enddo ; enddo ; + ! to compute energetics, we need to multiply by u*h, where u is original velocity before + ! velocity update; note that ADp%du_dt_visc(I,j,k) holds the original velocity value u(I,j,k) + if (CS%id_GLwork > 0) then + do k=1,nz; do I=Isq,Ieq ; if (do_i(I)) then + KE_u(I,j,k) = ADp%du_dt_visc(I,j,k) * CS%h_u(I,j,k) * G%areaCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + endif ; enddo ; enddo + endif + endif + endif + if (associated(ADp%du_dt_visc)) then ; do k=1,nz ; do I=Isq,Ieq ADp%du_dt_visc(I,j,k) = (u(I,j,k) - ADp%du_dt_visc(I,j,k))*Idt if (abs(ADp%du_dt_visc(I,j,k)) < accel_underflow) ADp%du_dt_visc(I,j,k) = 0.0 @@ -542,7 +604,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = v(i,J,k) enddo ; enddo ; endif - + if (associated(ADp%dv_dt_visc_gl90)) then ; do k=1,nz ; do i=is,ie + ADp%dv_dt_visc_gl90(i,J,k) = v(i,J,k) + enddo ; enddo ; endif if (associated(ADp%dv_dt_str)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_str(i,J,k) = 0.0 enddo ; enddo ; endif @@ -601,6 +665,47 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & endif ; enddo ; enddo endif + ! compute vertical velocity tendency that arises from GL90 viscosity; + ! follow tridiagonal solve method as above; to avoid corrupting v, + ! use ADp%dv_dt_visc_gl90 as a placeholder for updated u (due to GL90) until last do loop + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + if (associated(ADp%dv_dt_visc_gl90)) then + do i=is,ie ; if (do_i(i)) then + b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero + b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v_gl90(i,J,2)) + d1(i) = b_denom_1 * b1(i) + ADp%dv_dt_visc_gl90(I,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) + endif ; enddo + do k=2,nz ; do i=is,ie ; if (do_i(i)) then + c1(i,k) = dt_Z_to_H * CS%a_v_gl90(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (CS%a_v_gl90(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v_gl90(i,J,K+1)) + d1(i) = b_denom_1 * b1(i) + ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) + & + dt_Z_to_H * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) + endif ; enddo ; enddo + ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 + do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then + ADp%dv_dt_visc_gl90(i,J,k) = ADp%dv_dt_visc_gl90(i,J,k) + c1(i,k+1) * ADp%dv_dt_visc_gl90(i,J,k+1) + endif ; enddo ; enddo ! i and k loops + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + ! now fill ADp%dv_dt_visc_gl90(i,J,k) with actual velocity tendency due to GL90; + ! note that on RHS: ADp%dv_dt_visc(i,J,k) holds the original velocity value v(i,J,k) + ! and ADp%dv_dt_visc_gl90(i,J,k) the updated velocity due to GL90 + ADp%dv_dt_visc_gl90(i,J,k) = (ADp%dv_dt_visc_gl90(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt + if (abs(ADp%dv_dt_visc_gl90(i,J,k)) < accel_underflow) ADp%dv_dt_visc_gl90(i,J,k) = 0.0 + endif ; enddo ; enddo ; + ! to compute energetics, we need to multiply by v*h, where u is original velocity before + ! velocity update; note that ADp%dv_dt_visc(I,j,k) holds the original velocity value v(i,J,k) + if (CS%id_GLwork > 0) then + do k=1,nz ; do i=is,ie ; if (do_i(i)) then + ! note that on RHS: ADp%dv_dt_visc(I,j,k) holds the original velocity value v(I,j,k) + KE_v(I,j,k) = ADp%dv_dt_visc(i,J,k) * CS%h_v(i,J,k) * G%areaCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + endif ; enddo ; enddo + endif + endif + endif + if (associated(ADp%dv_dt_visc)) then ; do k=1,nz ; do i=is,ie ADp%dv_dt_visc(i,J,k) = (v(i,J,k) - ADp%dv_dt_visc(i,J,k))*Idt if (abs(ADp%dv_dt_visc(i,J,k)) < accel_underflow) ADp%dv_dt_visc(i,J,k) = 0.0 @@ -626,6 +731,23 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ! end of v-component J loop + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! We do the KE-rate calculation here (rather than in MOM_diagnostics) to ensure + ! a sign-definite term. MOM_diagnostics does not have access to the velocities + ! and thicknesses used in the vertical solver, but rather uses a time-mean + ! barotropic transport [uv]h. + if (CS%id_GLwork > 0) then + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do k=1,nz + do j=js,je ; do i=is,ie + KE_term(i,j,k) = 0.5 * G%IareaT(i,j) & + * (KE_u(I,j,k) + KE_u(I-1,j,k) + KE_v(i,J,k) + KE_v(i,J-1,k)) + enddo ; enddo + enddo + call post_data(CS%id_GLwork, KE_term, CS%diag) + endif + call vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS) ! Here the velocities associated with open boundary conditions are applied. @@ -651,8 +773,12 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (query_averaging_enabled(CS%diag)) then if (CS%id_du_dt_visc > 0) & call post_data(CS%id_du_dt_visc, ADp%du_dt_visc, CS%diag) + if (CS%id_du_dt_visc_gl90 > 0) & + call post_data(CS%id_du_dt_visc_gl90, ADp%du_dt_visc_gl90, CS%diag) if (CS%id_dv_dt_visc > 0) & call post_data(CS%id_dv_dt_visc, ADp%dv_dt_visc, CS%diag) + if (CS%id_dv_dt_visc_gl90 > 0) & + call post_data(CS%id_dv_dt_visc_gl90, ADp%dv_dt_visc_gl90, CS%diag) if (present(taux_bot) .and. (CS%id_taux_bot > 0)) & call post_data(CS%id_taux_bot, taux_bot, CS%diag) if (present(tauy_bot) .and. (CS%id_tauy_bot > 0)) & @@ -868,6 +994,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [H ~> m or kg m-2]. real, allocatable, dimension(:,:,:) :: Kv_u !< Total vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. real, allocatable, dimension(:,:,:) :: Kv_v !< Total vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_u !< GL90 vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_v !< GL90 vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. real :: zcol(SZI_(G)) ! The height of an interface at h-points [H ~> m or kg m-2]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior [nondim]. @@ -911,6 +1039,10 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) if (CS%id_Kv_v > 0) allocate(Kv_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + if (CS%id_Kv_gl90_u > 0) allocate(Kv_gl90_u(G%IsdB:G%IedB,G%jsd:G%jed,GV%ke), source=0.0) + + if (CS%id_Kv_gl90_v > 0) allocate(Kv_gl90_v(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.0) + if (CS%debug .or. (CS%id_hML_u > 0)) allocate(hML_u(G%IsdB:G%IedB,G%jsd:G%jed), source=0.0) if (CS%debug .or. (CS%id_hML_v > 0)) allocate(hML_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) @@ -1106,7 +1238,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) if (do_i(I)) Kv_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) enddo ; enddo endif - + ! Diagnose GL90 Kv at u-points + if (CS%id_Kv_gl90_u > 0) then + do k=1,nz ; do I=Isq,Ieq + if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + enddo ; enddo + endif enddo @@ -1297,7 +1434,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) if (do_i(I)) Kv_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) enddo ; enddo endif - + ! Diagnose GL90 Kv at v-points + if (CS%id_Kv_gl90_v > 0) then + do k=1,nz ; do i=is,ie + if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + enddo ; enddo + endif enddo ! end of v-point j loop if (CS%debug) then @@ -1316,8 +1458,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) call post_data(CS%id_Kv_slow, visc%Kv_slow, CS%diag) if (CS%id_Kv_u > 0) call post_data(CS%id_Kv_u, Kv_u, CS%diag) if (CS%id_Kv_v > 0) call post_data(CS%id_Kv_v, Kv_v, CS%diag) + if (CS%id_Kv_gl90_u > 0) call post_data(CS%id_Kv_gl90_u, Kv_gl90_u, CS%diag) + if (CS%id_Kv_gl90_v > 0) call post_data(CS%id_Kv_gl90_v, Kv_gl90_v, CS%diag) if (CS%id_au_vv > 0) call post_data(CS%id_au_vv, CS%a_u, CS%diag) if (CS%id_av_vv > 0) call post_data(CS%id_av_vv, CS%a_v, CS%diag) + if (CS%id_au_gl90_vv > 0) call post_data(CS%id_au_gl90_vv, CS%a_u_gl90, CS%diag) + if (CS%id_av_gl90_vv > 0) call post_data(CS%id_av_gl90_vv, CS%a_v_gl90, CS%diag) if (CS%id_h_u > 0) call post_data(CS%id_h_u, CS%h_u, CS%diag) if (CS%id_h_v > 0) call post_data(CS%id_h_v, CS%h_v, CS%diag) if (CS%id_hML_u > 0) call post_data(CS%id_hML_u, hML_u, CS%diag) @@ -2292,12 +2438,24 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & 'Total vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + CS%id_Kv_gl90_u = register_diag_field('ocean_model', 'Kv_gl90_u', diag%axesCuL, Time, & + 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + + CS%id_Kv_gl90_v = register_diag_field('ocean_model', 'Kv_gl90_v', diag%axesCvL, Time, & + 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_au_gl90_vv = register_diag_field('ocean_model', 'au_gl90_visc', diag%axesCui, Time, & + 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + + CS%id_av_gl90_vv = register_diag_field('ocean_model', 'av_gl90_visc', diag%axesCvi, Time, & + 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', & thickness_units, conversion=GV%H_to_MKS) @@ -2322,7 +2480,21 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_dv_dt_visc = register_diag_field('ocean_model', 'dv_dt_visc', diag%axesCvL, Time, & 'Meridional Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) - + CS%id_GLwork = register_diag_field('ocean_model', 'GLwork', diag%axesTL, Time, & + 'Kinetic Energy Source from GL90 Vertical Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_du_dt_visc_gl90 = register_diag_field('ocean_model', 'du_dt_visc_gl90', diag%axesCuL, Time, & + 'Zonal Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_du_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + call safe_alloc_ptr(ADp%du_dt_visc_gl90,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) + endif + CS%id_dv_dt_visc_gl90 = register_diag_field('ocean_model', 'dv_dt_visc_gl90', diag%axesCvL, Time, & + 'Meridional Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) + if ((CS%id_dv_dt_visc_gl90 > 0) .or. (CS%id_GLwork > 0)) then + call safe_alloc_ptr(ADp%dv_dt_visc_gl90,isd,ied,JsdB,JedB,nz) + call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) + endif CS%id_du_dt_str = register_diag_field('ocean_model', 'du_dt_str', diag%axesCuL, Time, & 'Zonal Acceleration from Surface Wind Stresses', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_du_dt_str > 0) call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) From 0f1fc0386928b3649fe841cc8a2896015f07a4fe Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 9 Jan 2023 13:31:41 -0700 Subject: [PATCH 151/629] fix gnu restart issue by removing leading spaces in restartfiles list --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index d244205b1b..1abb7c9229 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -625,7 +625,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(restartfiles)) + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) ! GMM, this call is not needed in CESM. Check with EMC if it can be deleted. call ocean_model_flux_init(ocean_state) From b693dd2d81a7d4b3de7fc05011d5519e4d6101b8 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 12 Jan 2023 09:35:09 -0700 Subject: [PATCH 152/629] remove more direct calls to FMS in mom_cap.F90 --- config_src/drivers/nuopc_cap/mom_cap.F90 | 37 ++++++------------------ 1 file changed, 9 insertions(+), 28 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index b9090e9cec..6768a2f547 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -2,26 +2,18 @@ module MOM_cap_mod -use constants_mod, only: constants_init -use diag_manager_mod, only: diag_manager_init, diag_manager_end -use field_manager_mod, only: field_manager_init, field_manager_end -use mom_coms_infra, only: MOM_infra_init, MOM_infra_end -use mom_io_infra, only: io_infra_end -use mom_domain_infra, only: get_domain_extent -use MOM_io, only: stdout +use MOM_domains, only: get_domain_extent +use MOM_io, only: stdout, io_infra_end use mpp_domains_mod, only: mpp_get_compute_domains use mpp_domains_mod, only: mpp_get_ntile_count, mpp_get_pelist, mpp_get_global_domain use mpp_domains_mod, only: mpp_get_domain_npes -use time_manager_mod, only: set_calendar_type, time_type, increment_date -use time_manager_mod, only: set_time, set_date, get_time, get_date, month_name -use time_manager_mod, only: GREGORIAN, JULIAN, NOLEAP, THIRTY_DAY_MONTHS, NO_CALENDAR -use time_manager_mod, only: operator( <= ), operator( < ), operator( >= ) -use time_manager_mod, only: operator( + ), operator( - ), operator( / ) -use time_manager_mod, only: operator( * ), operator( /= ), operator( > ) -use time_manager_mod, only: date_to_string -use time_manager_mod, only: fms_get_calendar_type => get_calendar_type -use MOM_domains, only: MOM_infra_init, num_pes, root_pe, pe_here +use MOM_time_manager, only: set_calendar_type, time_type, set_time, set_date, month_name +use MOM_time_manager, only: GREGORIAN, JULIAN, NOLEAP +use MOM_time_manager, only: operator( <= ), operator( < ), operator( >= ) +use MOM_time_manager, only: operator( + ), operator( - ), operator( / ) +use MOM_time_manager, only: operator( * ), operator( /= ), operator( > ) +use MOM_domains, only: MOM_infra_init, MOM_infra_end, num_pes, root_pe, pe_here use MOM_file_parser, only: get_param, log_version, param_file_type, close_param_file use MOM_get_input, only: get_MOM_input, directories use MOM_domains, only: pass_var @@ -486,9 +478,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (chkerr(rc,__LINE__,u_FILE_u)) return call MOM_infra_init(mpi_comm_mom) - call constants_init - call field_manager_init - ! determine the calendar if (cesm_coupled) then call NUOPC_CompAttributeGet(gcomp, name="calendar", value=cvalue, & @@ -514,8 +503,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call set_calendar_type (JULIAN) endif - call diag_manager_init - ! this ocean connector will be driven at set interval DT = set_time (DT_OCEAN, 0) ! get current time @@ -1987,7 +1974,6 @@ subroutine ocean_model_finalize(gcomp, rc) ESMF_LOGMSG_INFO) call ocean_model_end(ocean_public, ocean_State, Time, write_restart=write_restart) - call field_manager_end() call io_infra_end() call MOM_infra_end() @@ -2337,8 +2323,7 @@ end subroutine shr_log_setLogUnit !! @subsection Initialization Initialization !! !! During the [InitializeAdvertise] (@ref MOM_cap_mod::initializeadvertise) phase, calls are -!! made to MOM's native initialization subroutines, including `fms_init()`, `constants_init()`, -!! `field_manager_init()`, `diag_manager_init()`, and `set_calendar_type()`. The MPI communicator +!! made to MOM's native initialization subroutines. The MPI communicator !! is pulled in through the ESMF VM object for the MOM component. The dt and start time are set !! from parameters from the incoming ESMF clock with calls to `set_time()` and `set_date().` !! @@ -2413,10 +2398,6 @@ end subroutine shr_log_setLogUnit !! procedures: !! !! call ocean_model_end (ocean_public, ocean_State, Time) -!! call diag_manager_end(Time ) -!! call field_manager_end -!! call fms_io_exit -!! call fms_end !! !! @section ModelFields Model Fields !! From 1d918b651ab2c42ba7eab540c7f1ed95d7605b44 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 12 Jan 2023 14:29:36 -0500 Subject: [PATCH 153/629] Updates to ODA driver suggested by @Hallberg-NOAA Issue#277 (#297) These changes follow suggestions from @Hallberg-NOAA for clarity in documentation and code readability. These modifications should not impact existing applications (e.g. SPEAR) which are reliant on this code. --- src/core/MOM.F90 | 2 +- src/ocean_data_assim/MOM_oda_driver.F90 | 135 +++++++++++++----------- 2 files changed, 75 insertions(+), 62 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c0ff15e858..07538cdec2 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1456,7 +1456,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%debug) then call MOM_thermo_chksum("Pre-oda ", tv, G, US, haloshift=0) endif - call apply_oda_tracer_increments(US%T_to_s*dtdia, Time_end_thermo, G, GV, tv, h, CS%odaCS) + call apply_oda_tracer_increments(dtdia, Time_end_thermo, G, GV, tv, h, CS%odaCS) if (CS%debug) then call MOM_thermo_chksum("Post-oda ", tv, G, US, haloshift=0) endif diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 4ad11592f9..8a1aab3328 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -103,8 +103,12 @@ module MOM_oda_driver_mod type(domain2d), pointer :: mpp_domain => NULL() !< Pointer to a mpp domain object for DA type(grid_type), pointer :: oda_grid !< local tracer grid real, pointer, dimension(:,:,:) :: h => NULL() ! m or kg m-2] for DA - type(thermo_var_ptrs), pointer :: tv => NULL() !< pointer to thermodynamic variables - type(thermo_var_ptrs), pointer :: tv_bc => NULL() !< pointer to thermodynamic bias correction + real, pointer, dimension(:,:,:) :: T_tend => NULL() ! degC s-1] + real, pointer, dimension(:,:,:) :: S_tend => NULL() ! ppt s-1] + real, pointer, dimension(:,:,:) :: T_bc_tend => NULL() !< The layer temperature tendency due + !! to bias adjustment [C T-1 ~> degC s-1] + real, pointer, dimension(:,:,:) :: S_bc_tend => NULL() !< The layer salinity tendency due + !! to bias adjustment [S T-1 ~> ppt s-1] integer :: ni !< global i-direction grid size integer :: nj !< global j-direction grid size logical :: reentrant_x !< grid is reentrant in the x direction @@ -120,7 +124,7 @@ module MOM_oda_driver_mod integer :: ensemble_id = 0 !< id of the current ensemble member integer, pointer, dimension(:,:) :: ensemble_pelist !< PE list for ensemble members integer, pointer, dimension(:) :: filter_pelist !< PE list for ensemble members - integer :: assim_frequency !< analysis interval in hours + real :: assim_interval !< analysis interval [ T ~> s] ! Profiles local to the analysis domain type(ocean_profile_type), pointer :: Profiles => NULL() !< pointer to linked list of all available profiles type(ocean_profile_type), pointer :: CProfiles => NULL()!< pointer to linked list of current profiles @@ -198,8 +202,15 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, mdl, "ASSIM_METHOD", assim_method, & "String which determines the data assimilation method "//& "Valid methods are: \'EAKF\',\'OI\', and \'NO_ASSIM\'", default='NO_ASSIM') - call get_param(PF, mdl, "ASSIM_FREQUENCY", CS%assim_frequency, & - "data assimilation frequency in hours") + call get_param(PF, mdl, "ASSIM_INTERVAL", CS%assim_interval, & + "data assimilation update interval in hours",default=-1.0,units="hours",scale=3600.*US%s_to_T) + if (CS%assim_interval < 0.) then + call get_param(PF, mdl, "ASSIM_FREQUENCY", CS%assim_interval, & + "data assimilation update in hours. This parameter name will \n"//& + "be deprecated in the future. ASSIM_INTERVAL should be used instead.",default=-1.0, & + units="hours",scale=3600.*US%s_to_T) + endif + call get_param(PF, mdl, "USE_REGRIDDING", CS%use_ALE_algorithm , & "If True, use the ALE algorithm (regridding/remapping).\n"//& "If False, use the layered isopycnal algorithm.", default=.false. ) @@ -338,9 +349,9 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) ! assign thicknesses call ALE_initThicknessToCoord(CS%ALE_CS, G, CS%GV, CS%h) endif - allocate(CS%tv) - allocate(CS%tv%T(isd:ied,jsd:jed,CS%GV%ke), source=0.0) - allocate(CS%tv%S(isd:ied,jsd:jed,CS%GV%ke), source=0.0) + + allocate(CS%T_tend(isd:ied,jsd:jed,CS%GV%ke), source=0.0) + allocate(CS%S_tend(isd:ied,jsd:jed,CS%GV%ke), source=0.0) ! call set_axes_info(CS%Grid, CS%GV, CS%US, PF, CS%diag_cs, set_vertical=.true.) ! missing in Feiyu's fork allocate(CS%oda_grid) CS%oda_grid%x => CS%Grid%geolonT @@ -387,9 +398,9 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_external_field_info(CS%INC_CS%T_id,size=fld_sz) CS%INC_CS%fldno = 2 if (CS%nk /= fld_sz(3)) call MOM_error(FATAL,'Increment levels /= ODA levels') - allocate(CS%tv_bc) ! storage for increment - allocate(CS%tv_bc%T(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) - allocate(CS%tv_bc%S(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) + + allocate(CS%T_bc_tend(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) + allocate(CS%S_bc_tend(G%isd:G%ied,G%jsd:G%jed,CS%GV%ke), source=0.0) endif call cpu_clock_end(id_clock_oda_init) @@ -468,17 +479,15 @@ end subroutine set_prior_tracer !> Returns posterior adjustments or full state !!Note that only those PEs associated with an ensemble member receive data -subroutine get_posterior_tracer(Time, CS, h, tv, increment) +subroutine get_posterior_tracer(Time, CS, increment) type(time_type), intent(in) :: Time !< the current model time type(ODA_CS), pointer :: CS !< ocean DA control structure - real, dimension(:,:,:), pointer, optional :: h !< Layer thicknesses [H ~> m or kg m-2] - type(thermo_var_ptrs), pointer, optional :: tv !< A structure pointing to various thermodynamic variables logical, optional, intent(in) :: increment !< True if returning increment only type(ocean_control_struct), pointer :: Ocean_increment=>NULL() integer :: m logical :: get_inc - integer :: seconds_per_hour = 3600. + ! return if not analysis time (retain pointers for h and tv) if (Time < CS%Time .or. CS%assim_method == NO_ASSIM) return @@ -487,7 +496,7 @@ subroutine get_posterior_tracer(Time, CS, h, tv, increment) !! switch to global pelist call set_PElist(CS%filter_pelist) call MOM_mesg('Getting posterior') - if (present(h)) h => CS%h ! get analysis thickness + !! Calculate and redistribute increments to CS%tv right after assimilation !! Retain CS%tv to calculate increments for IAU updates CS%tv_inc otherwise get_inc = .true. @@ -503,30 +512,27 @@ subroutine get_posterior_tracer(Time, CS, h, tv, increment) do m=1,CS%ensemble_size if (get_inc) then call redistribute_array(CS%mpp_domain, Ocean_increment%T(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) call redistribute_array(CS%mpp_domain, Ocean_increment%S(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) else call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%T(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%T, complete=.true.) + CS%domains(m)%mpp_domain, CS%T_tend, complete=.true.) call redistribute_array(CS%mpp_domain, CS%Ocean_posterior%S(:,:,:,m),& - CS%domains(m)%mpp_domain, CS%tv%S, complete=.true.) + CS%domains(m)%mpp_domain, CS%S_tend, complete=.true.) endif enddo - if (present(tv)) tv => CS%tv - if (present(h)) h => CS%h - !! switch back to ensemble member pelist call set_PElist(CS%ensemble_pelist(CS%ensemble_id,:)) - call pass_var(CS%tv%T,CS%domains(CS%ensemble_id)) - call pass_var(CS%tv%S,CS%domains(CS%ensemble_id)) + call pass_var(CS%T_tend,CS%domains(CS%ensemble_id)) + call pass_var(CS%S_tend,CS%domains(CS%ensemble_id)) !convert to a tendency (degC or PSU per second) - CS%tv%T = CS%tv%T / (CS%assim_frequency * seconds_per_hour) - CS%tv%S = CS%tv%S / (CS%assim_frequency * seconds_per_hour) + CS%T_tend = CS%T_tend / (CS%assim_interval) + CS%S_tend = CS%S_tend / (CS%assim_interval) end subroutine get_posterior_tracer @@ -560,21 +566,22 @@ subroutine get_bias_correction_tracer(Time, US, CS) type(ODA_CS), pointer :: CS !< ocean DA control structure ! Local variables - real, allocatable, dimension(:,:,:) :: T_bias ! Temperature biases [C ~> degC] - real, allocatable, dimension(:,:,:) :: S_bias ! Salinity biases [C ~> degC] - real, allocatable, dimension(:,:,:) :: mask_z ! Missing value mask on the horizontal model grid - ! and input-file vertical levels [nondim] + real, allocatable, dimension(:,:,:) :: T_bias ! Estimated temperature tendency bias [C T-1 ~> degC s-1] + real, allocatable, dimension(:,:,:) :: S_bias ! Estimated salinity tendency bias [S T-1 ~> ppt s-1] + real, allocatable, dimension(:,:,:) :: valid_flag ! Valid value flag on the horizontal model grid + ! and input-file vertical levels [nondim] real, allocatable, dimension(:), target :: z_in ! Cell center depths for input data [Z ~> m] real, allocatable, dimension(:), target :: z_edges_in ! Cell edge depths for input data [Z ~> m] real :: missing_value ! A value indicating that there is no valid input data at this point [CU ~> conc] integer, dimension(3) :: fld_sz integer :: i,j,k + call cpu_clock_begin(id_clock_bias_adjustment) call horiz_interp_and_extrap_tracer(CS%INC_CS%T_id, Time, CS%G, T_bias, & - mask_z, z_in, z_edges_in, missing_value, scale=US%degC_to_C, spongeOngrid=.true.) + 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, & - mask_z, z_in, z_edges_in, missing_value, scale=US%ppt_to_S, spongeOngrid=.true.) + 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 ! which are intended to zero land values using an arbitrary limit. @@ -582,17 +589,21 @@ subroutine get_bias_correction_tracer(Time, US, CS) do i=1,fld_sz(1) do j=1,fld_sz(2) do k=1,fld_sz(3) - if (T_bias(i,j,k) > 1.0E-3*US%degC_to_C) T_bias(i,j,k) = 0.0 - if (S_bias(i,j,k) > 1.0E-3*US%ppt_to_S) S_bias(i,j,k) = 0.0 +! if (T_bias(i,j,k) > 1.0E-3*US%degC_to_C) T_bias(i,j,k) = 0.0 +! if (S_bias(i,j,k) > 1.0E-3*US%ppt_to_S) S_bias(i,j,k) = 0.0 + if (valid_flag(i,j,k)==0.) then + T_bias(i,j,k)=0.0 + S_bias(i,j,k)=0.0 + endif enddo enddo enddo - CS%tv_bc%T = T_bias * CS%bias_adjustment_multiplier - CS%tv_bc%S = S_bias * CS%bias_adjustment_multiplier + CS%T_bc_tend = T_bias * CS%bias_adjustment_multiplier + CS%S_bc_tend = S_bias * CS%bias_adjustment_multiplier - call pass_var(CS%tv_bc%T, CS%domains(CS%ensemble_id)) - call pass_var(CS%tv_bc%S, CS%domains(CS%ensemble_id)) + call pass_var(CS%T_bc_tend, CS%domains(CS%ensemble_id)) + call pass_var(CS%S_bc_tend, CS%domains(CS%ensemble_id)) call cpu_clock_end(id_clock_bias_adjustment) @@ -640,8 +651,8 @@ subroutine set_analysis_time(Time,CS) integer :: yr, mon, day, hr, min, sec if (Time >= CS%Time) then - ! increment the analysis time to the next step converting to seconds - CS%Time = CS%Time + real_to_time(CS%US%T_to_s*(CS%assim_frequency*3600.)) + ! increment the analysis time to the next step + CS%Time = CS%Time + real_to_time(CS%US%T_to_s*(CS%assim_interval)) call get_date(Time, yr, mon, day, hr, min, sec) write(mesg,*) 'Model Time: ', yr, mon, day, hr, min, sec @@ -662,7 +673,7 @@ end subroutine set_analysis_time !> Apply increments to tracers subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) - real, intent(in) :: dt !< The tracer timestep [s] + real, intent(in) :: dt !< The tracer timestep [T ~> s] type(time_type), intent(in) :: Time_end !< Time at the end of the interval type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -674,12 +685,14 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) !! local variables integer :: i, j integer :: isc, iec, jsc, jec - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_inc !< an adjustment to the temperature + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: T_tend_inc !< an adjustment to the temperature !! tendency [C T-1 -> degC s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_inc !< an adjustment to the salinity + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: S_tend_inc !< an adjustment to the salinity !! tendency [S T-1 -> ppt s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T !< The updated temperature [C ~> degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S !< The updated salinity [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: T_tend !< The temperature tendency adjustment from + !! DA [C T-1 ~> degC s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(CS%Grid)) :: S_tend !< The salinity tendency adjustment from DA + !! [S T-1 ~> ppt s-1] real :: h_neglect, h_neglect_edge ! small thicknesses [H ~> m or kg m-2] if (.not. associated(CS)) return @@ -687,14 +700,14 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) call cpu_clock_begin(id_clock_apply_increments) - T_inc(:,:,:) = 0.0; S_inc(:,:,:) = 0.0; T(:,:,:) = 0.0; S(:,:,:) = 0.0 + T_tend_inc(:,:,:) = 0.0; S_tend_inc(:,:,:) = 0.0; T_tend(:,:,:) = 0.0; S_tend(:,:,:) = 0.0 if (CS%assim_method > 0 ) then - T = T + CS%tv%T - S = S + CS%tv%S + T_tend = T_tend + CS%T_tend + S_tend = S_tend + CS%S_tend endif if (CS%do_bias_adjustment ) then - T = T + CS%tv_bc%T - S = S + CS%tv_bc%S + T_tend = T_tend + CS%T_bc_tend + S_tend = S_tend + CS%S_bc_tend endif if (CS%answer_date >= 20190101) then @@ -707,25 +720,25 @@ subroutine apply_oda_tracer_increments(dt, Time_end, G, GV, tv, h, CS) isc=G%isc; iec=G%iec; jsc=G%jsc; jec=G%jec do j=jsc,jec; do i=isc,iec - call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T(i,j,:), & - G%ke, h(i,j,:), T_inc(i,j,:), h_neglect, h_neglect_edge) - call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S(i,j,:), & - G%ke, h(i,j,:), S_inc(i,j,:), h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), T_tend(i,j,:), & + G%ke, h(i,j,:), T_tend_inc(i,j,:), h_neglect, h_neglect_edge) + call remapping_core_h(CS%remapCS, CS%nk, CS%h(i,j,:), S_tend(i,j,:), & + G%ke, h(i,j,:), S_tend_inc(i,j,:), h_neglect, h_neglect_edge) enddo; enddo - call pass_var(T_inc, G%Domain) - call pass_var(S_inc, G%Domain) + call pass_var(T_tend_inc, G%Domain) + call pass_var(S_tend_inc, G%Domain) - tv%T(isc:iec,jsc:jec,:) = tv%T(isc:iec,jsc:jec,:) + T_inc(isc:iec,jsc:jec,:)*dt - tv%S(isc:iec,jsc:jec,:) = tv%S(isc:iec,jsc:jec,:) + S_inc(isc:iec,jsc:jec,:)*dt + tv%T(isc:iec,jsc:jec,:) = tv%T(isc:iec,jsc:jec,:) + T_tend_inc(isc:iec,jsc:jec,:)*dt + tv%S(isc:iec,jsc:jec,:) = tv%S(isc:iec,jsc:jec,:) + S_tend_inc(isc:iec,jsc:jec,:)*dt call pass_var(tv%T, G%Domain) call pass_var(tv%S, G%Domain) call enable_averaging(dt, Time_end, CS%diag_CS) - if (CS%id_inc_t > 0) call post_data(CS%id_inc_t, T_inc, CS%diag_CS) - if (CS%id_inc_s > 0) call post_data(CS%id_inc_s, S_inc, CS%diag_CS) + if (CS%id_inc_t > 0) call post_data(CS%id_inc_t, T_tend_inc, CS%diag_CS) + if (CS%id_inc_s > 0) call post_data(CS%id_inc_s, S_tend_inc, CS%diag_CS) call disable_averaging(CS%diag_CS) call diag_update_remap_grids(CS%diag_CS) From 237194dfdeb4d20e907509645e83fee8f5c92472 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Jan 2023 10:23:52 -0500 Subject: [PATCH 154/629] +Add DOME_tracer and tracer_example runtime params Added the new runtime parameters DOME_TRACER_STRIPE_WIDTH, DOME_TRACER_STRIPE_LAT and DOME_TRACER_SHEET_SPACING to specify the previously hard-coded dimensional parameters in the DOME_tracer module, and added the runtime parameters TRACER_EXAMPLE_STRIPE_WIDTH and TRACER_EXAMPLE_STRIPE_LAT to specify parameters used by tracer_example. This change requires that an ocean grid type be passed to register_DOME_tracer and USER_register_tracer_example instead of a hor_index type. Descriptions of the units of a number of internal variables were added to both modules. In addition, the confusing (and dimensionally heterogeneous) trdc array in tracer_column_physics was replaced with 3 internal variables with more suggestive names. By default all answers are bitwise identical, but there are new entries in the MOM_parameter_doc.all files for cases that have USE_DOME_TRACER=True or USE_USER_TRACER_EXAMPLE=True. --- src/tracer/DOME_tracer.F90 | 65 ++++++++++------ src/tracer/MOM_tracer_flow_control.F90 | 7 +- src/tracer/tracer_example.F90 | 104 +++++++++++++------------ 3 files changed, 100 insertions(+), 76 deletions(-) diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index d1c6ebd7bf..98788843e3 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -42,10 +42,18 @@ module DOME_tracer character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, perhaps in [g kg-1] + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out, perhaps in [g kg-1] logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. + real :: stripe_width !< The meridional width of the vertical stripes in the initial condition + !! for some of the DOME tracers, in [km] or [degrees_N] or [m]. + real :: stripe_s_lat !< The southern latitude of the first vertical stripe in the initial condition + !! for some of the DOME tracers, in [km] or [degrees_N] or [m]. + real :: sheet_spacing !< The vertical spacing between successive horizontal sheets of tracer in the initial + !! conditions for some of the DOME tracers [Z ~> m], and twice the thickness of + !! these horizontal tracer sheets + integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -58,14 +66,15 @@ module DOME_tracer contains !> Register tracer fields and subroutines to be used with MOM. -function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - type(DOME_tracer_CS), pointer :: CS !< A pointer that is set to point to the +function register_DOME_tracer(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(DOME_tracer_CS), pointer :: CS !< A pointer that is set to point to the !! control structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer to the tracer registry. - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct ! Local variables character(len=80) :: name, longname @@ -75,10 +84,10 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. character(len=200) :: inputdir - real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to the tracer field + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] logical :: register_DOME_tracer integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then call MOM_error(FATAL, "DOME_register_tracer called with an "// & @@ -99,6 +108,16 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) call log_param(param_file, mdl, "INPUTDIR/DOME_TRACER_IC_FILE", & CS%tracer_IC_file) endif + call get_param(param_file, mdl, "DOME_TRACER_STRIPE_WIDTH", CS%stripe_width, & + "The meridional width of the vertical stripes in the initial condition "//& + "for the DOME tracers.", units=G%y_ax_unit_short, default=50.0) + call get_param(param_file, mdl, "DOME_TRACER_STRIPE_LAT", CS%stripe_s_lat, & + "The southern latitude of the first vertical stripe in the initial condition "//& + "for the DOME tracers.", units=G%y_ax_unit_short, default=350.0) + call get_param(param_file, mdl, "DOME_TRACER_SHEET_SPACING", CS%sheet_spacing, & + "The vertical spacing between successive horizontal sheets of tracer in the initial "//& + "conditions for the DOME tracers, and twice the thickness of these tracer sheets.", & + units="m", default=600.0, scale=US%m_to_Z) call get_param(param_file, mdl, "SPONGE", CS%use_sponge, & "If true, sponges may be applied anywhere in the domain. "//& "The exact location and properties of those sponges are "//& @@ -118,7 +137,7 @@ function register_DOME_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! calls. Curses on the designers and implementers of Fortran90. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., restart_CS=restart_CS, & flux_units=trim(flux_units), flux_scale=GV%H_to_MKS) @@ -154,16 +173,16 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables - real, allocatable :: temp(:,:,:) + real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] character(len=16) :: name ! A variable's name in a NetCDF file. - real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to the tracer field - real :: tr_y ! Initial zonally uniform tracer concentrations. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: e(SZK_(GV)+1) ! Interface heights relative to the sea surface (negative down) [Z ~> m] real :: e_top ! Height of the top of the tracer band relative to the sea surface [Z ~> m] real :: e_bot ! Height of the bottom of the tracer band relative to the sea surface [Z ~> m] - real :: d_tr ! A change in tracer concentrations, in tracer units. + real :: d_tr ! A change in tracer concentrations, in tracer units, perhaps [g kg-1] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB @@ -194,24 +213,25 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & enddo ! This sets a stripe of tracer across the basin. - do m=2,NTR ; do j=js,je ; do i=is,ie + do m=2,min(6,NTR) ; do j=js,je ; do i=is,ie tr_y = 0.0 - if ((m <= 6) .and. (G%geoLatT(i,j) > (300.0+50.0*real(m-1))) .and. & - (G%geoLatT(i,j) < (350.0+50.0*real(m-1)))) tr_y = 1.0 + if ((G%geoLatT(i,j) > (CS%stripe_s_lat + CS%stripe_width*real(m-2))) .and. & + (G%geoLatT(i,j) < (CS%stripe_s_lat + CS%stripe_width*real(m-1)))) & + tr_y = 1.0 do k=1,nz ! This adds the stripes of tracer to every layer. CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + tr_y enddo enddo ; enddo ; enddo - if (NTR > 7) then + if (NTR >= 7) then do j=js,je ; do i=is,ie e(1) = 0.0 do k=1,nz e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z do m=7,NTR - e_top = (-600.0*real(m-1) + 3000.0) * US%m_to_Z - e_bot = (-600.0*real(m-1) + 2700.0) * US%m_to_Z + e_top = -CS%sheet_spacing * (real(m-6)) + e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) if (e_top < e(K)) then if (e_top < e(K+1)) then ; d_tr = 0.0 elseif (e_bot < e(K+1)) then @@ -255,8 +275,7 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! do m=1,NTR do m=1,1 - ! This is needed to force the compiler not to do a copy in the sponge - ! calls. Curses on the designers and implementers of Fortran90. + ! This pointer is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) enddo diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index bf7076d4bb..aa3e359355 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -178,8 +178,7 @@ subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "USE_USER_TRACER_EXAMPLE", & - CS%use_USER_tracer_example, & + call get_param(param_file, mdl, "USE_USER_TRACER_EXAMPLE", CS%use_USER_tracer_example, & "If true, use the USER_tracer_example tracer package.", & default=.false.) call get_param(param_file, mdl, "USE_DOME_TRACER", CS%use_DOME_tracer, & @@ -230,10 +229,10 @@ subroutine call_tracer_register(G, GV, US, param_file, CS, tr_Reg, restart_CS) ! tracer package registration call returns a logical false if it cannot be run ! for some reason. This then overrides the run-time selection from above. if (CS%use_USER_tracer_example) CS%use_USER_tracer_example = & - USER_register_tracer_example(G%HI, GV, param_file, CS%USER_tracer_example_CSp, & + USER_register_tracer_example(G, GV, US, param_file, CS%USER_tracer_example_CSp, & tr_Reg, restart_CS) if (CS%use_DOME_tracer) CS%use_DOME_tracer = & - register_DOME_tracer(G%HI, GV, param_file, CS%DOME_tracer_CSp, & + register_DOME_tracer(G, GV, US, param_file, CS%DOME_tracer_CSp, & tr_Reg, restart_CS) if (CS%use_ISOMIP_tracer) CS%use_ISOMIP_tracer = & register_ISOMIP_tracer(G%HI, GV, param_file, CS%ISOMIP_tracer_CSp, & diff --git a/src/tracer/tracer_example.F90 b/src/tracer/tracer_example.F90 index 335f82a59b..fa9b978f9c 100644 --- a/src/tracer/tracer_example.F90 +++ b/src/tracer/tracer_example.F90 @@ -39,8 +39,13 @@ module USER_tracer_example !! to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, perhaps in [g kg-1]? + real :: land_val(NTR) = -1.0 !< The value of tr that is used where land is masked out, perhaps in [g kg-1]? + + real :: stripe_width !< The Gaussian width of the stripe in the initial condition + !! for the tracer_example tracers [L ~> m] + real :: stripe_lat !< The central latitude of the stripe in the initial condition + !! for the tracer_example tracers, in [degrees_N] or [km] or [m]. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the @@ -54,16 +59,17 @@ module USER_tracer_example contains !> This subroutine is used to register tracer fields and subroutines to be used with MOM. -function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS) - type(hor_index_type), intent(in) :: HI !< A horizontal index type structure +function USER_register_tracer_example(G, GV, US, param_file, CS, tr_Reg, restart_CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(USER_tracer_example_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module type(tracer_registry_type), pointer :: tr_Reg !< A pointer that is set to point to the control !! structure for the tracer advection and !! diffusion module - type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct ! Local variables character(len=80) :: name, longname @@ -73,10 +79,10 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] logical :: USER_register_tracer_example integer :: isd, ied, jsd, jed, nz, m - isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke if (associated(CS)) then call MOM_error(FATAL, "USER_register_tracer_example called with an "// & @@ -87,9 +93,9 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TRACER_EXAMPLE_IC_FILE", CS%tracer_IC_file, & - "The name of a file from which to read the initial "//& - "conditions for the DOME tracers, or blank to initialize "//& - "them internally.", default=" ") + "The name of a file from which to read the initial conditions for "//& + "the tracer_example tracers, or blank to initialize them internally.", & + default=" ") if (len_trim(CS%tracer_IC_file) >= 1) then call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%tracer_IC_file = trim(slasher(inputdir))//trim(CS%tracer_IC_file) @@ -100,6 +106,12 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS "If true, sponges may be applied anywhere in the domain. "//& "The exact location and properties of those sponges are "//& "specified from MOM_initialization.F90.", default=.false.) + call get_param(param_file, mdl, "TRACER_EXAMPLE_STRIPE_WIDTH", CS%stripe_width, & + "The Gaussian width of the stripe in the initial condition for the "//& + "tracer_example tracers.", units="m", default=1.0e5, scale=US%m_to_L) + call get_param(param_file, mdl, "TRACER_EXAMPLE_STRIPE_LAT", CS%stripe_lat, & + "The central latitude of the stripe in the initial condition for the "//& + "tracer_example tracers.", units=G%y_ax_unit_short, default=40.0) allocate(CS%tr(isd:ied,jsd:jed,nz,NTR), source=0.0) @@ -113,11 +125,10 @@ function USER_register_tracer_example(HI, GV, param_file, CS, tr_Reg, restart_CS if (GV%Boussinesq) then ; flux_units = "kg kg-1 m3 s-1" else ; flux_units = "kg s-1" ; endif - ! This is needed to force the compiler not to do a copy in the registration - ! calls. Curses on the designers and implementers of Fortran90. + ! This pointer is needed to force the compiler not to do a copy in the registration calls. tr_ptr => CS%tr(:,:,:,m) ! Register the tracer for horizontal advection, diffusion, and restarts. - call register_tracer(tr_ptr, tr_Reg, param_file, HI, GV, & + call register_tracer(tr_ptr, tr_Reg, param_file, G%HI, GV, & name=name, longname=longname, units="kg kg-1", & registry_diags=.true., flux_units=flux_units, & restart_CS=restart_CS) @@ -157,11 +168,11 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & !! for the sponges, if they are in use. ! Local variables - real, allocatable :: temp(:,:,:) + real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] character(len=32) :: name ! A variable's name in a NetCDF file. - real, pointer :: tr_ptr(:,:,:) => NULL() - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: tr_y ! Initial zonally uniform tracer concentrations. + real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] real :: dist2 ! The distance squared from a line [L2 ~> m2]. integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB, lntr @@ -195,9 +206,8 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! This sets a stripe of tracer across the basin. PI = 4.0*atan(1.0) do j=js,je - dist2 = (G%Rad_Earth_L * PI / 180.0)**2 * & - (G%geoLatT(i,j) - 40.0) * (G%geoLatT(i,j) - 40.0) - tr_y = 0.5 * exp( -dist2 / (1.0e5*US%m_to_L)**2 ) + dist2 = (G%Rad_Earth_L * PI / 180.0)**2 * (G%geoLatT(i,j) - CS%stripe_lat)**2 + tr_y = 0.5 * exp( -dist2 / CS%stripe_width**2 ) do k=1,nz ; do i=is,ie ! This adds the stripes of tracer to every layer. @@ -218,7 +228,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & allocate(temp(G%isd:G%ied,G%jsd:G%jed,nz)) do k=1,nz ; do j=js,je ; do i=is,ie - if (G%geoLatT(i,j) > 700.0 .and. (k > nz/2)) then + if ((G%geoLatT(i,j) > 0.5*G%len_lat + G%south_lat) .and. (k > nz/2)) then temp(i,j,k) = 1.0 else temp(i,j,k) = 0.0 @@ -227,8 +237,7 @@ subroutine USER_initialize_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & ! do m=1,NTR do m=1,1 - ! This is needed to force the compiler not to do a copy in the sponge - ! calls. Curses on the designers and implementers of Fortran90. + ! This pointer is needed to force the compiler not to do a copy in the sponge calls. tr_ptr => CS%tr(:,:,:,m) call set_up_sponge_field(temp, tr_ptr, G, GV, nz, sponge_CSp) enddo @@ -288,28 +297,25 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, real :: d1(SZI_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. + real :: diapyc_filt ! A multiplicative filter that can be set to 0 to disable diapycnal + ! advection of the tracer [nondim] + real :: dye_up ! The tracer concentration of upwelled water, perhaps in [g kg-1]? + real :: dye_down ! The tracer concentration of downwelled water, perhaps in [g kg-1]? integer :: i, j, k, is, ie, js, je, nz, m -! The following array (trdc) determines the behavior of the tracer -! diapycnal advection. The first element is 1 if tracers are -! passively advected. The second and third are the concentrations -! to which downwelling and upwelling water are set, respectively. -! For most (normal) tracers, the appropriate vales are {1,0,0}. - - real :: trdc(3) -! Uncomment the following line to dye both upwelling and downwelling. -! data trdc / 0.0,1.0,1.0 / -! Uncomment the following line to dye downwelling. -! data trdc / 0.0,1.0,0.0 / -! Uncomment the following line to dye upwelling. -! data trdc / 0.0,0.0,1.0 / -! Uncomment the following line for tracer concentrations to be set -! to zero in any diapycnal motions. -! data trdc / 0.0,0.0,0.0 / -! Uncomment the following line for most "physical" tracers, which -! are advected diapycnally in the usual manner. - data trdc / 1.0,0.0,0.0 / + ! These are the settings for most "physical" tracers, which + ! are advected diapycnally in the usual manner. + diapyc_filt = 1.0 ; dye_down = 0.0 ; dye_down = 0.0 + + ! Uncomment the following line to dye downwelling. +! diapyc_filt = 0.0 ; dye_down = 1.0 + ! Uncomment the following line to dye upwelling. +! diapyc_filt = 0.0 ; dye_up = 1.0 + ! Uncomment the following line for tracer concentrations to be set + ! to zero in any diapycnal motions. +! diapyc_filt = 0.0 ; dye_down = 0.0 ; dye_down = 0.0 + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke if (.not.associated(CS)) return @@ -330,21 +336,21 @@ subroutine tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, b_denom_1 = h_old(i,j,1) + ea(i,j,1) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,1)) ! d1(i) = b_denom_1 * b1(i) - d1(i) = trdc(1) * (b_denom_1 * b1(i)) + (1.0 - trdc(1)) + d1(i) = diapyc_filt * (b_denom_1 * b1(i)) + (1.0 - diapyc_filt) do m=1,NTR - CS%tr(i,j,1,m) = b1(i)*(hold0(i)*CS%tr(i,j,1,m) + trdc(3)*eb(i,j,1)) + CS%tr(i,j,1,m) = b1(i)*(hold0(i)*CS%tr(i,j,1,m) + dye_up*eb(i,j,1)) ! Add any surface tracer fluxes to the preceding line. enddo enddo do k=2,nz ; do i=is,ie - c1(i,k) = trdc(1) * eb(i,j,k-1) * b1(i) + c1(i,k) = diapyc_filt * eb(i,j,k-1) * b1(i) b_denom_1 = h_old(i,j,k) + d1(i)*ea(i,j,k) + h_neglect b1(i) = 1.0 / (b_denom_1 + eb(i,j,k)) - d1(i) = trdc(1) * (b_denom_1 * b1(i)) + (1.0 - trdc(1)) + d1(i) = diapyc_filt * (b_denom_1 * b1(i)) + (1.0 - diapyc_filt) do m=1,NTR CS%tr(i,j,k,m) = b1(i) * (h_old(i,j,k)*CS%tr(i,j,k,m) + & - ea(i,j,k)*(trdc(1)*CS%tr(i,j,k-1,m)+trdc(2)) + & - eb(i,j,k)*trdc(3)) + ea(i,j,k)*(diapyc_filt*CS%tr(i,j,k-1,m) + dye_down) + & + eb(i,j,k)*dye_up) enddo enddo ; enddo do m=1,NTR ; do k=nz-1,1,-1 ; do i=is,ie From 4959ee12fcba3ee01b4f91d98076885bf5e1a2ef Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Sun, 15 Jan 2023 20:52:39 -0700 Subject: [PATCH 155/629] update more write units to stdout in mom6 nuopc cap and let only rootpe write logs. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 8 +++++-- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 24 +++++++++---------- 2 files changed, 17 insertions(+), 15 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 6768a2f547..979dc3b25a 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1948,7 +1948,9 @@ subroutine ocean_model_finalize(gcomp, rc) logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' - write(*,*) 'MOM: --- finalize called ---' + if (is_root_pe()) then + write(stdout,*) 'MOM: --- finalize called ---' + endif rc = ESMF_SUCCESS call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) @@ -1978,7 +1980,9 @@ subroutine ocean_model_finalize(gcomp, rc) call io_infra_end() call MOM_infra_end() - write(*,*) 'MOM: --- completed ---' + if (is_root_pe()) then + write(stdout,*) 'MOM: --- completed ---' + endif end subroutine ocean_model_finalize diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1fb35b31a6..808e6d44d9 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -53,7 +53,7 @@ module MOM_ocean_model_nuopc use MOM_coupler_types, only : coupler_type_set_diags, coupler_type_send_data use mpp_domains_mod, only : domain2d, mpp_get_layout, mpp_get_global_domain use mpp_domains_mod, only : mpp_define_domains, mpp_get_compute_domain, mpp_get_data_domain -use fms_mod, only : stdout +use MOM_io, only : stdout use MOM_EOS, only : gsw_sp_from_sr, gsw_pt_from_ct use MOM_wave_interface, only : wave_parameters_CS, MOM_wave_interface_init use MOM_wave_interface, only : Update_Surface_Waves, query_wave_properties @@ -446,7 +446,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call diag_mediator_close_registration(OS%diag) if (is_root_pe()) & - write(*,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' + write(stdout,'(/12x,a/)') '======== COMPLETED MOM INITIALIZATION ========' call callTree_leave("ocean_model_init(") end subroutine ocean_model_init @@ -1123,20 +1123,18 @@ subroutine ocean_public_type_chksum(id, timestep, ocn) ! Local variables integer(kind=int64) :: chks ! A checksum for the field logical :: root ! True only on the root PE - integer :: outunit ! The output unit to write to - outunit = stdout() root = is_root_pe() - if (root) write(outunit,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep - chks = field_chksum(ocn%t_surf ) ; if (root) write(outunit,100) 'ocean%t_surf ', chks - chks = field_chksum(ocn%s_surf ) ; if (root) write(outunit,100) 'ocean%s_surf ', chks - chks = field_chksum(ocn%u_surf ) ; if (root) write(outunit,100) 'ocean%u_surf ', chks - chks = field_chksum(ocn%v_surf ) ; if (root) write(outunit,100) 'ocean%v_surf ', chks - chks = field_chksum(ocn%sea_lev) ; if (root) write(outunit,100) 'ocean%sea_lev ', chks - chks = field_chksum(ocn%frazil ) ; if (root) write(outunit,100) 'ocean%frazil ', chks - chks = field_chksum(ocn%melt_potential) ; if (root) write(outunit,100) 'ocean%melt_potential ', chks - call coupler_type_write_chksums(ocn%fields, outunit, 'ocean%') + if (root) write(stdout,*) "BEGIN CHECKSUM(ocean_type):: ", id, timestep + chks = field_chksum(ocn%t_surf ) ; if (root) write(stdout,100) 'ocean%t_surf ', chks + chks = field_chksum(ocn%s_surf ) ; if (root) write(stdout,100) 'ocean%s_surf ', chks + chks = field_chksum(ocn%u_surf ) ; if (root) write(stdout,100) 'ocean%u_surf ', chks + chks = field_chksum(ocn%v_surf ) ; if (root) write(stdout,100) 'ocean%v_surf ', chks + chks = field_chksum(ocn%sea_lev) ; if (root) write(stdout,100) 'ocean%sea_lev ', chks + chks = field_chksum(ocn%frazil ) ; if (root) write(stdout,100) 'ocean%frazil ', chks + chks = field_chksum(ocn%melt_potential) ; if (root) write(stdout,100) 'ocean%melt_potential ', chks + call coupler_type_write_chksums(ocn%fields, stdout, 'ocean%') 100 FORMAT(" CHECKSUM::",A20," = ",Z20) end subroutine ocean_public_type_chksum From 54b07015396d3e508db6eca774829b53d02e1dfe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Jan 2023 17:33:54 -0500 Subject: [PATCH 156/629] Named argument assignment white-space clean-up Removed extra white space around the named argument assignments for default, units or conversion arguments to align with the MOM6 style guide. Only white space is modified, and all answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 4 ++-- src/core/MOM_dynamics_unsplit.F90 | 4 ++-- src/core/MOM_dynamics_unsplit_RK2.F90 | 4 ++-- src/core/MOM_verticalGrid.F90 | 2 +- src/framework/MOM_domains.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 2 +- src/parameterizations/lateral/MOM_tidal_forcing.F90 | 2 +- src/parameterizations/vertical/MOM_CVMix_shear.F90 | 2 +- src/tracer/MOM_neutral_diffusion.F90 | 6 +++--- src/user/BFB_surface_forcing.F90 | 2 +- src/user/circle_obcs_initialization.F90 | 2 +- src/user/dumbbell_surface_forcing.F90 | 4 ++-- 14 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 748748f77f..e8909e24f9 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1545,10 +1545,10 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & - 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & + 'Effective U-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & - 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & + 'Effective V-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & x_cell_method='sum', v_extensive=.true.) if (GV%Boussinesq) then CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index a0a6633811..e6f99cc9d8 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -692,10 +692,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & - 'Effective U Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & + 'Effective U Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & - 'Effective V Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & + 'Effective V Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 85f5d6c546..fbf416d13d 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -655,10 +655,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & 'Meridional Pressure Force Acceleration', 'meter second-2', conversion=US%L_T2_to_m_s2) CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & - 'Effective U-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & + 'Effective U-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & y_cell_method='sum', v_extensive=.true.) CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & - 'Effective V-Face Area', 'm^2', conversion = GV%H_to_m*US%L_to_m, & + 'Effective V-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & x_cell_method='sum', v_extensive=.true.) id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 41d29488cd..f20c7bbd26 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -105,7 +105,7 @@ subroutine verticalGridInit( param_file, GV, US ) log_to_all=.true., debugging=.true.) call get_param(param_file, mdl, "G_EARTH", GV%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) + units="m s-2", default=9.80, scale=US%Z_to_m*US%m_s_to_L_T**2) call get_param(param_file, mdl, "RHO_0", GV%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index 47ac43df06..a0f3855d19 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -180,7 +180,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & !$ if (.not.MOM_thread_affinity_set()) then !$ call get_param(param_file, mdl, "OCEAN_OMP_THREADS", ocean_nthreads, & !$ "The number of OpenMP threads that MOM6 will use.", & - !$ default = 1, layoutParam=.true.) + !$ default=1, layoutParam=.true.) !$ call get_param(param_file, mdl, "OCEAN_OMP_HYPER_THREAD", ocean_omp_hyper_thread, & !$ "If True, use hyper-threading.", default=.false., layoutParam=.true.) !$ call set_MOM_thread_affinity(ocean_nthreads, ocean_omp_hyper_thread) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index bde8e3e219..aaa53dee59 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1468,7 +1468,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "C_P", CS%Cp, & "The heat capacity of sea water, approximated as a constant. "//& "The default value is from the TEOS-10 definition of conservative temperature.", & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 552216f41d..6691095b08 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -407,7 +407,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ fail_if_missing=.true.) call get_param(param_file, mdl, "G_EARTH", CS%g_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) + units="m s-2", default=9.80, scale=US%m_s_to_L_T**2*US%Z_to_m) call get_param(param_file, mdl, "GLEN_EXPONENT", CS%n_glen, & "nonlinearity exponent in Glen's Law", & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index c0d7e6c50c..b4092d3d43 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2040,7 +2040,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "is permitted for the thickness diffusivity. 1.0 is the "//& "marginally unstable value in a pure layered model, but "//& "much smaller numbers (e.g. 0.1) seem to work better for "//& - "ALE-based models.", units = "nondimensional", default=0.8) + "ALE-based models.", units="nondimensional", default=0.8) call get_param(param_file, mdl, "KH_ETA_CONST", CS%Kh_eta_bg, & "The background horizontal diffusivity of the interface heights (without "//& diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 520c70172f..63b0ced556 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -393,7 +393,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) if (CS%tidal_sal_from_file .or. CS%use_prev_tides) then call get_param(param_file, mdl, "TIDAL_INPUT_FILE", tidal_input_files, & "A list of input files for tidal information.", & - default = "", fail_if_missing=.true.) + default="", fail_if_missing=.true.) endif call get_param(param_file, mdl, "TIDE_REF_DATE", tide_ref_date, & diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index b69cd2daae..4f13cf5793 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -277,7 +277,7 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "SMOOTH_RI", CS%smooth_ri, & "If true, vertically smooth the Richardson "// & "number by applying a 1-2-1 filter once.", & - default = .false.) + default=.false.) call cvmix_init_shear(mix_scheme=CS%Mix_Scheme, & KPP_nu_zero=US%Z2_T_to_m2_s*CS%Nu_Zero, & KPP_Ri_zero=CS%Ri_zero, & diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index cd29e9a536..a34c2a2e58 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%kg_m3_to_R*US%m_s_to_L_T**2) 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"//& @@ -245,10 +245,10 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & "Turns on verbose output for discontinuous neutral "//& "diffusion routines.", & - default = .false.) + default=.false.) call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & "Bring down the model if a problem with heff is detected",& - default = .true.) + default=.true.) endif if (CS%interior_only) then diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index 818fa63659..f3d04980f6 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -197,7 +197,7 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index f8e9b342ac..07fc539979 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -64,7 +64,7 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus call get_param(param_file, mdl, "DISK_X_OFFSET", xOffset, & "The x-offset of the initially elevated disk in the "//& "circle_obcs test case.", units=G%x_ax_unit_short, & - default = 0.0, do_not_log=just_read) + default=0.0, do_not_log=just_read) call get_param(param_file, mdl, "DISK_IC_AMPLITUDE", IC_amp, & "Initial amplitude of interface height displacements "//& "in the circle_obcs test case.", & diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 685ffc4bee..0b8f59a6e8 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -201,7 +201,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & - units="m s-2", default = 9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) + units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& @@ -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%kg_m3_to_R*US%m_s_to_L_T**2) call get_param(param_file, mdl, "DUMBBELL_SLP_PERIOD", CS%slp_period, & "Periodicity of SLP forcing in reservoirs.", & units="days", default=1.0) From 3a9f6c731cdd1081adf6987cf0cee64ed3ad9d32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 4 Jan 2023 17:27:40 -0500 Subject: [PATCH 157/629] +Make z_tol arg non-optional to cut_off_column_top Made the previously optional z_tol argument to find_depth_of_pressure_in_cell and cut_off_column_top non-optional. It was already being provided except in a call for unit testing, so adding it as a parameter there led to a simple change and the elimination of a hard-coded dimensional parameter. Also replaced the hard-coded fill values over land in MOM_temp_salt_initialize_from_Z for temperatures and salinities before regridding with the runtime variables temp_land_fill and salt_land_fill that are already being used in the same routine. This does not change any answers, probably because these values are not actually used. All answers are bitwise identical, but some subroutine arguments have been made non-optional. --- src/core/MOM_density_integrals.F90 | 7 +++---- src/initialization/MOM_state_initialization.F90 | 12 +++++++----- 2 files changed, 10 insertions(+), 9 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 1e51612e6d..6cffea5c75 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1550,10 +1550,10 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t !! are anomalous to [R ~> kg m-3] real, intent(in) :: G_e !< Gravitational acceleration [L2 Z-1 T-2 ~> m s-2] type(EOS_type), intent(in) :: EOS !< Equation of state 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, intent(out) :: P_b !< Pressure at the bottom of the cell [R L2 T-2 ~> Pa] real, intent(out) :: z_out !< Absolute depth at which anomalous pressure = p_tgt [Z ~> m] - real, optional, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] + real, intent(in) :: z_tol !< The tolerance in finding z_out [Z ~> m] ! Local variables real :: dp ! Pressure thickness of the layer [R L2 T-2 ~> Pa] @@ -1583,8 +1583,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t Pa_left = P_t - P_tgt ! Pa_left < 0 F_r = 1. Pa_right = P_b - P_tgt ! Pa_right > 0 - Pa_tol = GxRho * 1.0e-5*US%m_to_Z - if (present(z_tol)) Pa_tol = GxRho * z_tol + Pa_tol = GxRho * z_tol F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) Pa = Pa_right - Pa_left ! To get into iterative loop diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 14459f7d0a..0504994a30 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1393,7 +1393,7 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, real, dimension(nk), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(remapping_CS), pointer :: remap_CS !< Remapping structure for remapping T and S, !! if associated - real, optional, intent(in) :: z_tol !< The tolerance with which to find the depth + real, intent(in) :: z_tol !< The tolerance with which to find the depth !! matching the specified pressure [Z ~> m]. integer, optional, intent(in) :: remap_answer_date !< The vintage of the order of arithmetic and !! expressions to use for remapping. Values below 20190101 @@ -2809,8 +2809,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just tmpT1dIn(i,j,k) = tmpT1dIn(i,j,k-1) tmpS1dIn(i,j,k) = tmpS1dIn(i,j,k-1) else ! This next block should only ever be reached over land - tmpT1dIn(i,j,k) = -99.9*US%degC_to_C ! Change to temp_land_fill - tmpS1dIn(i,j,k) = -99.9*US%ppt_to_S ! Change to salt_land_fill + 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) zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k @@ -3129,6 +3129,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) real :: P_tot, P_t, P_b ! Pressures [R L2 T-2 ~> Pa] real :: z_out ! Output height [Z ~> m] real :: I_z_scale ! The inverse of the height scale for prescribed gradients [Z-1 ~> m-1] + real :: z_tol ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. integer :: k type(remapping_CS), pointer :: remap_CS => NULL() @@ -3143,6 +3144,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) P_tot = 0. T_ref = 20.0*US%degC_to_C S_ref = 35.0*US%ppt_to_S + z_tol = 1.0e-5*US%m_to_Z do k = 1, nk z(k) = 0.5 * ( e(K) + e(K+1) ) T_t(k) = T_ref + (0. * I_z_scale) * e(k) @@ -3159,7 +3161,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) P_t = 0. do k = 1, nk call find_depth_of_pressure_in_cell(T_t(k), T_b(k), S_t(k), S_b(k), e(K), e(K+1), P_t, 0.5*P_tot, & - GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out) + GV%Rho0, GV%g_Earth, tv%eqn_of_state, US, P_b, z_out, z_tol=z_tol) write(0,*) k, US%RL2_T2_to_Pa*P_t, US%RL2_T2_to_Pa*P_b, 0.5*US%RL2_T2_to_Pa*P_tot, & US%Z_to_m*e(K), US%Z_to_m*e(K+1), US%Z_to_m*z_out P_t = P_b @@ -3171,7 +3173,7 @@ subroutine MOM_state_init_tests(G, GV, US, tv) 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, & - T, T_t, T_b, S, S_t, S_b, 0.5*P_tot, h, remap_CS) + 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(:) end subroutine MOM_state_init_tests From 68aefe134b853b751593267646a8f9dcfb6d6015 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 5 Jan 2023 08:57:02 -0500 Subject: [PATCH 158/629] Revise tc4/MOM_input with updated parameter names Updated tc4/MOM_input to reflect the newer parameter settings, including replacing the obsolete NEW_SPONGES parameter with INTERPOLATE_SPONGE_TIME_SPACE. Without this change, NEW_SPONGES can not be formally and properly obsoleted without breaking the TC testing. All answers and testing are identical with this change. --- .testing/tc4/MOM_input | 142 +++++++++++++++++++---------------------- 1 file changed, 65 insertions(+), 77 deletions(-) diff --git a/.testing/tc4/MOM_input b/.testing/tc4/MOM_input index e33bf40bf6..591ed4c788 100644 --- a/.testing/tc4/MOM_input +++ b/.testing/tc4/MOM_input @@ -1,25 +1,25 @@ ! This file was written by the model and records the non-default parameters used at run-time. ! === module MOM === - -! === module MOM_unit_scaling === -! Parameters for doing unit scaling of variables. USE_REGRIDDING = True ! [Boolean] default = False ! If True, use the ALE algorithm (regridding/remapping). If False, use the ! layered isopycnal algorithm. -DT = 1200.0 ! [s] +DT = 1200.0 ! [s] ! The (baroclinic) dynamics time step. The time-step that is actually used will ! be an integer fraction of the forcing time-step (DT_FORCING in ocean-only mode ! or the coupling timestep in coupled mode.) -DT_THERM = 3600.0 ! [s] default = 300.0 +DT_THERM = 3600.0 ! [s] default = 1200.0 ! The thermodynamic and tracer advection time step. Ideally DT_THERM should be ! an integer multiple of DT and less than the forcing or coupling time-step, ! unless THERMO_SPANS_COUPLING is true, in which case DT_THERM can be an integer - ! multiple of the coupling timestep. By default DT_THERM is set to DT. + ! multiple of the coupling timestep. By default DT_THERM is set to DT. C_P = 3925.0 ! [J kg-1 K-1] default = 3991.86795711963 ! The heat capacity of sea water, approximated as a constant. This is only used ! if ENABLE_THERMODYNAMICS is true. The default value is from the TEOS-10 ! definition of conservative temperature. +USE_PSURF_IN_EOS = False ! [Boolean] default = True + ! If true, always include the surface pressure contributions in equation of + ! state calculations. SAVE_INITIAL_CONDS = False ! [Boolean] default = False ! If true, write the initial conditions to a file given by IC_OUTPUT_FILE. @@ -33,9 +33,6 @@ NJGLOBAL = 10 ! ! The total number of thickness grid points in the y-direction in the physical ! domain. With STATIC_MEMORY_ this is set in MOM_memory.h at compile time. -! === module MOM_hor_index === -! Sets the horizontal array index types. - ! === module MOM_verticalGrid === ! Parameters providing information about the vertical grid. NK = 2 ! [nondim] @@ -65,8 +62,9 @@ TOPO_CONFIG = "file" ! ! wall at the southern face. ! halfpipe - a zonally uniform channel with a half-sine ! profile in the meridional direction. + ! bbuilder - build topography from list of functions. ! benchmark - use the benchmark test case topography. - ! Neverland - use the Neverland test case topography. + ! Neverworld - use the Neverworld test case topography. ! DOME - use a slope and channel configuration for the ! DOME sill-overflow test case. ! ISOMIP - use a slope and channel configuration for the @@ -83,9 +81,6 @@ TOPO_CONFIG = "file" ! !MAXIMUM_DEPTH = 100.0 ! [m] ! The (diagnosed) maximum depth of the ocean. -! === module MOM_open_boundary === -! Controls where open boundaries are located, what kind of boundary condition to impose, and what data to apply, -! if any. ROTATION = "betaplane" ! default = "2omegasinlat" ! This specifies how the Coriolis parameter is specified: ! 2omegasinlat - Use twice the planetary rotation rate @@ -94,6 +89,10 @@ ROTATION = "betaplane" ! default = "2omegasinlat" ! USER - call a user modified routine. F_0 = 1.0E-04 ! [s-1] default = 0.0 ! The reference value of the Coriolis parameter with the betaplane option. +GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = False + ! If true, use an older algorithm to calculate the sine and cosines needed + ! rotate between grid-oriented directions and true north and east. Differences + ! arise at the tripolar fold. ! === module MOM_tracer_registry === @@ -106,12 +105,10 @@ DRHO_DS = 0.0 ! [kg m-3 PSU-1] default = 0.8 ! When EQN_OF_STATE=LINEAR, this is the partial derivative of density with ! salinity. -! === module MOM_restart === - ! === module MOM_tracer_flow_control === ! === module MOM_coord_initialization === -COORD_CONFIG = "linear" ! +COORD_CONFIG = "linear" ! default = "none" ! This specifies how layers are to be defined: ! ALE or none - used to avoid defining layers in ALE mode ! file - read coordinate information from the file @@ -129,6 +126,10 @@ COORD_CONFIG = "linear" ! ! ts_profile - use temperature and salinity profiles ! (read from COORD_FILE) to set layer densities. ! USER - call a user modified routine. +REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = False + ! If true, uses the old remapping-via-a-delta-z method for remapping u and v. If + ! false, uses the new method that remaps between grids described by an old and + ! new thickness. REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" ! Coordinate mode for vertical regridding. Choose among the following ! possibilities: LAYER - Isopycnal or stacked shallow water layers @@ -137,6 +138,7 @@ REGRIDDING_COORDINATE_MODE = "Z*" ! default = "LAYER" ! SIGMA - terrain following coordinates ! RHO - continuous isopycnal ! HYCOM1 - HyCOM-like hybrid coordinate + ! HYBGEN - Hybrid coordinate from the Hycom hybgen code ! SLIGHT - stretched coordinates above continuous isopycnal ! ADAPTIVE - optimize for smooth neutral density surfaces !ALE_RESOLUTION = 2*50.0 ! [m] @@ -150,14 +152,14 @@ REMAPPING_SCHEME = "PPM_IH4" ! default = "PLM" ! variables. It can be one of the following schemes: PCM (1st-order ! accurate) ! PLM (2nd-order accurate) + ! PLM_HYBGEN (2nd-order accurate) ! PPM_H4 (3rd-order accurate) ! PPM_IH4 (3rd-order accurate) + ! PPM_HYBGEN (3rd-order accurate) + ! WENO_HYBGEN (3rd-order accurate) ! PQM_IH4IH3 (4th-order accurate) ! PQM_IH6IH5 (5th-order accurate) -! === module MOM_grid === -! Parameters providing information about the lateral grid. - ! === module MOM_state_initialization === INIT_LAYERS_FROM_Z_FILE = True ! [Boolean] default = False ! If true, initialize the layer thicknesses, temperatures, and salinities from a @@ -181,9 +183,9 @@ SPONGE_PTEMP_VAR = "ptemp" ! default = "PTEMP" ! The name of the potential temperature variable in SPONGE_STATE_FILE. SPONGE_SALT_VAR = "salt" ! default = "SALT" ! The name of the salinity variable in SPONGE_STATE_FILE. -NEW_SPONGES = True ! [of sponge restoring data.] default = False - ! Set True if using the newer sponging code which performs on-the-fly regridding - ! in lat-lon-time. +INTERPOLATE_SPONGE_TIME_SPACE = True ! [Boolean] default = False + ! If True, perform on-the-fly regridding in lat-lon-time of sponge restoring + ! data. ! === module MOM_sponge === SPONGE_DATA_ONGRID = True ! [Boolean] default = False @@ -192,8 +194,9 @@ SPONGE_DATA_ONGRID = True ! [Boolean] default = False ! The total number of columns where sponges are applied at h points. ! === module MOM_diag_mediator === - -! === module MOM_MEKE === +DIAG_AS_CHKSUM = True ! [Boolean] default = False + ! Instead of writing diagnostics to the diag manager, write a text file + ! containing the checksum (bitcount) of the array. ! === module MOM_lateral_mixing_coeffs === @@ -202,10 +205,10 @@ LINEAR_DRAG = True ! [Boolean] default = False ! If LINEAR_DRAG and BOTTOMDRAGLAW are defined the drag law is ! cdrag*DRAG_BG_VEL*u. HBBL = 10.0 ! [m] - ! The thickness of a bottom boundary layer with a viscosity of KVBBL if - ! BOTTOMDRAGLAW is not defined, or the thickness over which near-bottom - ! velocities are averaged for the drag law if BOTTOMDRAGLAW is defined but - ! LINEAR_DRAG is not. + ! The thickness of a bottom boundary layer with a viscosity increased by + ! KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which + ! near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is + ! defined but LINEAR_DRAG is not. CDRAG = 0.002 ! [nondim] default = 0.003 ! CDRAG is the drag coefficient relating the magnitude of the velocity field to ! the bottom stress. CDRAG is only used if BOTTOMDRAGLAW is defined. @@ -214,7 +217,7 @@ DRAG_BG_VEL = 0.05 ! [m s-1] default = 0.0 ! unresolved velocity that is combined with the resolved velocity to estimate ! the velocity magnitude. DRAG_BG_VEL is only used when BOTTOMDRAGLAW is ! defined. -BBL_USE_EOS = True ! [Boolean] default = False +BBL_USE_EOS = True ! [Boolean] default = True ! If true, use the equation of state in determining the properties of the bottom ! boundary layer. Otherwise use the layer target potential densities. BBL_THICK_MIN = 0.1 ! [m] default = 0.0 @@ -228,6 +231,13 @@ KV = 1.0E-04 ! [m2 s-1] ! === module MOM_thickness_diffuse === KHTH = 500.0 ! [m2 s-1] default = 0.0 ! The background horizontal thickness diffusivity. +USE_GM_WORK_BUG = True ! [Boolean] default = False + ! If true, compute the top-layer work tendency on the u-grid with the incorrect + ! sign, for legacy reproducibility. + +! === module MOM_porous_barriers === + +! === module MOM_dynamics_split_RK2 === BE = 0.7 ! [nondim] default = 0.6 ! If SPLIT is true, BE determines the relative weighting of a 2nd-order ! Runga-Kutta baroclinic time stepping scheme (0.5) and a backward Euler scheme @@ -258,7 +268,7 @@ BOUND_CORIOLIS = True ! [Boolean] default = False ! === module MOM_PressureForce === -! === module MOM_PressureForce_AFV === +! === module MOM_PressureForce_FV === RECONSTRUCT_FOR_PRESSURE = False ! [Boolean] default = True ! If True, use vertical reconstruction of T & S within the integrals of the FV ! pressure gradient calculation. If False, use the constant-by-layer algorithm. @@ -269,17 +279,25 @@ SMAGORINSKY_AH = True ! [Boolean] default = False ! If true, use a biharmonic Smagorinsky nonlinear eddy viscosity. SMAG_BI_CONST = 0.03 ! [nondim] default = 0.0 ! The nondimensional biharmonic Smagorinsky constant, typically 0.015 - 0.06. +USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = True + ! If true, use the land mask for the computation of thicknesses at velocity + ! locations. This eliminates the dependence on arbitrary values over land or + ! outside of the domain. ! === module MOM_vert_friction === DIRECT_STRESS = True ! [Boolean] default = False ! If true, the wind stress is distributed over the topmost HMIX_STRESS of fluid - ! (like in HYCOM), and KVML may be set to a very small value. + ! (like in HYCOM), and an added mixed layer viscosity or a physically based + ! boundary layer turbulence parameterization is not needed for stability. HMIX_FIXED = 20.0 ! [m] ! The prescribed depth over which the near-surface viscosity and diffusivity are ! elevated when the bulk mixed layer is not used. -KVML = 0.01 ! [m2 s-1] default = 1.0E-04 - ! The kinematic viscosity in the mixed layer. A typical value is ~1e-2 m2 s-1. - ! KVML is not used if BULKMIXEDLAYER is true. The default is set by KV. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through + ! infinitesimally thin surface layers. This is an older option for numerical + ! convenience without a strong physical basis, and its use is now discouraged. MAXVEL = 10.0 ! [m s-1] default = 3.0E+08 ! The maximum velocity allowed before the velocity components are truncated. @@ -304,23 +322,11 @@ DTBT = 10.0 ! [s or nondim] default = -0.98 ! DTBT to 0 is the same as setting it to -0.98. The value of DTBT that will ! actually be used is an integer fraction of DT, rounding down. -! === module MOM_mixed_layer_restrat === +! === module MOM_diagnostics === ! === module MOM_diabatic_driver === ! The following parameters are used for diabatic processes. -! === module MOM_CVMix_KPP === -! This is the MOM wrapper to CVMix:KPP -! See http://cvmix.github.io/ - -! === module MOM_tidal_mixing === -! Vertical Tidal Mixing Parameterization - -! === module MOM_CVMix_conv === -! Parameterization of enhanced mixing due to convection via CVMix - -! === module MOM_entrain_diffusive === - ! === module MOM_set_diffusivity === BBL_EFFIC = 0.0 ! [nondim] default = 0.2 ! The efficiency with which the energy extracted by bottom drag drives BBL @@ -332,29 +338,18 @@ KD = 0.0 ! [m2 s-1] ! The background diapycnal diffusivity of density in the interior. Zero or the ! molecular value, ~1e-7 m2 s-1, may be used. -! === module MOM_kappa_shear === -! Parameterization of shear-driven turbulence following Jackson, Hallberg and Legg, JPO 2008 - -! === module MOM_CVMix_shear === -! Parameterization of shear-driven turbulence via CVMix (various options) - -! === module MOM_CVMix_ddiff === -! Parameterization of mixing due to double diffusion processes via CVMix - ! === module MOM_diabatic_aux === ! The following parameters are used for auxiliary diabatic processes. -! === module MOM_regularize_layers === - ! === module MOM_opacity === +PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 1.0 + ! A thickness that is used to absorb the remaining penetrating shortwave heat + ! flux when it drops below PEN_SW_FLUX_ABSORB. ! === module MOM_tracer_advect === ! === module MOM_tracer_hor_diff === -! === module MOM_neutral_diffusion === -! This module implements neutral diffusion of tracers - ! === module MOM_sum_output === MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 ! The run will be stopped, and the day set to a very large value if the velocity @@ -362,6 +357,9 @@ MAXTRUNC = 5000 ! [truncations save_interval-1] default = 0 ! to stop if there is any truncation of velocities. DATE_STAMPED_STDOUT = False ! [Boolean] default = True ! If true, use dates (not times) in messages to stdout +ENERGYSAVEDAYS = 0.125 ! [days] default = 1.0 + ! The interval in units of TIMEUNIT between saves of the energies of the run and + ! other globally summed diagnostics. ! === module MOM_surface_forcing === VARIABLE_WINDS = False ! [Boolean] default = True @@ -375,19 +373,17 @@ BUOY_CONFIG = "zero" ! WIND_CONFIG = "zero" ! ! The character string that indicates how wind forcing is specified. Valid ! options include (file), (2gyre), (1gyre), (gyres), (zero), and (USER). - -! === module MOM_restart === +GUST_CONST = 0.02 ! [Pa] default = 0.0 + ! The background gustiness in the winds. +FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = True + ! If true correct a bug in the time-averaging of the gustless wind friction + ! velocity ! === module MOM_main (MOM_driver) === -DAYMAX = 0.25 ! [days] +DAYMAX = 0.25 ! [days] ! The final time of the whole simulation, in units of TIMEUNIT seconds. This ! also sets the potential end time of the present run segment if the end time is ! not set via ocean_solo_nml in input.nml. - -ENERGYSAVEDAYS = 0.125 ! [days] default = 1.44E+04 - ! The interval in units of TIMEUNIT between saves of the - ! energies of the run and other globally summed diagnostics. - RESTART_CONTROL = 3 ! default = 1 ! An integer whose bits encode which restart files are written. Add 2 (bit 1) ! for a time-stamped file, and odd (bit 0) for a non-time-stamped file. A @@ -405,21 +401,13 @@ MAXCPU = 2.88E+04 ! [wall-clock seconds] default = -1.0 ! === module MOM_file_parser === -DIAG_AS_CHKSUM = True DEBUG = True -USE_PSURF_IN_EOS = False ! [Boolean] default = False -GRID_ROTATION_ANGLE_BUGS = True ! [Boolean] default = True INTERPOLATE_RES_FN = True ! [Boolean] default = True GILL_EQUATORIAL_LD = False ! [Boolean] default = False -USE_GM_WORK_BUG = True ! [Boolean] default = True FIX_UNSPLIT_DT_VISC_BUG = False ! [Boolean] default = False -REMAP_UV_USING_OLD_ALG = True ! [Boolean] default = True USE_LAND_MASK_FOR_HVISC = False ! [Boolean] default = False KAPPA_SHEAR_ITER_BUG = True ! [Boolean] default = True KAPPA_SHEAR_ALL_LAYER_TKE_BUG = True ! [Boolean] default = True USE_MLD_ITERATION = False ! [Boolean] default = False -PEN_SW_ABSORB_MINTHICK = 0.001 ! [m] default = 0.001 -GUST_CONST = 0.02 ! [Pa] default = 0.02 -FIX_USTAR_GUSTLESS_BUG = False ! [Boolean] default = False From a3ef1ac8ec12d2154b5eb5f0fb3f704e401f0f31 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 5 Jan 2023 09:03:55 -0500 Subject: [PATCH 159/629] +Obsoleted the runtime parameter NEW_SPONGES Formally obsoleted the runtime parameter NEW_SPONGES. The agreed upon replacement is INTERPOLATE_SPONGE_TIME_SPACE, which has been available for almost a year. There is a warning message rather than a fatal error if NEW_SPONGES is used and both are set consistently, and a hint if they are not. Also added or amended comments describing a number of the internal variables or their units in MOM_state_initialization. All answers and output are bitwise identical. --- src/diagnostics/MOM_obsolete_params.F90 | 5 +- .../MOM_state_initialization.F90 | 170 ++++++++---------- 2 files changed, 78 insertions(+), 97 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 19f3d87429..cea0c82bcf 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -95,8 +95,9 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "MIN_Z_DIAG_INTERVAL") call obsolete_char(param_file, "Z_OUTPUT_GRID_FILE") - ! This parameter is on the to-do list to be obsoleted. - ! call obsolete_logical(param_file, "NEW_SPONGES", hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + call read_param(param_file, "INTERPOLATE_SPONGE_TIME_SPACE", test_logic) + call obsolete_logical(param_file, "NEW_SPONGES", warning_val=test_logic, & + hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0504994a30..49002d4846 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -154,9 +154,9 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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 - ! a restart file to the internal representation in this run. + ! 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. + ! 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 @@ -741,8 +741,8 @@ subroutine initialize_thickness_from_file(h, depth_tot, G, GV, US, param_file, f units="m", default=0.1, scale=US%m_to_Z, do_not_log=just_read) endif call get_param(param_file, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & - "A tolerance for detecting inconsist topography and input layer "//& - "ticknesses when ADJUST_THICKNESS is false.", & + "A tolerance for detecting inconsistent topography and input layer "//& + "thicknesses when ADJUST_THICKNESS is false.", & units="m", default=1.0, scale=US%m_to_Z, & do_not_log=(just_read.or.correct_thickness)) call get_param(param_file, mdl, "INTERFACE_IC_VAR", eta_var, & @@ -1099,8 +1099,8 @@ subroutine depress_surface(h, G, GV, US, param_file, tv, just_read, z_top_shelf) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & eta ! The free surface height that the model should use [Z ~> m]. real :: dilate ! A ratio by which layers are dilated [nondim]. - real :: scale_factor ! A scaling factor for the eta_sfc values that are read - ! in, which can be used to change units, for example. + real :: scale_factor ! A scaling factor for the eta_sfc values that are read in, + ! which can be used to change units, for example, often [Z m-1 ~> 1]. character(len=40) :: mdl = "depress_surface" ! This subroutine's name. character(len=200) :: inputdir, eta_srf_file ! Strings for file/path character(len=200) :: filename, eta_srf_var ! Strings for file/path @@ -1194,7 +1194,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T_t, T_b ! Top and bottom edge values for reconstructions ! of temperature within each layer [T ~> 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. + 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 :: z_tolerance ! The tolerance with which to find the depth matching a specified pressure [Z ~> m]. integer :: i, j, k @@ -1305,7 +1305,7 @@ subroutine calc_sfc_displacement(PF, G, GV, US, mass_shelf, tv, h) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & eta ! The free surface height that the model should use [Z ~> m]. ! temporary arrays - real, dimension(SZK_(GV)) :: rho_col ! potential density in the column for use in ice + real, dimension(SZK_(GV)) :: rho_col ! potential density in the column for use in ice [R ~> kg m-3] real, dimension(SZK_(GV)) :: rho_h ! potential density multiplied by thickness [R Z ~> kg m-2] real, dimension(SZK_(GV)) :: h_tmp ! temporary storage for thicknesses [H ~> m] real, dimension(SZK_(GV)) :: p_ref ! pressure for density [R Z ~> kg m-2] @@ -1401,10 +1401,12 @@ subroutine cut_off_column_top(nk, tv, GV, US, G_earth, depth, min_thickness, T, !! values use more robust forms of the same remapping expressions. ! Local variables - real, dimension(nk+1) :: e ! Top and bottom edge values for reconstructions [Z ~> m] - real, dimension(nk) :: h0, S0, T0, h1, S1, T1 + real, dimension(nk+1) :: e ! Top and bottom edge positions for reconstructions [Z ~> m] + 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 :: z_out, e_top + real :: z_out, e_top ! Interface height positions [Z ~> m] logical :: answers_2018 integer :: k @@ -1568,7 +1570,7 @@ subroutine initialize_velocity_uniform(u, v, G, GV, US, param_file, just_read) !! parameters without changing u or v. ! Local variables integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real :: initial_u_const, initial_v_const + real :: initial_u_const, initial_v_const ! Constant initial velocities [L T-1 ~> m s-1] character(len=200) :: mdl = "initialize_velocity_uniform" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -1609,7 +1611,7 @@ subroutine initialize_velocity_circular(u, v, G, GV, US, param_file, just_read) ! Local variables character(len=200) :: mdl = "initialize_velocity_circular" real :: circular_max_u ! The amplitude of the zonal flow [L T-1 ~> m s-1] - real :: dpi ! A local variable storing pi = 3.14159265358979... + real :: dpi ! A local variable storing pi = 3.14159265358979... [nondim] real :: psi1, psi2 ! Values of the streamfunction at two points [L2 T-1 ~> m2 s-1] 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 @@ -1722,7 +1724,8 @@ subroutine initialize_temp_salt_from_profile(T, S, G, GV, US, param_file, just_r logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing T or S. ! Local variables - real, dimension(SZK_(GV)) :: T0, S0 + real, dimension(SZK_(GV)) :: T0 ! The profile of temperatures [C ~> degC] + real, dimension(SZK_(GV)) :: S0 ! The profile of salinities [S ~> ppt] integer :: i, j, k character(len=200) :: filename, ts_file, inputdir ! Strings for file/path character(len=64) :: temp_var, salt_var ! Temperature and salinity names in files @@ -1866,12 +1869,11 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, US, param_file, just_read) !! this call will only read parameters !! without changing T or S. - integer :: k - real :: S_top, T_top ! Reference salinity [S ~> ppt] and temperature [C ~> degC] within surface layer - real :: S_range, T_range ! Range of salinities [S ~> ppt] and temperatures [C ~> degC] over the vertical - !real :: delta_S, delta_T - !real :: delta + ! Local variables + real :: S_top, S_range ! Reference salinity in the surface layer and its vertical range [S ~> ppt] + real :: T_top, T_range ! Reference temperature in the surface layer and its vertical range [C ~> degC] character(len=40) :: mdl = "initialize_temp_salt_linear" ! This subroutine's name. + integer :: k if (.not.just_read) call callTree_enter(trim(mdl)//"(), MOM_state_initialization.F90") call get_param(param_file, mdl, "T_TOP", T_top, & @@ -1889,25 +1891,18 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, US, param_file, just_read) if (just_read) return ! All run-time parameters have been read, so return. - ! Prescribe salinity - !delta_S = S_range / ( GV%ke - 1.0 ) - !S(:,:,1) = S_top - !do k=2,GV%ke - ! S(:,:,k) = S(:,:,k-1) + delta_S - !enddo + ! Prescribe salinity and temperature, with the extrapolated top interface value prescribed. do k=1,GV%ke S(:,:,k) = S_top - S_range*((real(k)-0.5)/real(GV%ke)) T(:,:,k) = T_top - T_range*((real(k)-0.5)/real(GV%ke)) enddo - ! Prescribe temperature - !delta_T = T_range / ( GV%ke - 1.0 ) - !T(:,:,1) = T_top - !do k=2,GV%ke - ! T(:,:,k) = T(:,:,k-1) + delta_T - !enddo - !delta = 1 - !T(:,:,GV%ke/2 - (delta-1):GV%ke/2 + delta) = 1.0 + ! Prescribe salinity and temperature, but with the top layer value matching the surface value. + ! S(:,:,1) = S_top ; T(:,:,1) = T_top + ! do k=2,GV%ke + ! S(:,:,k) = S_top - S_range * (real(k-1) / real(GV%ke-1)) + ! T(:,:,k) = T_top - T_range * (real(k-1) / real(GV%ke-1)) + ! enddo call callTree_leave(trim(mdl)//'()') end subroutine initialize_temp_salt_linear @@ -1945,11 +1940,17 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t real, allocatable, dimension(:,:,:) :: h ! The target interface thicknesses [H ~> m or kg m-2]. real, dimension (SZI_(G),SZJ_(G),SZK_(GV)) :: & - tmp, tmp2 ! A temporary array for tracers. + tmp, & ! A temporary array for temperatures [C ~> degC] or other tracers. + tmp2 ! A temporary array for salinities [S ~> ppt] real, dimension (SZI_(G),SZJ_(G)) :: & - tmp_2d ! A temporary array for tracers. - real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading sponge fields - real, allocatable, dimension(:,:,:) :: tmp_u,tmp_v ! A temporary array for reading sponge fields + 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_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 + ! velocities on the vertical grid of the input file [L T-1 ~> m s-1] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: Idamp_u(SZIB_(G),SZJ_(G)) ! The sponge damping rate for velocity fields [T-1 ~> s-1] @@ -1968,7 +1969,6 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t character(len=200) :: filename, inputdir ! Strings for file/path and path. logical :: use_ALE ! True if ALE is being used, False if in layered mode - logical :: new_sponge_param ! The value of a deprecated parameter. logical :: time_space_interp_sponge ! If true use sponge data that need to be interpolated in both ! the horizontal dimension and in time prior to vertical remapping. @@ -2024,34 +2024,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t endif call get_param(param_file, mdl, "USE_REGRIDDING", use_ALE, default=.false., do_not_log=.true.) - !### NEW_SPONGES should be obsoleted properly, rather than merely deprecated, at which - ! point only the else branch of the new_sponge_param block would be retained. - call get_param(param_file, mdl, "NEW_SPONGES", new_sponge_param, & - "Set True if using the newer sponging code which "//& - "performs on-the-fly regridding in lat-lon-time"//& - "of sponge restoring data.", default=.false., do_not_log=.true.) - if (new_sponge_param) then - call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & - "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & - default=.true., do_not_log=.true.) - if (.not.time_space_interp_sponge) then - call MOM_error(FATAL, " initialize_sponges: NEW_SPONGES has been deprecated, "//& - "but is set to true inconsistently with INTERPOLATE_SPONGE_TIME_SPACE. "//& - "Remove the NEW_SPONGES input line.") - else - call MOM_error(WARNING, " initialize_sponges: NEW_SPONGES has been deprecated. "//& - "Please use INTERPOLATE_SPONGE_TIME_SPACE instead. Setting "//& - "INTERPOLATE_SPONGE_TIME_SPACE = True.") - endif - call log_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & - "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & - default=.true.) - else - call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & + call get_param(param_file, mdl, "INTERPOLATE_SPONGE_TIME_SPACE", time_space_interp_sponge, & "If True, perform on-the-fly regridding in lat-lon-time of sponge restoring data.", & default=.false.) - endif - ! Read in sponge damping rate for tracers filename = trim(inputdir)//trim(damping_file) @@ -2143,8 +2118,8 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t if ( use_temperature) then call MOM_read_data(filename, potemp_var, tmp(:,:,:), G%Domain, scale=US%degC_to_C) call set_up_sponge_field(tmp, tv%T, G, GV, nz, Layer_CSp) - call MOM_read_data(filename, salin_var, tmp(:,:,:), G%Domain, scale=US%ppt_to_S) - call set_up_sponge_field(tmp, tv%S, G, GV, nz, Layer_CSp) + call MOM_read_data(filename, salin_var, tmp2(:,:,:), G%Domain, scale=US%ppt_to_S) + call set_up_sponge_field(tmp2, tv%S, G, GV, nz, Layer_CSp) endif ! else @@ -2247,30 +2222,34 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p oda_incupd_CSp, restart_CS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: use_temperature !< If true, T & S are state variables. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic - !! variables. + !! variables. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< The zonal velocity that is being + intent(in) :: u !< The zonal velocity that is being !! initialized [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< The meridional velocity that is being - !! initialized [L T-1 ~> m s-1] + intent(in) :: v !< The meridional velocity that is being + !! initialized [L T-1 ~> m s-1] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(oda_incupd_CS), pointer :: oda_incupd_CSp !< A pointer that is set to point to the control - !! structure for this module. + !! structure for this module. type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure - type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in - !! overrides any value set for - !Time. + type(time_type), intent(in) :: Time !< Time at the start of the run segment. Time_in + !! overrides any value set for Time. ! Local variables - real, allocatable, dimension(:,:,:) :: hoda ! The layer thk inc. and oda layer thk [H ~> m or kg m-2]. - real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda fields - real, allocatable, dimension(:,:,:) :: tmp_u, tmp_v ! Temporary arrays for reading oda fields + real, allocatable, dimension(:,:,:) :: hoda ! The layer thickness increment and oda layer thickness [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: tmp_tr ! A temporary array for reading oda tracer increments + ! on the vertical grid of the input file, used for both + ! temperatures [C ~> degC] and salinities [S ~> ppt] + real, allocatable, dimension(:,:,:) :: tmp_u ! Temporary array for reading oda zonal velocity + ! increments on the vertical grid of the input file [L T-1 ~> m s-1] + real, allocatable, dimension(:,:,:) :: tmp_v ! Temporary array for reading oda meridional velocity + ! increments on the vertical grid of the input file [L T-1 ~> m s-1] integer :: is, ie, js, je, nz integer :: isd, ied, jsd, jed @@ -2375,7 +2354,7 @@ subroutine initialize_oda_incupd_file(G, GV, US, use_temperature, tv, h, u, v, p allocate(tmp_v(isd:ied,G%JsdB:G%JedB,nz_data), source=0.0) call MOM_read_vector(filename, uinc_var, vinc_var, tmp_u, tmp_v, G%Domain,scale=US%m_s_to_L_T) call set_up_oda_incupd_vel_field(tmp_u, tmp_v, G, GV, oda_incupd_CSp) - deallocate(tmp_u,tmp_v) + deallocate(tmp_u, tmp_v) endif ! calculate increments if input are full fields @@ -2415,8 +2394,8 @@ subroutine compute_global_grid_integrals(G, US) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming - real :: area_scale + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming ! Masked and unscaled areas for sums [m2] + real :: area_scale ! A conversion factor to prepare for reproducing sums [m2 L-2 ~> 1] integer :: i,j area_scale = US%L_to_m**2 @@ -2536,7 +2515,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just 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 :: dz_interface ! Change in position of interface due to regridding + 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]. type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -2685,8 +2665,8 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just units="m", default=0.1, scale=US%m_to_Z, & do_not_log=(just_read.or..not.correct_thickness)) call get_param(PF, mdl, "DZ_BOTTOM_TOLERANCE", tol_dz_bot, & - "A tolerance for detecting inconsist topography and input layer "//& - "ticknesses when ADJUST_THICKNESS is false.", & + "A tolerance for detecting inconsistent topography and input layer "//& + "thicknesses when ADJUST_THICKNESS is false.", & units="m", default=1.0, scale=US%m_to_Z, & do_not_log=(just_read.or.correct_thickness)) @@ -2727,12 +2707,12 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just units="1e-3", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "HORIZ_INTERP_TOL_TEMP", tol_temp, & "The tolerance in temperature changes between iterations when interpolating "//& - "ifrom an nput dataset using horiz_interp_and_extrap_tracer. This routine "//& + "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& "converges slowly, so an overly small tolerance can get expensive.", & units="degC", default=1.0e-3, scale=US%degC_to_C, do_not_log=just_read) call get_param(PF, mdl, "HORIZ_INTERP_TOL_SALIN", tol_sal, & "The tolerance in salinity changes between iterations when interpolating "//& - "ifrom an nput dataset using horiz_interp_and_extrap_tracer. This routine "//& + "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& "converges slowly, so an overly small tolerance can get expensive.", & units="1e-3", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) @@ -2796,11 +2776,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just allocate( tmpT1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) allocate( tmpS1dIn(isd:ied,jsd:jed,nkd), source=0.0 ) do j = js, je ; do i = is, ie - if (G%mask2dT(i,j)>0.) then + if (G%mask2dT(i,j) > 0.) then zTopOfCell = 0. ; zBottomOfCell = 0. tmp_mask_in(i,j,1:kd) = mask_z(i,j,:) do k = 1, nkd - if (tmp_mask_in(i,j,k)>0. .and. k<=kd) then + if ((tmp_mask_in(i,j,k) > 0.) .and. (k <= kd)) then zBottomOfCell = max( z_edges_in(k+1), Z_bottom(i,j)) tmpT1dIn(i,j,k) = temp_z(i,j,k) tmpS1dIn(i,j,k) = salt_z(i,j,k) @@ -2831,7 +2811,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just hTarget = getCoordinateResolution( regridCS ) do j = js, je ; do i = is, ie h(i,j,:) = 0. - if (G%mask2dT(i,j)>0.) then + if (G%mask2dT(i,j) > 0.) then ! Build the target grid combining hTarget and topography zTopOfCell = 0. ; zBottomOfCell = 0. do k = 1, nz @@ -3013,7 +2993,7 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, n real, dimension(SZK_(GV)+1) :: zi_ ! A column interface heights (negative downward) [Z ~> m]. real :: slope ! The rate of change of height with density [Z R-1 ~> m4 kg-1] real :: drhodz ! A local vertical density gradient [R Z-1 ~> kg m-4] - real, parameter :: zoff=0.999 + real, parameter :: zoff = 0.999 ! A small fractional adjustment to the density differences [nondim] logical :: unstable ! True if the column is statically unstable anywhere. integer :: nlevs_data ! The number of data values in a column. logical :: work_down ! This indicates whether this pass goes up or down the water column. @@ -3028,18 +3008,18 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, n nlevs_data = nlevs(i,j) do k=1,nlevs_data ; rho_(k) = rho(i,j,k) ; enddo - unstable=.true. + unstable = .true. work_down = .true. do while (unstable) ! Modify the input profile until it no longer has densities that decrease with depth. - unstable=.false. + unstable = .false. if (work_down) then - do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0 ) then + do k=2,nlevs_data-1 ; if (rho_(k) - rho_(k-1) < 0.0) then if (k == 2) then rho_(k-1) = rho_(k) - eps_rho else drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. + if (drhodz < 0.0) unstable = .true. rho_(k) = rho_(k-1) + drhodz*zoff*(zin(k)-zin(k-1)) endif endif ; enddo @@ -3054,7 +3034,7 @@ subroutine find_interfaces(rho, zin, nk_data, Rb, Z_bot, zi, G, GV, US, nlevs, n endif else drhodz = (rho_(k+1)-rho_(k-1)) / (zin(k+1)-zin(k-1)) - if (drhodz < 0.0) unstable=.true. + if (drhodz < 0.0) unstable = .true. rho_(k) = rho_(k+1) - drhodz*(zin(k+1)-zin(k)) endif endif ; enddo From 3f82a92bbe682a6d7dfafbf2d2de822940843389 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 5 Jan 2023 11:29:33 -0500 Subject: [PATCH 160/629] Updated comments in MOM_initialize_topography Updated the comments in MOM_initialize_topography to reflect the fact that US is no longer an optional argument. Only comments are changed, and all answers are bitwise identical. --- src/initialization/MOM_fixed_initialization.F90 | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 16702b6901..0cc3794543 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -174,14 +174,13 @@ subroutine MOM_initialize_fixed(G, US, OBC, PF, write_geom, output_dir) end subroutine MOM_initialize_fixed -!> MOM_initialize_topography makes the appropriate call to set up the bathymetry. At this -!! point the topography is in units of [Z ~> m] or [m], depending on the presence of US. +!> MOM_initialize_topography makes the appropriate call to set up the bathymetry in units of [Z ~> m]. subroutine MOM_initialize_topography(D, max_depth, G, PF, US) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth [Z ~> m] or [m] + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: PF !< Parameter file structure - real, intent(out) :: max_depth !< Maximum depth of model [Z ~> m] or [m] + real, intent(out) :: max_depth !< Maximum depth of model [Z ~> m] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! This subroutine makes the appropriate call to set up the bottom depth. From 4be437a0bbc44111fed7ae7fcde8635bddc1e9d3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 5 Jan 2023 11:31:16 -0500 Subject: [PATCH 161/629] Added units to comments in MOM_grid_initialization Added a description of the units to the comments for each of the real variables in MOM_grid_initialization and MOM_shared_initialization. Only comments are changed, and all answers are bitwise identical. --- src/initialization/MOM_grid_initialize.F90 | 139 ++++++++++-------- .../MOM_shared_initialization.F90 | 2 +- 2 files changed, 75 insertions(+), 66 deletions(-) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index 964007c663..e622b11805 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -177,7 +177,7 @@ subroutine set_grid_metrics_from_mosaic(G, param_file, US) real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-2:2*G%jed+1) :: tmpU ! East face supergrid spacing [L ~> m] real, dimension(2*G%isd-2:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpV ! North face supergrid spacing [L ~> m] real, dimension(2*G%isd-3:2*G%ied+1,2*G%jsd-3:2*G%jed+1) :: tmpZ ! Corner latitudes or longitudes [degN] or [degE] - real, dimension(:,:), allocatable :: tmpGlbl ! A global array of axis labels + real, dimension(:,:), allocatable :: tmpGlbl ! A global array of axis labels [degrees_N] or [km] or [m] character(len=200) :: filename, grid_file, inputdir character(len=64) :: mdl = "MOM_grid_init set_grid_metrics_from_mosaic" type(MOM_domain_type), pointer :: SGdom => NULL() ! Supergrid domain @@ -361,8 +361,8 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) ! Local variables integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, I1off, J1off integer :: niglobal, njglobal - real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) - real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) + real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) ! Axis labels [degrees_N] or [km] or [m] + real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] or [km] or [m] real :: dx_everywhere, dy_everywhere ! Grid spacings [L ~> m]. real :: I_dx, I_dy ! Inverse grid spacings [L-1 ~> m-1]. real :: PI @@ -498,13 +498,17 @@ subroutine set_grid_metrics_spherical(G, param_file, US) type(param_file_type), intent(in) :: param_file !< Parameter file structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: PI, PI_180! PI = 3.1415926... as 4*atan(1) + real :: PI ! PI = 3.1415926... as 4*atan(1) [nondim] + real :: PI_180 ! The conversion factor from degrees to radians [radians degree-1] integer :: i, j, isd, ied, jsd, jed integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB integer :: i_offset, j_offset - real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) - real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) - real :: dLon, dLat, latitude, dL_di + real :: grid_latT(G%jsd:G%jed), grid_latB(G%JsdB:G%JedB) ! Axis labels [degrees_N] + real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] + real :: dLon ! The change in longitude between successive grid points [degrees_E] + real :: dLat ! The change in latitude between successive grid points [degrees_N] + real :: dL_di ! dLon rescaled from degrees to radians [radians] + real :: latitude ! The latitude of a grid point [degrees_N] character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_spherical" is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -517,7 +521,7 @@ subroutine set_grid_metrics_spherical(G, param_file, US) ! Calculate the values of the metric terms that might be used ! and save them in arrays. - PI = 4.0*atan(1.0); PI_180 = atan(1.0)/45. + PI = 4.0*atan(1.0) ; PI_180 = atan(1.0)/45. call get_param(param_file, mdl, "SOUTHLAT", G%south_lat, & "The southern latitude of the domain.", units="degrees_N", & @@ -639,19 +643,23 @@ subroutine set_grid_metrics_mercator(G, param_file, US) integer :: I_off, J_off type(GPS) :: GP character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_mercator" - real :: PI, PI_2! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 - real :: y_q, y_h, jd, x_q, x_h, id + real :: PI, PI_2 ! PI = 3.1415926... as 4*atan(1), PI_2 = (PI) /2.0 [nondim] + real :: y_q, y_h ! Latitudes of a point [radians] + real :: id ! The i-grid space positions whose longitude is being sought [gridpoints] + real :: jd ! The j-grid space positions whose latitude is being sought [gridpoints] + real :: x_q, x_h ! Longitudes of a point [radians] real, dimension(G%isd:G%ied,G%jsd:G%jed) :: & - xh, yh ! Latitude and longitude of h points in radians. + xh, yh ! Latitude and longitude of h points in radians [radians] real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: & - xu, yu ! Latitude and longitude of u points in radians. + xu, yu ! Latitude and longitude of u points in radians [radians] real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: & - xv, yv ! Latitude and longitude of v points in radians. + xv, yv ! Latitude and longitude of v points in radians [radians] real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB) :: & - xq, yq ! Latitude and longitude of q points in radians. + xq, yq ! Latitude and longitude of q points in radians [radians] real :: fnRef ! fnRef is the value of Int_dj_dy or ! Int_dj_dy at a latitude or longitude that is - real :: jRef, iRef ! being set to be at grid index jRef or iRef. + ! being set to be at grid index jRef or iRef [gridpoints] + real :: jRef, iRef ! The grid index at which fnRef is evaluated [gridpoints] integer :: itt1, itt2 logical, parameter :: simple_area = .true. integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, IsdB, IedB, JsdB, JedB @@ -860,8 +868,8 @@ end subroutine set_grid_metrics_mercator !> This function returns the grid spacing in the logical x direction in [L ~> m]. function ds_di(x, y, GP) - real, intent(in) :: x !< The longitude in question - real, intent(in) :: y !< The latitude in question + real, intent(in) :: x !< The longitude in question [radians] + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_di ! The returned grid spacing [L ~> m] @@ -874,8 +882,8 @@ end function ds_di !> This function returns the grid spacing in the logical y direction in [L ~> m]. function ds_dj(x, y, GP) - real, intent(in) :: x !< The longitude in question - real, intent(in) :: y !< The latitude in question + real, intent(in) :: x !< The longitude in question [radians] + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters real :: ds_dj ! The returned grid spacing [L ~> m] @@ -887,16 +895,17 @@ function ds_dj(x, y, GP) end function ds_dj !> This function returns the contribution from the line integral along one of the four sides of a -!! cell face to the area of a cell, assuming that the sides follow a linear path in latitude and -!! longitude (i.e., on a Mercator grid). +!! cell face to the area of a cell, in [radians2], assuming that the sides follow a linear path in +!! latitude and longitude (i.e., on a Mercator grid). function dL(x1, x2, y1, y2) - real, intent(in) :: x1 !< Segment starting longitude, in degrees E. - real, intent(in) :: x2 !< Segment ending longitude, in degrees E. - real, intent(in) :: y1 !< Segment ending latitude, in degrees N. - real, intent(in) :: y2 !< Segment ending latitude, in degrees N. + real, intent(in) :: x1 !< Segment starting longitude [radians] + real, intent(in) :: x2 !< Segment ending longitude [radians] + real, intent(in) :: y1 !< Segment starting latitude [radians] + real, intent(in) :: y2 !< Segment ending latitude [radians] ! Local variables - real :: dL - real :: r, dy + real :: dL ! A contribution to the spanned area the surface of the sphere [radian2] + real :: r ! A contribution from the range of latitudes, including trigonometric factors [radians] + real :: dy ! The spanned range of latitudes [radians] dy = y2 - y1 @@ -914,22 +923,24 @@ end function dL !! Newton's method that were used to polish the root. function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) real :: find_root !< The value of y where fn(y) = fnval that will be returned - real, external :: fn !< The external function whose root is being sought - real, external :: dy_df !< The inverse of the derivative of that function - type(GPS), intent(in) :: GP !< A structure of grid parameters - real, intent(in) :: fnval !< The value of fn being sought - real, intent(in) :: y1 !< A first guess for y - real, intent(in) :: ymin !< The minimum permitted value of y - real, intent(in) :: ymax !< The maximum permitted value of y + real, external :: fn !< The external function whose root is being sought [gridpoints] + real, external :: dy_df !< The inverse of the derivative of that function [radian gridpoint-1] + type(GPS), intent(in) :: GP !< A structure of grid parameters + real, intent(in) :: fnval !< The value of fn being sought [gridpoints] + real, intent(in) :: y1 !< A first guess for y [radians] + real, intent(in) :: ymin !< The minimum permitted value of y [radians] + real, intent(in) :: ymax !< The maximum permitted value of y [radians] integer, intent(out) :: ittmax !< The number of iterations used to polish the root ! Local variables - real :: y, y_next - real :: ybot, ytop, fnbot, fntop + real :: y, y_next ! Successive guesses at the root position [radians] + real :: ybot, ytop ! Brackets bounding the root [radians] + real :: fnbot, fntop ! Values of fn at the bounding values of y [gridpoints] + real :: dy_dfn ! The inverse of the local derivative of fn with y [radian gridpoint-1] + real :: dy ! The jump to the next guess of y [radians] + real :: fny ! The difference between fn(y) and the target value [gridpoints] integer :: itt character(len=256) :: warnmesg - real :: dy_dfn, dy, fny - ! Bracket the root. Do not use the bounding values because the value at the ! function at the bounds could be infinite, as is the case for the Mercator ! grid recursion relation. (I.e., this is a search on an open interval.) @@ -1022,40 +1033,40 @@ function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) find_root = y end function find_root -!> This function calculates and returns the value of dx/di, where x is the -!! longitude in Radians, and i is the integral north-south grid index. +!> This function calculates and returns the value of dx/di in [radian gridpoint-1], +!! where x is the longitude in Radians, and i is the integral east-west grid index. function dx_di(x, GP) - real, intent(in) :: x !< The longitude in question + real, intent(in) :: x !< The longitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: dx_di + real :: dx_di ! The derivative of zonal position with the grid index [radian gridpoint-1] dx_di = (GP%len_lon * 4.0*atan(1.0)) / (180.0 * GP%niglobal) end function dx_di !> This function calculates and returns the integral of the inverse -!! of dx/di to the point x, in radians. +!! of dx/di to the point x, in radians [gridpoints] function Int_di_dx(x, GP) - real, intent(in) :: x !< The longitude in question + real, intent(in) :: x !< The longitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: Int_di_dx + real :: Int_di_dx ! A position in the global i-index space [gridpoints] Int_di_dx = x * ((180.0 * GP%niglobal) / (GP%len_lon * 4.0*atan(1.0))) end function Int_di_dx -!> This subroutine calculates and returns the value of dy/dj, where y is the -!! latitude in Radians, and j is the integral north-south grid index. +!> This subroutine calculates and returns the value of dy/dj in [radian gridpoint-1], +!! where y is the latitude in Radians, and j is the integral north-south grid index. function dy_dj(y, GP) - real, intent(in) :: y !< The latitude in question + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: dy_dj + real :: dy_dj ! The derivative of meridional position with the grid index [radian gridpoint-1] ! Local variables - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: C0 ! The constant that converts the nominal y-spacing in - ! gridpoints to the nominal spacing in Radians. + ! gridpoints to the nominal spacing in Radians [radian gridpoint-1] real :: y_eq_enhance ! The latitude in radians within which the resolution - ! is enhanced. + ! is enhanced [radians] PI = 4.0*atan(1.0) if (GP%isotropic) then C0 = (GP%len_lon * PI) / (180.0 * GP%niglobal) @@ -1074,21 +1085,19 @@ function dy_dj(y, GP) end function dy_dj !> This subroutine calculates and returns the integral of the inverse -!! of dy/dj to the point y, in radians. +!! of dy/dj to the point y in radians [gridpoints] function Int_dj_dy(y, GP) - real, intent(in) :: y !< The latitude in question + real, intent(in) :: y !< The latitude in question [radians] type(GPS), intent(in) :: GP !< A structure of grid parameters - real :: Int_dj_dy + real :: Int_dj_dy ! The grid position of latitude y [gridpoints] ! Local variables - real :: I_C0 = 0.0 ! The inverse of the constant that converts the + real :: I_C0 ! The inverse of the constant that converts the ! nominal spacing in gridpoints to the nominal - ! spacing in Radians. - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: y_eq_enhance ! The latitude in radians from - ! from the equator within which the - ! meridional grid spacing is enhanced by - ! a factor of GP%lat_enhance_factor. - real :: r + ! spacing in Radians [gridpoint radian-1] + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: y_eq_enhance ! The latitude in radians from from the equator within which the meridional + ! grid spacing is enhanced by a factor of GP%lat_enhance_factor [radians] + real :: r ! The y grid position in the global index space [gridpoints] PI = 4.0*atan(1.0) if (GP%isotropic) then @@ -1119,9 +1128,9 @@ end function Int_dj_dy !> Extrapolates missing metric data into all the halo regions. subroutine extrapolate_metric(var, jh, missing) - real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos + real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos [A] integer, intent(in) :: jh !< The size of the halos to be filled - real, optional, intent(in) :: missing !< The missing data fill value, 0 by default. + real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [A] ! Local variables real :: badval integer :: i,j diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 73be3f5843..acffc9c927 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -1309,7 +1309,7 @@ subroutine compute_global_grid_integrals(G, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: tmpForSumming ! Masked and unscaled cell areas [m2] real :: area_scale ! A scaling factor for area into MKS units [m2 L-2 ~> 1] integer :: i,j From 297cc89cbee4090fc8035023101747e4e3864ebb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 9 Jan 2023 05:21:04 -0500 Subject: [PATCH 162/629] Document units of variables in MOM_wave_speed Added or amended comments to document the units of numerous internal variables and function arguments in MOM_wave_speed.F90. Only comments are changed, but the position of some variable declarations is changed to help the comments make more sense. All answers are bitwise identical and no output is changed. --- src/diagnostics/MOM_wave_speed.F90 | 129 ++++++++++++++++++----------- 1 file changed, 81 insertions(+), 48 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 36dc884679..3dcad440ce 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -35,7 +35,7 @@ module MOM_wave_speed !! internal wave speed. real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as !! monotonic for the purposes of calculating the equivalent barotropic - !! wave speed. This parameter controls the default behavior of + !! wave speed [nondim]. This parameter controls the default behavior of !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of !! calculating the equivalent barotropic wave speed [Z ~> m]. @@ -72,7 +72,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction !! of water column over which N2 is limited as monotonic - !! for the purposes of calculating vertical modal structure. + !! for the purposes of calculating vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical !! modal structure [Z ~> m]. @@ -104,11 +104,14 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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 :: det, ddet + real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the + ! units of the eigenvalue change with the number of layers and because of the + ! dynamic rescaling that is used to keep det in a numerically representable range, + ! the units of of det are hard to interpret, but det/ddet is always in units + ! of [T2 L-2 ~> s2 m-2] real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] - real :: min_h_frac ! [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)) :: & htot, hmin, & ! Thicknesses [Z ~> m] @@ -122,29 +125,40 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. - real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant - ! and its derivative with lam between rows of the Thomas algorithm solver. The - ! exact value should not matter for the final result if it is an even power of 2. + real :: 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]. + ! The exact value should not matter for the final result if it is an even power of 2. real :: tol_Hfrac ! Layers that together are smaller than this fraction of - ! the total water column can be merged for efficiency. + ! the total water column can be merged for efficiency [nondim]. + real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim] real :: tol_merge ! The fractional change in estimated wave speed that is allowed ! when deciding to merge layers in the calculation [nondim] - real :: rescale, I_rescale + real :: rescale ! A rescaling factor to control the magnitude of the determinant [nondim] + real :: I_rescale ! The reciprocal of the rescaling factor to control the magnitude of the determinant [nondim] integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 10 - real :: lam_it(max_itt), det_it(max_itt), ddet_it(max_itt) + real :: lam_it(max_itt) ! The guess at the eignevalue with each iteration [T2 L-2 ~> s2 m-2] + real :: det_it(max_itt), ddet_it(max_itt) ! The determinant of the matrix and its derivative with lam + ! with each iteration. Because of all of the dynamic rescaling of the determinant + ! between rows, its units are not easily interpretable, but the ratio of det/ddet + ! always has units of [T2 L-2 ~> s2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using an 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. integer :: kc ! The number of layers in the column after merging integer :: i, j, k, k2, itt, is, ie, js, je, nz - real :: hw, sum_hc + real :: hw ! The mean of the adjacent layer thicknesses [Z ~> m] + real :: sum_hc ! The sum of the layer thicknesses [Z ~> m] real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] real :: N2min ! A minimum buoyancy frequency [T-2 ~> s-2] logical :: l_use_ebt_mode, calc_modal_structure - real :: l_mono_N2_column_fraction, l_mono_N2_depth - real :: mode_struct(SZK_(GV)), ms_min, ms_max, ms_sq + real :: l_mono_N2_column_fraction ! A local value of mono_N2_column_fraction [nondim] + real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [Z ~> m] + real :: mode_struct(SZK_(GV)) ! 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 :: 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] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -525,6 +539,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (calc_modal_structure) then call tdma6(kc, Igu, Igl, lam, mode_struct) + ! Note that tdma6 changes the units of mode_struct to [L2 T-2 ~> m2 s-2] ms_min = mode_struct(1) ms_max = mode_struct(1) ms_sq = mode_struct(1)**2 @@ -540,6 +555,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else mode_struct(1:kc) = mode_struct(1:kc) / sqrt( ms_sq ) endif + ! After the nondimensionalization above, mode_struct is once again [nondim] endif if (abs(dlam) < tol_solve*lam) exit @@ -590,13 +606,13 @@ subroutine tdma6(n, a, c, lam, y) real, dimension(:), intent(in) :: a !< Lower diagonal [T2 L-2 ~> s2 m-2] real, dimension(:), intent(in) :: c !< Upper diagonal [T2 L-2 ~> s2 m-2] real, intent(in) :: lam !< Scalar subtracted from leading diagonal [T2 L-2 ~> s2 m-2] - real, dimension(:), intent(inout) :: y !< RHS on entry, result on exit + real, dimension(:), intent(inout) :: y !< RHS on entry [A ~> a], result on exit [A L2 T-2 ~> a m2 s-2] ! Local variables real :: lambda ! A temporary variable in [T2 L-2 ~> s2 m-2] real :: beta(n) ! A temporary variable in [T2 L-2 ~> s2 m-2] real :: I_beta(n) ! A temporary variable in [L2 T-2 ~> m2 s-2] - real :: yy(n) ! A temporary variable with the same units as y on entry. + real :: yy(n) ! A temporary variable with the same units as y on entry [A ~> a] integer :: k, m lambda = lam @@ -634,16 +650,16 @@ 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(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] + 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), optional, intent(in) :: CS !< Wave speed control struct logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire computational domain. + !! over the entire data domain. ! Local variables real, dimension(SZK_(GV)+1) :: & @@ -670,23 +686,34 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) real :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] real :: c1_thresh ! if c1 is below this value, don't bother calculating ! cn values for higher modes [L T-1 ~> m s-1] - real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant - ! and its derivative with lam between rows of the Thomas algorithm solver. The - ! exact value should not matter for the final result if it is an even power of 2. - real :: det, ddet ! determinant & its derivative of eigen system + 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]. + ! The exact value should not matter for the final result if it is an even power of 2. + real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the + ! units of the eigenvalue change with the number of layers and because of the + ! dynamic rescaling that is used to keep det in a numerically representable range, + ! the units of of det are hard to interpret, but det/ddet is always in units + ! of [T2 L-2 ~> s2 m-2] real :: lam_1 ! approximate mode-1 eigenvalue [T2 L-2 ~> s2 m-2] real :: lam_n ! approximate mode-n eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lamMin ! minimum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamMax ! maximum lam value for root searching range [T2 L-2 ~> s2 m-2] real :: lamInc ! width of moving window for root searching [T2 L-2 ~> s2 m-2] - real :: det_l,det_r ! determinant value at left and right of window - real :: ddet_l,ddet_r ! derivative of determinant at left and right of window - real :: det_sub,ddet_sub! derivative of determinant at subinterval endpoint - real :: xl,xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] + real :: det_l, ddet_l ! determinant of the eigensystem and its derivative with lam at the lower + ! end of the range of values bracketing a particular root, in dynamically + ! rescaled units that may differ from the other det variables, but such + ! that the units of det_l/ddet_l are [T2 L-2 ~> s2 m-2] + real :: det_r, ddet_r ! determinant and its derivative with lam at the lower end of the + ! bracket in arbitrarily rescaled units, but such that the units of + ! det_r/ddet_r are [T2 L-2 ~> s2 m-2] + real :: det_sub, ddet_sub ! determinant and its derivative with lam at a subinterval endpoint that + ! is a candidate for a new bracket endpoint in arbitrarily rescaled units, + ! but such that the units of det_sub/ddet_sub are [T2 L-2 ~> s2 m-2] + real :: xl, xr ! lam guesses at left and right of window [T2 L-2 ~> s2 m-2] real :: xl_sub ! lam guess at left of subinterval window [T2 L-2 ~> s2 m-2] - real,dimension(nmodes) :: & - xbl,xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] + real, dimension(nmodes) :: & + xbl, xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] @@ -698,14 +725,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) HxR_here ! A layer integrated density [R Z ~> kg m-2] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] - real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] - real, parameter :: reduct_factor = 0.5 - ! A factor used in setting speed2_min [nondim] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] + real, parameter :: reduct_factor = 0.5 ! A factor used in setting speed2_min [nondim] + real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. real :: tol_Hfrac ! Layers that together are smaller than this fraction of - ! the total water column can be merged for efficiency. + ! the total water column can be merged for efficiency [nondim]. real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. real :: tol_solve ! The fractional tolerance with which to solve for the wave speeds [nondim]. real :: tol_merge ! The fractional change in estimated wave speed that is allowed @@ -1127,20 +1153,27 @@ end subroutine wave_speeds !! signs are typically used, so internal rescaling by consistent factors are used to avoid !! over- or underflow. subroutine tridiag_det(a, c, ks, ke, lam, det, ddet, row_scale) - real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) - real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) + real, dimension(:), intent(in) :: a !< Lower diagonal of matrix (first entry unused) [T2 L-2 ~> s2 m-2] + real, dimension(:), intent(in) :: c !< Upper diagonal of matrix (last entry unused) [T2 L-2 ~> s2 m-2] integer, intent(in) :: ks !< Starting index to use in determinant integer, intent(in) :: ke !< Ending index to use in determinant - real, intent(in) :: lam !< Value subtracted from b - real, intent(out):: det !< Determinant - real, intent(out):: ddet !< Derivative of determinant with lam - real, intent(in) :: row_scale !< A scaling factor of the rows of the - !! matrix to limit the growth of the determinant + real, intent(in) :: lam !< Value subtracted from b [T2 L-2 ~> s2 m-2] + real, intent(out):: det !< Determinant of the matrix in dynamically rescaled units that + !! depend on the number of rows and the cumulative magnitude of + !! det and are therefore difficult to interpret, but the units + !! of det/ddet are always in [T2 L-2 ~> s2 m-2] + real, intent(out):: ddet !< Derivative of determinant with lam in units that are dynamically + !! rescaled along with those of det, such that the units of + !! det/ddet are always in [T2 L-2 ~> s2 m-2] + real, intent(in) :: row_scale !< A scaling factor of the rows of the matrix to + !! limit the growth of the determinant [L2 s2 T-2 m-2 ~> 1] ! Local variables - real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers. - real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two layers. - real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling - real :: I_rescale ! inverse of rescale + real :: detKm1, detKm2 ! Cumulative value of the determinant for the previous two layers in units + ! that vary with the number of layers that have been worked on [various] + real :: ddetKm1, ddetKm2 ! Derivative of the cumulative determinant with lam for the previous two + ! layers [various], but the units of detKm1/ddetKm1 are [T2 L-2 ~> s2 m-2] + real, parameter :: rescale = 1024.0**4 ! max value of determinant allowed before rescaling [nondim] + real :: I_rescale ! inverse of rescale [nondim] integer :: k ! row (layer interface) index I_rescale = 1.0 / rescale @@ -1175,7 +1208,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over !! which N2 is limited as monotonic for the purposes of - !! calculating the vertical modal structure. + !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the !! vertical modal structure [Z ~> m]. @@ -1221,7 +1254,7 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction of water column over !! which N2 is limited as monotonic for the purposes of - !! calculating the vertical modal structure. + !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the !! vertical modal structure [Z ~> m]. From b9daf2f201f60c9fc0d1da78df78591213f42d5a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 9 Jan 2023 07:12:05 -0500 Subject: [PATCH 163/629] +Add runtime parameter INTERNAL_WAVE_CG1_THRESH Made the CS argument mandatory for wave_speeds and added the new runtime parameter INTERNAL_WAVE_CG1_THRESH to specify the threshold first mode internal below which all higher mode speeds are reported as 0, replacing a previously hard-coded dimensional value. As a result of this change there is a new waves_CS element in diabatic_CS and a call to wave_speed_init from diabatic_driver_init. By default, all answers are bitwise identical, but there is a new entry in some MOM_parameter_doc files that have INTERNAL_TIDES=True. --- src/diagnostics/MOM_wave_speed.F90 | 49 ++++++++++++------- .../vertical/MOM_diabatic_driver.F90 | 13 ++++- 2 files changed, 42 insertions(+), 20 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 3dcad440ce..34669ae706 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -44,6 +44,11 @@ module MOM_wave_speed real :: min_speed2 = 0. !< The minimum mode 1 internal wave speed squared [L2 T-2 ~> m2 s-2] real :: wave_speed_tol = 0.001 !< The fractional tolerance with which to solve for the wave !! speeds [nondim] + real :: c1_thresh = -1.0 !< 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 [L T-1 ~> m s-1]. A non-negative + !! value must be specified via a call to wave_speed_init for + !! the subroutine wave_speeds to be used (but not wave_speed). type(remapping_CS) :: remapping_CS !< Used for vertical remapping when calculating equivalent barotropic !! mode structure. integer :: remap_answer_date = 99991231 !< The vintage of the order of arithmetic and expressions to use @@ -162,7 +167,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed: "// & + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speed: "// & "Module must be initialized before it is used.") if (present(full_halos)) then ; if (full_halos) then @@ -657,7 +662,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) 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), optional, intent(in) :: CS !< Wave speed control struct + 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. @@ -684,8 +689,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) 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 :: I_Htot ! The inverse of the total filtered thicknesses [Z ~> m] - real :: c1_thresh ! if c1 is below this value, don't bother calculating - ! cn values for higher modes [L T-1 ~> m s-1] real :: 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]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -752,10 +755,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - if (present(CS)) then - if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed: "// & - "Module must be initialized before it is used.") - endif + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speeds: "// & + "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 @@ -765,26 +766,28 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! Simplifying the following could change answers at roundoff. Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) - c1_thresh = 0.01*US%m_s_to_L_T + if (CS%c1_thresh < 0.0) & + call MOM_error(FATAL, "INTERNAL_WAVE_CG1_THRESH must be set to a non-negative "//& + "value via wave_speed_init for wave_speeds to be used.") c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. - better_est = .false. ; if (present(CS)) better_est = CS%better_cg1_est + better_est = CS%better_cg1_est if (better_est) then - tol_solve = 0.001 ; if (present(CS)) tol_solve = CS%wave_speed_tol + tol_solve = CS%wave_speed_tol tol_Hfrac = 0.1*tol_solve ; tol_merge = tol_solve / real(nz) else tol_solve = 0.001 ; tol_Hfrac = 0.0001 ; tol_merge = 0.001 endif - cg1_min2 = 0.0 ; if (present(CS)) cg1_min2 = CS%min_speed2 + cg1_min2 = CS%min_speed2 ! Zero out all wave speeds. Values over land or for columns that are too weakly stratified ! are not changed from this zero value. cn(:,:,:) = 0.0 min_h_frac = tol_Hfrac / real(nz) - !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS, & + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,min_h_frac,use_EOS, & !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & - !$OMP c1_thresh,tol_solve,tol_merge,c2_scale) + !$OMP tol_solve,tol_merge,c2_scale) 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 @@ -1046,7 +1049,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, full_halos) ! 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)>c1_thresh) then + if ((nmodes > 1) .and. (kc >= nmodes+1) .and. (cn(i,j,1) > CS%c1_thresh)) then ! Set the the range to look for the other desired eigen values ! set min value just greater than the 1st root (found above) lamMin = lam_1*(1.0 + tol_solve) @@ -1202,7 +1205,7 @@ end subroutine tridiag_det !> Initialize control structure for MOM_wave_speed subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & - remap_answer_date, better_speed_est, min_speed, wave_speed_tol) + remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Wave speed control struct logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. @@ -1225,6 +1228,10 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the !! wave speeds [nondim] + real, optional, intent(in) :: 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 [L T-1 ~> m s-1]. A non-negative value + !! must be specified for wave_speeds to be used (but not wave_speed). ! This include declares and sets the variable "version". # include "version_variable.h" @@ -1237,7 +1244,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol, & - remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date) + remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & + c1_thresh=c1_thresh) ! The remap_answers_2018 argument here is irrelevant, because remapping is hard-coded to use PLM. call initialize_remapping(CS%remapping_CS, 'PLM', boundary_extrapolation=.false., & @@ -1247,7 +1255,7 @@ end subroutine wave_speed_init !> Sets internal parameters for MOM_wave_speed subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_depth, remap_answers_2018, & - remap_answer_date, better_speed_est, min_speed, wave_speed_tol) + remap_answer_date, better_speed_est, min_speed, wave_speed_tol, c1_thresh) type(wave_speed_CS), intent(inout) :: CS !< Control structure for MOM_wave_speed logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent @@ -1271,6 +1279,10 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ !! below which 0 is returned [L T-1 ~> m s-1]. real, optional, intent(in) :: wave_speed_tol !< The fractional tolerance for finding the !! wave speeds [nondim] + real, optional, intent(in) :: 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 [L T-1 ~> m s-1]. A non-negative value + !! must be specified for wave_speeds to be used (but not wave_speed). if (present(use_ebt_mode)) CS%use_ebt_mode = use_ebt_mode if (present(mono_N2_column_fraction)) CS%mono_N2_column_fraction = mono_N2_column_fraction @@ -1286,6 +1298,7 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ if (present(better_speed_est)) CS%better_cg1_est = better_speed_est if (present(min_speed)) CS%min_speed2 = min_speed**2 if (present(wave_speed_tol)) CS%wave_speed_tol = wave_speed_tol + if (present(c1_thresh)) CS%c1_thresh = c1_thresh end subroutine wave_speed_set_param diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 7cfcbfab07..fa08a8c3af 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -67,7 +67,7 @@ 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 +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 @@ -239,6 +239,7 @@ 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 @@ -395,7 +396,7 @@ 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, full_halos=.true.) + call wave_speeds(h, tv, G, GV, US, CS%nMode, cn_IGW, CS%wave_speed, full_halos=.true.) endif call propagate_int_tide(h, tv, cn_IGW, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & @@ -2948,6 +2949,8 @@ 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 @@ -3045,6 +3048,11 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di 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) @@ -3466,6 +3474,7 @@ 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 c60aff159341a1e46cbcf11c00491e51a7ca9efd Mon Sep 17 00:00:00 2001 From: Nora Loose Date: Sun, 22 Jan 2023 12:31:12 -0700 Subject: [PATCH 164/629] Add KE_visc_gl90 diagnostic (#305) * Add KE_visc_gl90 diagnostic KE_visc_gl90 is an alternative to the diagnostic GLwork. Both diagnostics describe the energetics of the GL90 parameterization, as part of the kinetic energy budget. * KE_visc_gl90 is consistent with KE_visc, and the remaining KE diagnostics. In particular, it is true that KE_visc_gl90 is exactly contained in KE_visc, i.e., we have that KE_visc - KE_visc_gl90 represents exactly the energetics of all viscosity contributions except the GL90 viscosity. * GLwork is not directly compatible with KE_visc, but is guaranteed to be sign-definite if summed in the vertical. --- src/diagnostics/MOM_diagnostics.F90 | 31 +++++++++++++++++-- .../vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 30 insertions(+), 3 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ad51ecfe5e..11a37c8589 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -83,6 +83,7 @@ module MOM_diagnostics integer :: id_PE_to_KE = -1, id_KE_BT = -1 integer :: id_KE_Coradv = -1, id_KE_adv = -1 integer :: id_KE_visc = -1, id_KE_stress = -1 + integer :: id_KE_visc_gl90 = -1 integer :: id_KE_horvisc = -1, id_KE_dia = -1 integer :: id_uh_Rlay = -1, id_vh_Rlay = -1 integer :: id_uhGM_Rlay = -1, id_vhGM_Rlay = -1 @@ -1121,6 +1122,25 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call post_data(CS%id_KE_visc, KE_term, CS%diag) endif + if (CS%id_KE_visc_gl90 > 0) then + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. + do k=1,nz + do j=js,je ; do I=Isq,Ieq + KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + KE_v(i,J) = vh(i,J,k) * G%dyCv(i,J) * ADp%dv_dt_visc_gl90(i,J,k) + enddo ; enddo + if (.not.G%symmetric) & + call do_group_pass(CS%pass_KE_uv, G%domain) + do j=js,je ; do i=is,ie + 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))) + enddo ; enddo + enddo + call post_data(CS%id_KE_visc_gl90, KE_term, CS%diag) + endif + if (CS%id_KE_stress > 0) then ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3]. do k=1,nz @@ -1803,6 +1823,9 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag CS%id_KE_visc = register_diag_field('ocean_model', 'KE_visc', diag%axesTL, Time, & 'Kinetic Energy Source from Vertical Viscosity and Stresses', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) + CS%id_KE_visc_gl90 = register_diag_field('ocean_model', 'KE_visc_gl90', diag%axesTL, Time, & + 'Kinetic Energy Source from GL90 Vertical Viscosity', & + 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) CS%id_KE_stress = register_diag_field('ocean_model', 'KE_stress', diag%axesTL, Time, & 'Kinetic Energy Source from Surface Stresses or Body Wind Stress', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) @@ -2231,7 +2254,10 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) call safe_alloc_ptr(ADp%du_dt_visc,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) endif - + if (CS%id_KE_visc_gl90 > 0) then + call safe_alloc_ptr(ADp%du_dt_visc_gl90,IsdB,IedB,jsd,jed,nz) + call safe_alloc_ptr(ADp%dv_dt_visc_gl90,isd,ied,JsdB,JedB,nz) + endif if (CS%id_KE_stress > 0) then call safe_alloc_ptr(ADp%du_dt_str,IsdB,IedB,jsd,jed,nz) call safe_alloc_ptr(ADp%dv_dt_str,isd,ied,JsdB,JedB,nz) @@ -2245,7 +2271,8 @@ subroutine set_dependent_diagnostics(MIS, ADp, CDp, G, GV, CS) CS%KE_term_on = ((CS%id_dKEdt > 0) .or. (CS%id_PE_to_KE > 0) .or. (CS%id_KE_BT > 0) .or. & (CS%id_KE_Coradv > 0) .or. (CS%id_KE_adv > 0) .or. (CS%id_KE_visc > 0) .or. & - (CS%id_KE_stress > 0) .or. (CS%id_KE_horvisc > 0) .or. (CS%id_KE_dia > 0)) + (CS%id_KE_visc_gl90 > 0) .or. (CS%id_KE_stress > 0) .or. (CS%id_KE_horvisc > 0) .or. & + (CS%id_KE_dia > 0)) if (CS%id_h_du_dt > 0) call safe_alloc_ptr(ADp%diag_hu,IsdB,IedB,jsd,jed,nz) if (CS%id_h_dv_dt > 0) call safe_alloc_ptr(ADp%diag_hv,isd,ied,JsdB,JedB,nz) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 88be824885..6488ba5b1b 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2481,7 +2481,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Meridional Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) if (CS%id_dv_dt_visc > 0) call safe_alloc_ptr(ADp%dv_dt_visc,isd,ied,JsdB,JedB,nz) CS%id_GLwork = register_diag_field('ocean_model', 'GLwork', diag%axesTL, Time, & - 'Kinetic Energy Source from GL90 Vertical Viscosity', & + 'Sign-definite Kinetic Energy Source from GL90 Vertical Viscosity', & 'm3 s-3', conversion=GV%H_to_m*(US%L_T_to_m_s**2)*US%s_to_T) CS%id_du_dt_visc_gl90 = register_diag_field('ocean_model', 'du_dt_visc_gl90', diag%axesCuL, Time, & 'Zonal Acceleration from GL90 Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) From 321ee0b1bc863730f2c52e281654a0b73eecfc01 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 25 Oct 2022 13:49:13 -0400 Subject: [PATCH 165/629] Generic I/O layer for infra and netCDF This patch introduces a generalized I/O interface, through a new class, `MOM_file`, for reading and writing of axis-based model fields. A common API for interacting with files is defined in the `MOM_file` class, and two implementations are provided: * `MOM_infra_file`, using the "infra" framework (i.e. FMS) * `MOM_netcdf_file`, using native netCDF framework This separation allows us to define certain generic functions by class, and platform-specific functions by type. It will also allow for removal of legacy FMS1 operations which are no longer used for the majority of I/O but are still required for isolated MOM files. This change will allow us to move incompatible files from the FMS to the netCDF implementation, while still preserving a common structure for both files. The majority of the details of `MOM_file` and its subclasses are defined in `MOM_io_file.F90`, which is exclusively accessed through `MOM_io.F90`. The netCDF implementation, designed to be used by `MOM_netcdf_file` but is designed as a standalone system, is defined in `MOM_netcdf.F90`. *Interface* `MOM_file` includes the following functions: * `open` * `close` * `flush` * `register_axis` * `register_field` * `write_attribute` * `write_field` * `file_is_open` * `get_file_info` * `get_file_fields` * `get_field_atts` * `read_field_chksum` Most are designed to resemble the existing MOM I/O operations. Note that some of these have not yet been implemented for `MOM_netcdf_file`, since they are never used in the model. `MOM_file_infra` includes the following additional operations: * `get_file_times` * `get_file_fieldtypes` See documentation for usage of these functions. The "axis"/"field" model from FMS1 has been preserved, where axes are associated with variables which contain the grid point, and fields are defined with respect to the file's axes. Operations such as field counters will exclude any variables associated with the axes. The `axistype` and `fieldtype` from FMS have been replaced with new abstractions (`MOM_axis` and `MOM_field`). Internally, these point to either the FMS types or equivalent netCDF types. *Implementation* Each file type contains an instance of its native type, as well as lists of associated axes and fields. List are implemented as linked lists of names (stored as `label`) which are used to identify and extract or write the axis/field to the internal type. The mechanics of this are largely hidden from the user and can be changed in the future, if needed, without disruption to the rest of the codebase. The current netCDF implementation very closely mirrors the FMS infra behavior, but this can be relaxed or modified as needed. netCDF I/O is currently only designed for serial I/O, with all of the data on the root PE. Further development would be needed to support any kind of parallel I/O. *Current Usage* Two functions have been transferred from infra to the netCDF I/O: * `Depth_list.nc` * `ocean.stats.nc` The following legacy functions and types from FMS have been preserved: * `create_file` * `reopen_file` * `file_type` * `open_file` * `get_file_info` * `get_file_fields` * `get_file_times` This is primarily to preserve compatibility with SIS2, but may also be useful for other code, such as model drivers. These may be phased out in the future, however. --- config_src/infra/FMS2/MOM_io_infra.F90 | 4 +- src/ALE/MOM_hybgen_regrid.F90 | 13 +- src/ALE/MOM_regridding.F90 | 14 +- src/diagnostics/MOM_sum_output.F90 | 72 +- src/framework/MOM_io.F90 | 442 ++++- src/framework/MOM_io_file.F90 | 1654 +++++++++++++++++ src/framework/MOM_netcdf.F90 | 755 ++++++++ src/framework/MOM_restart.F90 | 48 +- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- .../MOM_coord_initialization.F90 | 12 +- .../MOM_shared_initialization.F90 | 12 +- 11 files changed, 2854 insertions(+), 174 deletions(-) create mode 100644 src/framework/MOM_io_file.F90 create mode 100644 src/framework/MOM_netcdf.F90 diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index c49c124ae0..54b9dfb78b 100644 --- a/config_src/infra/FMS2/MOM_io_infra.F90 +++ b/config_src/infra/FMS2/MOM_io_infra.F90 @@ -509,8 +509,8 @@ subroutine open_ASCII_file(unit, file, action, threading, fileset) ! This checks if open() failed but did not raise a runtime error. inquire(unit, opened=is_open) if (.not. is_open) & - call MOM_error(FATAL, 'open_ASCII_file: File ' // trim(filename) // & - ' failed to open.') + call MOM_error(FATAL, & + 'open_ASCII_file: File "' // trim(filename) // '" failed to open.') ! NOTE: There are two possible mpp_write_meta functions in FMS1: ! - call mpp_write_meta( unit, 'filename', cval=mpp_file(unit)%name) diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index 271caa7ad6..f89e15d930 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -7,7 +7,8 @@ module MOM_hybgen_regrid use MOM_EOS, only : EOS_type, calculate_density use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, assert use MOM_file_parser, only : get_param, param_file_type, log_param -use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_file, MOM_field use MOM_io, only : MOM_read_data, MOM_write_field, vardesc, var_desc, SINGLE_FILE use MOM_string_functions, only : slasher use MOM_unit_scaling, only : unit_scale_type @@ -210,20 +211,20 @@ subroutine write_Hybgen_coord_file(GV, CS, filepath) character(len=*), intent(in) :: filepath !< The full path to the file to write ! Local variables type(vardesc) :: vars(3) - type(fieldtype) :: fields(3) - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_field) :: fields(3) + type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset vars(1) = var_desc("dp0", "meter", "Deep z-level minimum thicknesses for Hybgen", '1', 'L', '1') vars(2) = var_desc("ds0", "meter", "Shallow z-level minimum thicknesses for Hybgen", '1', 'L', '1') vars(3) = var_desc("Rho_tgt", "kg m-3", "Target coordinate potential densities for Hybgen", '1', 'L', '1') - call create_file(IO_handle, trim(filepath), vars, 3, fields, SINGLE_FILE, GV=GV) + call create_MOM_file(IO_handle, trim(filepath), vars, 3, fields, & + SINGLE_FILE, GV=GV) call MOM_write_field(IO_handle, fields(1), CS%dp0k, scale=CS%coord_scale) call MOM_write_field(IO_handle, fields(2), CS%ds0k, scale=CS%coord_scale) call MOM_write_field(IO_handle, fields(3), CS%target_density, scale=CS%Rho_coord_scale) - call close_file(IO_handle) - + call IO_handle%close() end subroutine write_Hybgen_coord_file !> This subroutine deallocates memory in the control structure for the hybgen module diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index e28f2c5e82..53072909a5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -6,8 +6,9 @@ module MOM_regridding use MOM_error_handler, only : MOM_error, FATAL, WARNING, assert 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, fieldtype, SINGLE_FILE -use MOM_io, only : create_file, MOM_write_field, close_file, file_type +use MOM_io, only : vardesc, var_desc, SINGLE_FILE +use MOM_io, only : MOM_infra_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 use MOM_variables, only : ocean_grid_type, thermo_var_ptrs @@ -2212,8 +2213,8 @@ subroutine write_regrid_file( CS, GV, filepath ) character(len=*), intent(in) :: filepath !< The full path to the file to write type(vardesc) :: vars(2) - type(fieldtype) :: fields(2) - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_field) :: fields(2) + type(MOM_infra_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 @@ -2231,10 +2232,11 @@ subroutine write_regrid_file( CS, GV, filepath ) vars(2) = var_desc('ds_interface', getCoordinateUnits( CS ), & 'Layer Center Coordinate Separation', '1', 'i', '1') - call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & + SINGLE_FILE, GV=GV) call MOM_write_field(IO_handle, fields(1), ds) call MOM_write_field(IO_handle, fields(2), dsi) - call close_file(IO_handle) + call IO_handle%close() end subroutine write_regrid_file diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 7797a266dd..6dbe4997d6 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -13,8 +13,9 @@ module MOM_sum_output use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : find_eta -use MOM_io, only : create_file, file_type, fieldtype, flush_file, reopen_file, close_file -use MOM_io, only : file_exists, slasher, vardesc, var_desc, write_field, MOM_write_field +use MOM_io, only : create_MOM_file, reopen_MOM_file +use MOM_io, only : MOM_infra_file, MOM_netcdf_file, MOM_field +use MOM_io, only : file_exists, slasher, vardesc, var_desc, MOM_write_field use MOM_io, only : field_size, read_variable, read_attribute, open_ASCII_file, stdout use MOM_io, only : axis_info, set_axis_info, delete_axis_info, get_filename_appendix use MOM_io, only : attribute_info, set_attribute_info, delete_attribute_info @@ -125,9 +126,9 @@ module MOM_sum_output !! to stdout when the energy files are written. integer :: previous_calls = 0 !< The number of times write_energy has been called. integer :: prev_n = 0 !< The value of n from the last call. - type(file_type) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. + type(MOM_netcdf_file) :: fileenergy_nc !< The file handle for the netCDF version of the energy file. integer :: fileenergy_ascii !< The unit number of the ascii version of the energy file. - type(fieldtype), dimension(NUM_FIELDS+MAX_FIELDS_) :: & + type(MOM_field), dimension(NUM_FIELDS+MAX_FIELDS_) :: & fields !< fieldtype variables for the output fields. character(len=200) :: energyfile !< The name of the energy file with path. end type sum_output_CS @@ -603,13 +604,11 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci energypath_nc = trim(CS%energyfile) // ".nc" if (day > CS%Start_time) then - call reopen_file(CS%fileenergy_nc, trim(energypath_nc), vars, & - num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, & - G=G, GV=GV) + call reopen_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) else - call create_file(CS%fileenergy_nc, trim(energypath_nc), vars, & - num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, & - G=G, GV=GV) + call create_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) endif endif @@ -863,35 +862,35 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif endif - call write_field(CS%fileenergy_nc, CS%fields(1), real(CS%ntrunc), reday) - call write_field(CS%fileenergy_nc, CS%fields(2), toten, reday) - call write_field(CS%fileenergy_nc, CS%fields(3), PE, reday) - call write_field(CS%fileenergy_nc, CS%fields(4), KE, reday) - call write_field(CS%fileenergy_nc, CS%fields(5), H_0APE, reday) - call write_field(CS%fileenergy_nc, CS%fields(6), mass_lay, reday) - - call write_field(CS%fileenergy_nc, CS%fields(7), mass_tot, reday) - call write_field(CS%fileenergy_nc, CS%fields(8), mass_chg, reday) - call write_field(CS%fileenergy_nc, CS%fields(9), mass_anom, reday) - call write_field(CS%fileenergy_nc, CS%fields(10), max_CFL(1), reday) - call write_field(CS%fileenergy_nc, CS%fields(11), max_CFL(2), reday) + call CS%fileenergy_nc%write_field(CS%fields(1), real(CS%ntrunc), reday) + call CS%fileenergy_nc%write_field(CS%fields(2), toten, reday) + call CS%fileenergy_nc%write_field(CS%fields(3), PE, reday) + call CS%fileenergy_nc%write_field(CS%fields(4), KE, reday) + call CS%fileenergy_nc%write_field(CS%fields(5), H_0APE, reday) + call CS%fileenergy_nc%write_field(CS%fields(6), mass_lay, reday) + + call CS%fileenergy_nc%write_field(CS%fields(7), mass_tot, reday) + call CS%fileenergy_nc%write_field(CS%fields(8), mass_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(9), mass_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(10), max_CFL(1), reday) + call CS%fileenergy_nc%write_field(CS%fields(11), max_CFL(2), reday) if (CS%use_temperature) then - call write_field(CS%fileenergy_nc, CS%fields(12), 0.001*Salt, reday) - call write_field(CS%fileenergy_nc, CS%fields(13), 0.001*salt_chg, reday) - call write_field(CS%fileenergy_nc, CS%fields(14), 0.001*salt_anom, reday) - call write_field(CS%fileenergy_nc, CS%fields(15), Heat, reday) - call write_field(CS%fileenergy_nc, CS%fields(16), heat_chg, reday) - call write_field(CS%fileenergy_nc, CS%fields(17), heat_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(12), 0.001*Salt, reday) + call CS%fileenergy_nc%write_field(CS%fields(13), 0.001*salt_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(14), 0.001*salt_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(15), Heat, reday) + call CS%fileenergy_nc%write_field(CS%fields(16), heat_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(17), heat_anom, reday) do m=1,nTr_stocks - call write_field(CS%fileenergy_nc, CS%fields(17+m), Tr_stocks(m), reday) + call CS%fileenergy_nc%write_field(CS%fields(17+m), Tr_stocks(m), reday) enddo else do m=1,nTr_stocks - call write_field(CS%fileenergy_nc, CS%fields(11+m), Tr_stocks(m), reday) + call CS%fileenergy_nc%write_field(CS%fields(11+m), Tr_stocks(m), reday) enddo endif - call flush_file(CS%fileenergy_nc) + call CS%fileenergy_nc%flush() if (is_NaN(En_mass)) then call MOM_error(FATAL, "write_energy : NaNs in total model energy forced model termination.") @@ -1233,13 +1232,13 @@ subroutine write_depth_list(G, US, DL, filename) ! Local variables type(vardesc), dimension(:), allocatable :: & vars ! Types that described the staggering and metadata for the fields - type(fieldtype), dimension(:), allocatable :: & + type(MOM_field), dimension(:), allocatable :: & fields ! Types with metadata about the variables that will be written type(axis_info), dimension(:), allocatable :: & extra_axes ! Descriptors for extra axes that might be used type(attribute_info), dimension(:), allocatable :: & global_atts ! Global attributes and their values - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_netcdf_file) :: IO_handle ! The I/O handle of the fileset character(len=16) :: depth_chksum, area_chksum ! All ranks are required to compute the global checksum @@ -1259,8 +1258,8 @@ subroutine write_depth_list(G, US, DL, filename) call set_attribute_info(global_atts(1), depth_chksum_attr, depth_chksum) call set_attribute_info(global_atts(2), area_chksum_attr, area_chksum) - call create_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, extra_axes=extra_axes, & - global_atts=global_atts) + call create_MOM_file(IO_handle, filename, vars, 3, fields, SINGLE_FILE, & + extra_axes=extra_axes, global_atts=global_atts) call MOM_write_field(IO_handle, fields(1), DL%depth, scale=US%Z_to_m) call MOM_write_field(IO_handle, fields(2), DL%area, scale=US%L_to_m**2) call MOM_write_field(IO_handle, fields(3), DL%vol_below, scale=US%Z_to_m*US%L_to_m**2) @@ -1268,8 +1267,7 @@ subroutine write_depth_list(G, US, DL, filename) call delete_axis_info(extra_axes) call delete_attribute_info(global_atts) deallocate(vars, extra_axes, fields, global_atts) - call close_file(IO_handle) - + call IO_handle%close() end subroutine write_depth_list !> This subroutine reads in the depth list from the specified file diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index e8df89b268..6c2dc9df34 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -15,15 +15,17 @@ module MOM_io use MOM_io_infra, only : read_field, read_vector use MOM_io_infra, only : read_data => read_field ! Deprecated use MOM_io_infra, only : read_field_chksum -use MOM_io_infra, only : file_type, file_exists, get_file_info, get_file_fields -use MOM_io_infra, only : open_file, open_ASCII_file, close_file, flush_file, file_is_open -use MOM_io_infra, only : get_field_size, fieldtype, field_exists, get_field_atts -use MOM_io_infra, only : get_file_times, axistype, get_axis_data, get_filename_suffix -use MOM_io_infra, only : write_field, write_metadata, write_version +use MOM_io_infra, only : file_exists +use MOM_io_infra, only : open_ASCII_file, close_file, file_is_open +use MOM_io_infra, only : get_field_size, field_exists, get_field_atts +use MOM_io_infra, only : get_axis_data, get_filename_suffix +use MOM_io_infra, only : write_version use MOM_io_infra, only : MOM_namelist_file, check_namelist_error, io_infra_init, io_infra_end use MOM_io_infra, only : APPEND_FILE, ASCII_FILE, MULTIPLE, NETCDF_FILE, OVERWRITE_FILE use MOM_io_infra, only : READONLY_FILE, SINGLE_FILE, WRITEONLY_FILE use MOM_io_infra, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io_file, only : MOM_file, MOM_infra_file, MOM_netcdf_file +use MOM_io_file, only : MOM_axis, MOM_field use MOM_string_functions, only : lowercase, slasher use MOM_verticalGrid, only : verticalGrid_type @@ -33,21 +35,33 @@ module MOM_io use netcdf, only : NF90_strerror, NF90_inquire_dimension use netcdf, only : NF90_NOWRITE, NF90_NOERR, NF90_GLOBAL, NF90_ENOTATT, NF90_CHAR +! The following are not used in MOM6, but may be used by externals (e.g. SIS2). +use MOM_io_infra, only : axistype ! still used but soon to be nuked +use MOM_io_infra, only : fieldtype +use MOM_io_infra, only : file_type +use MOM_io_infra, only : get_file_info +use MOM_io_infra, only : get_file_fields +use MOM_io_infra, only : get_file_times +use MOM_io_infra, only : open_file +use MOM_io_infra, only : write_field + implicit none ; private ! These interfaces are actually implemented in this file. -public :: create_file, reopen_file, cmor_long_std, ensembler, MOM_io_init +public :: create_MOM_file, reopen_MOM_file, cmor_long_std, ensembler, MOM_io_init +public :: MOM_field public :: MOM_write_field, var_desc, modify_vardesc, query_vardesc, position_from_horgrid public :: open_namelist_file, check_namelist_error, check_nml_error public :: get_var_sizes, verify_variable_units, num_timelevels, read_variable, read_attribute public :: open_file_to_read, close_file_to_read ! The following are simple pass throughs of routines from MOM_io_infra or other modules. -public :: file_exists, open_file, open_ASCII_file, close_file, flush_file, file_type -public :: get_file_info, field_exists, get_file_fields, get_file_times, get_filename_appendix +public :: file_exists, open_ASCII_file, close_file +public :: MOM_file, MOM_infra_file, MOM_netcdf_file +public :: field_exists, get_filename_appendix public :: fieldtype, field_size, get_field_atts public :: axistype, get_axis_data public :: MOM_read_data, MOM_read_vector, read_field_chksum -public :: slasher, write_field, write_version_number +public :: slasher, write_version_number public :: io_infra_init, io_infra_end public :: stdout_if_root public :: get_var_axes_info @@ -67,6 +81,15 @@ module MOM_io !> These encoding constants are used to indicate the discretization position of a variable public :: CENTER, CORNER, NORTH_FACE, EAST_FACE +! The following are not used in MOM6, but may be used by externals (e.g. SIS2). +public :: create_file +public :: reopen_file +public :: file_type +public :: open_file +public :: get_file_info +public :: get_file_fields +public :: get_file_times + !> Read a field from file using the infrastructure I/O. interface MOM_read_data module procedure MOM_read_data_0d @@ -87,6 +110,11 @@ module MOM_io !> Write a registered field to an output file, potentially with rotation interface MOM_write_field + module procedure MOM_write_field_legacy_4d + module procedure MOM_write_field_legacy_3d + module procedure MOM_write_field_legacy_2d + module procedure MOM_write_field_legacy_1d + module procedure MOM_write_field_legacy_0d module procedure MOM_write_field_4d module procedure MOM_write_field_3d module procedure MOM_write_field_2d @@ -147,23 +175,70 @@ module MOM_io character(len=:), allocatable :: att_val !< The values of this attribute end type attribute_info - integer, public :: stdout = stdout_iso !< standard output unit integer, public :: stderr = stderr_iso !< standard output unit contains -!> Routine creates a new NetCDF file. It also sets up fieldtype -!! structures that describe this file and variables that will -!! later be written to this file. -subroutine create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G, dG, GV, checksums, extra_axes, global_atts) - type(file_type), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be +!> `create_MOM_file` wrapper for the legacy file handle, `file_type`. +!! NOTE: This function may be removed in a future release. +subroutine create_file(IO_handle, filename, vars, novars, fields, threading, & + timeunit, G, dG, GV, checksums, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle + !< Handle for a files or fileset that is to be opened or reopened for + !! writing + character(len=*), intent(in) :: filename + !< full path to the file to create + type(vardesc), intent(in) :: vars(:) + !< structures describing fields written to filename + integer, intent(in) :: novars + !< number of fields written to filename + type(fieldtype), intent(inout) :: fields(:) + !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading + !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit + !< length of the units for time [s]. The default value is 86400.0, for 1 + !! day. + type(ocean_grid_type), optional, intent(in) :: G + !< ocean horizontal grid structure; G or dG is required if the new file + !! uses any horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG + !< dynamic horizontal grid structure; G or dG is required if the new file + !! uses any horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV + !< ocean vertical grid structure, which is ! required if the new file uses + !! any vertical grid axes. + integer(kind=int64), optional, intent(in) :: checksums(:,:) + !< checksums of vars + type(axis_info), optional, intent(in) :: extra_axes(:) + !< Types with information about some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) + !< Global attributes to write to this file + + type(MOM_infra_file) :: new_file + type(MOM_field) :: new_fields(novars) + + new_file%handle_infra = IO_handle + + call create_MOM_file(new_file, filename, vars, novars, new_fields, & + threading=threading, timeunit=timeunit, G=G, dG=dG, GV=GV, & + checksums=checksums, extra_axes=extra_axes, global_atts=global_atts) + + IO_handle = new_file%handle_infra + call new_file%get_file_fieldtypes(fields(:novars)) +end subroutine create_file + + +!! Create a new netCDF file and register the MOM_fields to be written. +subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G, dG, GV, checksums, extra_axes, global_atts) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a files or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename integer, intent(in) :: novars !< number of fields written to filename - type(fieldtype), intent(inout) :: fields(:) !< array of fieldtypes for each variable + type(MOM_field), intent(inout) :: fields(:) !< array of fieldtypes for each variable integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE real, optional, intent(in) :: timeunit !< length of the units for time [s]. The !! default value is 86400.0, for 1 day. @@ -186,10 +261,10 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim logical :: use_layer, use_int, use_periodic logical :: one_file, domain_set, dim_found logical, dimension(:), allocatable :: use_extra_axis - type(axistype) :: axis_lath, axis_latq, axis_lonh, axis_lonq - type(axistype) :: axis_layer, axis_int, axis_time, axis_periodic - type(axistype), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes - type(axistype) :: axes(5) ! The axes of a variable + type(MOM_axis) :: axis_lath, axis_latq, axis_lonh, axis_lonq + type(MOM_axis) :: axis_layer, axis_int, axis_time, axis_periodic + type(MOM_axis), dimension(:), allocatable :: more_axes ! Axes generated from extra_axes + type(MOM_axis) :: axes(5) ! The axes of a variable type(MOM_domain_type), pointer :: Domain => NULL() type(domain1d) :: x_domain, y_domain integer :: position, numaxes, pack, thread, k, n, m @@ -244,9 +319,9 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(IO_handle, filename, OVERWRITE_FILE, threading=thread) + call IO_handle%open(filename, action=OVERWRITE_FILE, threading=thread) else - call open_file(IO_handle, filename, OVERWRITE_FILE, MOM_domain=Domain) + call IO_handle%open(filename, action=OVERWRITE_FILE, MOM_domain=Domain) endif ! Define the coordinates. @@ -326,28 +401,23 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim "create_file: A vertical grid type is required to create a file with a vertical coordinate.") if (use_lath) & - call write_metadata(IO_handle, axis_lath, name="lath", units=y_axis_units, longname="Latitude", & + axis_lath = IO_handle%register_axis("lath", units=y_axis_units, longname="Latitude", & cartesian='Y', domain=y_domain, data=gridLatT(jsg:jeg)) - if (use_lonh) & - call write_metadata(IO_handle, axis_lonh, name="lonh", units=x_axis_units, longname="Longitude", & + axis_lonh = IO_handle%register_axis("lonh", units=x_axis_units, longname="Longitude", & cartesian='X', domain=x_domain, data=gridLonT(isg:ieg)) - if (use_latq) & - call write_metadata(IO_handle, axis_latq, name="latq", units=y_axis_units, longname="Latitude", & + axis_latq = IO_handle%register_axis("latq", units=y_axis_units, longname="Latitude", & cartesian='Y', domain=y_domain, data=gridLatB(JsgB:JegB), edge_axis=.true.) - if (use_lonq) & - call write_metadata(IO_handle, axis_lonq, name="lonq", units=x_axis_units, longname="Longitude", & + axis_lonq = IO_handle%register_axis("lonq", units=x_axis_units, longname="Longitude", & cartesian='X', domain=x_domain, data=gridLonB(IsgB:IegB), edge_axis=.true.) - if (use_layer) & - call write_metadata(IO_handle, axis_layer, name="Layer", units=trim(GV%zAxisUnits), & + axis_layer = IO_handle%register_axis("Layer", units=trim(GV%zAxisUnits), & longname="Layer "//trim(GV%zAxisLongName), cartesian='Z', & sense=1, data=GV%sLayer(1:GV%ke)) - if (use_int) & - call write_metadata(IO_handle, axis_int, name="Interface", units=trim(GV%zAxisUnits), & + axis_int = IO_handle%register_axis("Interface", units=trim(GV%zAxisUnits), & longname="Interface "//trim(GV%zAxisLongName), cartesian='Z', & sense=1, data=GV%sInterface(1:GV%ke+1)) @@ -367,9 +437,9 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim write(time_units,'(es8.2," s")') timeunit endif - call write_metadata(IO_handle, axis_time, name="Time", units=time_units, longname="Time", cartesian='T') + axis_time = IO_handle%register_axis("Time", units=time_units, longname="Time", cartesian='T') else - call write_metadata(IO_handle, axis_time, name="Time", units="days", longname="Time", cartesian='T') + axis_time = IO_handle%register_axis("Time", units="days", longname="Time", cartesian='T') endif ; endif if (use_periodic) then @@ -378,24 +448,24 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim ! Define a periodic axis with unit labels. allocate(axis_val(num_periods)) do k=1,num_periods ; axis_val(k) = real(k) ; enddo - call write_metadata(IO_handle, axis_periodic, name="Period", units="nondimensional", & - longname="Periods for cyclical variables", cartesian='T', data=axis_val) + axis_periodic = IO_handle%register_axis("Period", units="nondimensional", & + longname="Periods for cyclical variables", cartesian='T', data=axis_val) deallocate(axis_val) endif do m=1,num_extra_dims ; if (use_extra_axis(m)) then if (allocated(extra_axes(m)%ax_data)) then - call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & sense=extra_axes(m)%sense, data=extra_axes(m)%ax_data) elseif (trim(extra_axes(m)%cartesian) == "T") then - call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian) else ! FMS requires that non-time axes have variables that label their values, even if they are trivial. allocate (axis_val(extra_axes(m)%ax_size)) do k=1,extra_axes(m)%ax_size ; axis_val(k) = real(k) ; enddo - call write_metadata(IO_handle, more_axes(m), name=extra_axes(m)%name, units=extra_axes(m)%units, & + more_axes(m) = IO_handle%register_axis(extra_axes(m)%name, units=extra_axes(m)%units, & longname=extra_axes(m)%longname, cartesian=extra_axes(m)%cartesian, & sense=extra_axes(m)%sense, data=axis_val) deallocate(axis_val) @@ -457,10 +527,10 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim pack = 1 if (present(checksums)) then - call write_metadata(IO_handle, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack=pack, checksum=checksums(k,:)) else - call write_metadata(IO_handle, fields(k), axes(1:numaxes), vars(k)%name, vars(k)%units, & + fields(k) = IO_handle%register_field(axes(1:numaxes), vars(k)%name, vars(k)%units, & vars(k)%longname, pack=pack) endif enddo @@ -468,41 +538,92 @@ subroutine create_file(IO_handle, filename, vars, novars, fields, threading, tim if (present(global_atts)) then do n=1,size(global_atts) if (allocated(global_atts(n)%name) .and. allocated(global_atts(n)%att_val)) & - call write_metadata(IO_handle, global_atts(n)%name, global_atts(n)%att_val) + call IO_handle%write_attribute(global_atts(n)%name, global_atts(n)%att_val) enddo endif - ! Now actualy write the variables with the axis label values - if (use_lath) call write_field(IO_handle, axis_lath) - if (use_latq) call write_field(IO_handle, axis_latq) - if (use_lonh) call write_field(IO_handle, axis_lonh) - if (use_lonq) call write_field(IO_handle, axis_lonq) - if (use_layer) call write_field(IO_handle, axis_layer) - if (use_int) call write_field(IO_handle, axis_int) - if (use_periodic) call write_field(IO_handle, axis_periodic) + ! Now write the variables with the axis label values + if (use_lath) call IO_handle%write_field(axis_lath) + if (use_latq) call IO_handle%write_field(axis_latq) + if (use_lonh) call IO_handle%write_field(axis_lonh) + if (use_lonq) call IO_handle%write_field(axis_lonq) + if (use_layer) call IO_handle%write_field(axis_layer) + if (use_int) call IO_handle%write_field(axis_int) + if (use_periodic) call IO_handle%write_field(axis_periodic) do m=1,num_extra_dims ; if (use_extra_axis(m)) then - call write_field(IO_handle, more_axes(m)) + call IO_handle%write_field(more_axes(m)) endif ; enddo if (num_extra_dims > 0) then deallocate(use_extra_axis, more_axes) endif +end subroutine create_MOM_file + + +!> `reopen_MOM_file` wrapper for the legacy file handle, `file_type`. +!! NOTE: This function may be removed in a future release. +subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, & + timeunit, G, dG, GV, extra_axes, global_atts) + type(file_type), intent(inout) :: IO_handle + !< Handle for a file or fileset that is to be opened or reopened for + !! writing + character(len=*), intent(in) :: filename + !< full path to the file to create + type(vardesc), intent(in) :: vars(:) + !< structures describing fields written to filename + integer, intent(in) :: novars + !< number of fields written to filename + type(fieldtype), intent(inout) :: fields(:) + !< array of fieldtypes for each variable + integer, optional, intent(in) :: threading + !< SINGLE_FILE or MULTIPLE + real, optional, intent(in) :: timeunit + !< length of the units for time [s]. The default value is 86400.0, for 1 + !! day. + type(ocean_grid_type), optional, intent(in) :: G + !< ocean horizontal grid structure; G or dG is required if a new file uses + !! any horizontal grid axes. + type(dyn_horgrid_type), optional, intent(in) :: dG + !< dynamic horizontal grid structure; G or dG is required if a new file + !! uses any horizontal grid axes. + type(verticalGrid_type), optional, intent(in) :: GV + !< ocean vertical grid structure, which is required if a new file uses any + !! vertical grid axes. + type(axis_info), optional, intent(in) :: extra_axes(:) + !< Types with information about some axes that might be used in this file + type(attribute_info), optional, intent(in) :: global_atts(:) + !< Global attributes to write to this file + + type(MOM_infra_file) :: mfile + !< Wrapper to MOM file + type(MOM_field), allocatable :: mfields(:) + !< Wrapper to MOM fields + integer :: i -end subroutine create_file + mfile%handle_infra = IO_handle + allocate(mfields(size(fields))) + + call reopen_MOM_file(mfile, filename, vars, novars, mfields, & + threading=threading, timeunit=timeunit, G=G, dG=dG, GV=GV, & + extra_axes=extra_axes, global_atts=global_atts) + + IO_handle = mfile%handle_infra + call get_file_fields(IO_handle, fields) +end subroutine reopen_file !> This routine opens an existing NetCDF file for output. If it !! does not find the file, a new file is created. It also sets up !! structures that describe this file and the variables that will !! later be written to this file. -subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G, dG, GV, extra_axes, global_atts) - type(file_type), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be +subroutine reopen_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G, dG, GV, extra_axes, global_atts) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file or fileset that is to be !! opened or reopened for writing character(len=*), intent(in) :: filename !< full path to the file to create type(vardesc), intent(in) :: vars(:) !< structures describing fields written to filename integer, intent(in) :: novars !< number of fields written to filename - type(fieldtype), intent(inout) :: fields(:) !< array of fieldtypes for each variable + type(MOM_field), intent(inout) :: fields(:) !< array of fieldtypes for each variable integer, optional, intent(in) :: threading !< SINGLE_FILE or MULTIPLE real, optional, intent(in) :: timeunit !< length of the units for time [s]. The !! default value is 86400.0, for 1 day. @@ -536,8 +657,9 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim inquire(file=check_name,EXIST=exists) if (.not.exists) then - call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) + call create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G=G, dG=dG, GV=GV, extra_axes=extra_axes, & + global_atts=global_atts) else domain_set = .false. @@ -551,40 +673,31 @@ subroutine reopen_file(IO_handle, filename, vars, novars, fields, threading, tim if (domain_set) one_file = (thread == SINGLE_FILE) if (one_file) then - call open_file(IO_handle, filename, APPEND_FILE, threading=thread) + call IO_handle%open(filename, APPEND_FILE, threading=thread) else - call open_file(IO_handle, filename, APPEND_FILE, MOM_domain=Domain) + call IO_handle%open(filename, APPEND_FILE, MOM_domain=Domain) endif - if (.not.file_is_open(IO_handle)) return + if (.not. IO_handle%file_is_open()) return - call get_file_info(IO_handle, nvar=nvar) + call IO_handle%get_file_info(nvar=nvar) if (nvar == -1) then write (mesg,*) "Reopening file ",trim(filename)," apparently had ",nvar,& " variables. Clobbering and creating file with ",novars," instead." call MOM_error(WARNING,"MOM_io: "//mesg) - call create_file(IO_handle, filename, vars, novars, fields, threading, timeunit, & - G=G, dG=dG, GV=GV, extra_axes=extra_axes, global_atts=global_atts) + call create_MOM_file(IO_handle, filename, vars, novars, fields, & + threading, timeunit, G=G, dG=dG, GV=GV, extra_axes=extra_axes, & + global_atts=global_atts) elseif (nvar /= novars) then write (mesg,*) "Reopening file ",trim(filename)," with ",novars,& " variables instead of ",nvar,"." call MOM_error(FATAL,"MOM_io: "//mesg) endif - if (nvar > 0) call get_file_fields(IO_handle, fields(1:nvar)) - - ! Check for inconsistent field names... -! do i=1,nvar -! call get_field_atts(fields(i), name) -! !if (trim(name) /= trim(vars%name)) then -! ! write (mesg, '("Reopening file ",a," variable ",a," is called ",a,".")',& -! ! trim(filename), trim(vars%name), trim(name)) -! ! call MOM_error(NOTE, "MOM_io: "//trim(mesg)) -! !endif -! enddo + if (nvar > 0) call IO_handle%get_file_fields(fields(1:nvar)) endif +end subroutine reopen_MOM_file -end subroutine reopen_file !> Return the index of sdtout if called from the root PE, or 0 for other PEs. integer function stdout_if_root() @@ -2089,9 +2202,8 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data endif end subroutine MOM_read_vector_3d - !> Write a 4d field to an output file, potentially with rotation -subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & +subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata @@ -2122,10 +2234,11 @@ subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, ti tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) endif -end subroutine MOM_write_field_4d +end subroutine MOM_write_field_legacy_4d + !> Write a 3d field to an output file, potentially with rotation -subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & +subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata @@ -2156,10 +2269,11 @@ subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, ti tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) endif -end subroutine MOM_write_field_3d +end subroutine MOM_write_field_legacy_3d + !> Write a 2d field to an output file, potentially with rotation -subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & +subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & fill_value, turns, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata @@ -2190,10 +2304,11 @@ subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, ti tile_count=tile_count, fill_value=fill_value) deallocate(field_rot) endif -end subroutine MOM_write_field_2d +end subroutine MOM_write_field_legacy_2d + !> Write a 1d field to an output file -subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, dimension(:), intent(in) :: field !< Field to write @@ -2219,10 +2334,11 @@ subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, sc call write_field(IO_handle, field_md, array, tstamp=tstamp) deallocate(array) endif -end subroutine MOM_write_field_1d +end subroutine MOM_write_field_legacy_1d + !> Write a 0d field to an output file -subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) +subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata real, intent(in) :: field !< Field to write @@ -2237,6 +2353,156 @@ subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, sc if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif call write_field(IO_handle, field_md, scaled_val, tstamp=tstamp) +end subroutine MOM_write_field_legacy_0d + + +!> Write a 4d field to an output file, potentially with rotation +subroutine MOM_write_field_4d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled + real :: scale_fac ! A scaling factor to use before writing the array + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_4d + +!> Write a 3d field to an output file, potentially with rotation +subroutine MOM_write_field_3d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled + real :: scale_fac ! A scaling factor to use before writing the array + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_3d + +!> Write a 2d field to an output file, potentially with rotation +subroutine MOM_write_field_2d(IO_handle, field_md, MOM_domain, field, tstamp, tile_count, & + fill_value, turns, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write + real, optional, intent(in) :: tstamp !< Model timestamp + integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value !< Missing data fill value + integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + real :: scale_fac ! A scaling factor to use before writing the array + integer :: qturns ! The number of quarter turns through which to rotate field + + qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if ((qturns == 0) .and. (scale_fac == 1.0)) then + call IO_handle%write_field(field_md, MOM_domain, field, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + else + call allocate_rotated_array(field, [1,1], qturns, field_rot) + call rotate_array(field, qturns, field_rot) + if (scale_fac /= 1.0) call rescale_comp_data(MOM_Domain, field_rot, scale_fac) + call IO_handle%write_field(field_md, MOM_domain, field_rot, tstamp=tstamp, & + tile_count=tile_count, fill_value=fill_value) + deallocate(field_rot) + endif +end subroutine MOM_write_field_2d + +!> Write a 1d field to an output file +subroutine MOM_write_field_1d(IO_handle, field_md, field, tstamp, fill_value, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + real, dimension(:), intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + + real, dimension(:), allocatable :: array ! A rescaled copy of field + real :: scale_fac ! A scaling factor to use before writing the array + integer :: i + + scale_fac = 1.0 ; if (present(scale)) scale_fac = scale + + if (scale_fac == 1.0) then + call IO_handle%write_field(field_md, field, tstamp=tstamp) + else + allocate(array(size(field))) + array(:) = scale_fac * field(:) + if (present(fill_value)) then + do i=1,size(field) ; if (field(i) == fill_value) array(i) = fill_value ; enddo + endif + call IO_handle%write_field(field_md, array, tstamp=tstamp) + deallocate(array) + endif +end subroutine MOM_write_field_1d + +!> Write a 0d field to an output file +subroutine MOM_write_field_0d(IO_handle, field_md, field, tstamp, fill_value, scale) + class(MOM_file), intent(inout) :: IO_handle !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md !< Field type with metadata + real, intent(in) :: field !< Field to write + real, optional, intent(in) :: tstamp !< Model timestamp + real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: scale !< A scaling factor that the field is + !! multiplied by before it is written + real :: scaled_val ! A rescaled copy of field + + scaled_val = field + if (present(scale)) scaled_val = scale*field + if (present(fill_value)) then ; if (field == fill_value) scaled_val = fill_value ; endif + + call IO_handle%write_field(field_md, scaled_val, tstamp=tstamp) end subroutine MOM_write_field_0d !> Given filename and fieldname, this subroutine returns the size of the field in the file diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 new file mode 100644 index 0000000000..68c0f33f07 --- /dev/null +++ b/src/framework/MOM_io_file.F90 @@ -0,0 +1,1654 @@ +!> This module contains the MOM file handler types +module MOM_io_file + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : int64 + +use MOM_domains, only : MOM_domain_type, domain1D +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 +use MOM_io_infra, only : fieldtype +use MOM_io_infra, only : get_file_times, axistype +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_netcdf, only : netcdf_file_type +use MOM_netcdf, only : netcdf_axis +use MOM_netcdf, only : netcdf_field +use MOM_netcdf, only : open_netcdf_file +use MOM_netcdf, only : close_netcdf_file +use MOM_netcdf, only : flush_netcdf_file +use MOM_netcdf, only : register_netcdf_axis +use MOM_netcdf, only : register_netcdf_field +use MOM_netcdf, only : write_netcdf_field +use MOM_netcdf, only : write_netcdf_axis +use MOM_netcdf, only : write_netcdf_attribute +use MOM_netcdf, only : get_netcdf_size +use MOM_netcdf, only : get_netcdf_fields + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_error_handler, only : is_root_PE + +implicit none ; private + +public :: MOM_file +public :: MOM_infra_file +public :: MOM_netcdf_file +public :: MOM_axis +public :: MOM_field + + +! Internal types + +! NOTE: MOM_axis and MOM_field do not represent the actual axes and +! fields stored in the file. They are only very thin wrappers to the keys (as +! strings) used to reference the associated object inside the MOM_file. + +!> Handle for axis in MOM file +type :: MOM_axis + character(len=:), allocatable :: label + !< Identifier for the axis in handle's list +end type MOM_axis + + +!> Linked list of framework axes +type :: axis_list_infra + private + type(axis_node_infra), pointer :: head => null() + !< Head of axis linked list + type(axis_node_infra), pointer :: tail => null() + !< Tail of axis linked list +contains + !> Initialize the framework axis list + procedure :: init => initialize_axis_list_infra + !> Append a new axis to the framework axis list + procedure :: append => append_axis_list_infra + !> Get an axis from the framework axis list + procedure :: get => get_axis_list_infra + !> Deallocate the framework axis list + procedure :: finalize => finalize_axis_list_infra +end type axis_list_infra + + +!> Framework axis linked list node +type :: axis_node_infra + private + character(len=:), allocatable :: label + !< Axis identifier + type(axis_node_infra), pointer :: next => null() + !< Pointer to next axis node + type(axistype) :: axis + !< Axis node contents +end type axis_node_infra + + +!> Linked list of framework axes +type :: axis_list_nc + private + type(axis_node_nc), pointer :: head => null() + !< Head of axis linked list + type(axis_node_nc), pointer :: tail => null() + !< Tail of axis linked list +contains + !> Initialize the netCDF axis list + procedure :: init => initialize_axis_list_nc + !> Append a new axis to the netCDF axis list + procedure :: append => append_axis_list_nc + !> Get an axis from the netCDF axis list + procedure :: get => get_axis_list_nc + !> Deallocate the netCDF axis list + procedure :: finalize => finalize_axis_list_nc +end type axis_list_nc + + +!> Framework axis linked list node +type :: axis_node_nc + private + character(len=:), allocatable :: label + !< Axis identifier + type(axis_node_nc), pointer :: next => null() + !< Pointer to next axis node + type(netcdf_axis) :: axis + !< Axis node contents +end type axis_node_nc + + +!> Handle for field in MOM file +type :: MOM_field + character(len=:), allocatable :: label + !< Identifier for the field in the handle's list +end type MOM_field + + +!> Linked list of framework fields +type :: field_list_infra + private + type(field_node_infra), pointer :: head => null() + !< Head of field linked list + type(field_node_infra), pointer :: tail => null() + !< Tail of field linked list +contains + !> Initialize the framework field list + procedure :: init => initialize_field_list_infra + !> Append a new axis to the framework field list + procedure :: append => append_field_list_infra + !> Get an axis from the framework field list + procedure :: get => get_field_list_infra + !> Deallocate the framework field list + procedure :: finalize => finalize_field_list_infra +end type field_list_infra + + +!> Framework field linked list node +type :: field_node_infra + private + character(len=:), allocatable :: label + !< Field identifier + type(fieldtype) :: field + !< Field node contents + type(field_node_infra), pointer :: next => null() + !< Pointer to next field node +end type field_node_infra + + +!> Linked list of framework fields +type :: field_list_nc + private + type(field_node_nc), pointer :: head => null() + !< Head of field linked list + type(field_node_nc), pointer :: tail => null() + !< Tail of field linked list +contains + !> Initialize the netCDF field list + procedure :: init => initialize_field_list_nc + !> Append a new axis to the netCDF field list + procedure :: append => append_field_list_nc + !> Get an axis from the netCDF field list + procedure :: get => get_field_list_nc + !> Deallocate the netCDF field list + procedure :: finalize => finalize_field_list_nc +end type field_list_nc + + +!> Framework field linked list node +type :: field_node_nc + private + character(len=:), allocatable :: label + !< Field identifier + type(netcdf_field) :: field + !< Field node contents + type(field_node_nc), pointer :: next => null() + !< Pointer to next field node +end type field_node_nc + + +!> Generic MOM file abstraction for common operations +type, abstract :: MOM_file + private + + contains + + !> Open a file and connect to the MOM_file object + procedure(i_open_file), deferred :: open + !> Close the MOM file + procedure(i_close_file), deferred :: close + !> Flush buffered output to the MOM file + procedure(i_flush_file), deferred :: flush + + !> Register an axis to the MOM file + procedure(i_register_axis), deferred :: register_axis + !> Register a field to the MOM file + procedure(i_register_field), deferred :: register_field + !> Write metadata to the MOM file + procedure(i_write_attribute), deferred :: write_attribute + + !> Write field to a MOM file + generic :: write_field => & + write_field_4d, & + write_field_3d, & + write_field_2d, & + write_field_1d, & + write_field_0d, & + write_field_axis + + !> Write a 4D field to the MOM file + procedure(i_write_field_4d), deferred :: write_field_4d + !> Write a 3D field to the MOM file + procedure(i_write_field_3d), deferred :: write_field_3d + !> Write a 2D field to the MOM file + procedure(i_write_field_2d), deferred :: write_field_2d + !> Write a 1D field to the MOM file + procedure(i_write_field_1d), deferred :: write_field_1d + !> Write a 0D field to the MOM file + procedure(i_write_field_0d), deferred :: write_field_0d + !> Write an axis field to the MOM file + procedure(i_write_field_axis), deferred :: write_field_axis + + !> Return true if MOM file has been opened + procedure(i_file_is_open), deferred :: file_is_open + !> Return number of dimensions, variables, or time levels in a MOM file + procedure(i_get_file_info), deferred :: get_file_info + !> Get field objects from a MOM file + procedure(i_get_file_fields), deferred :: get_file_fields + !> Get attributes from a field + procedure(i_get_field_atts), deferred :: get_field_atts + !> Get checksum from a field + procedure(i_read_field_chksum), deferred :: read_field_chksum +end type MOM_file + + +!> MOM file from the supporting framework ("infra") layer +type, extends(MOM_file) :: MOM_infra_file + private + + ! NOTE: This will be made private after the API transition + type(file_type), public :: handle_infra + !< Framework-specific file handler content + type(axis_list_infra) :: axes + !< List of axes in file + type(field_list_infra) :: fields + !< List of fields in file + + contains + + !> Open a framework file and connect to the MOM_file object + procedure :: open => open_file_infra + !> Close the MOM framework file + procedure :: close => close_file_infra + !> Flush buffered output to the MOM framework file + procedure :: flush => flush_file_infra + + !> Register an axis to the MOM framework file + procedure :: register_axis => register_axis_infra + !> Register a field to the MOM framework file + procedure :: register_field => register_field_infra + !> Write global metadata to the MOM framework file + procedure :: write_attribute => write_attribute_infra + + !> Write a 4D field to the MOM framework file + procedure :: write_field_4d => write_field_4d_infra + !> Write a 3D field to the MOM framework file + procedure :: write_field_3d => write_field_3d_infra + !> Write a 2D field to the MOM framework file + procedure :: write_field_2d => write_field_2d_infra + !> Write a 1D field to the MOM framework file + procedure :: write_field_1d => write_field_1d_infra + !> Write a 0D field to the MOM framework file + procedure :: write_field_0d => write_field_0d_infra + !> Write an axis field to the MOM framework file + procedure :: write_field_axis => write_field_axis_infra + + !> Return true if MOM infra file has been opened + procedure :: file_is_open => file_is_open_infra + !> Return number of dimensions, variables, or time levels in a MOM infra file + procedure :: get_file_info => get_file_info_infra + !> Get field metadata from a MOM infra file + procedure :: get_file_fields => get_file_fields_infra + !> Get attributes from a field + procedure :: get_field_atts => get_field_atts_infra + !> Get checksum from a field + procedure :: read_field_chksum => read_field_chksum_infra + + ! MOM_infra_file methods + ! NOTE: These could naturally reside in MOM_file but is currently not needed. + + !> Get time levels of a MOM framework file + procedure :: get_file_times => get_file_times_infra + + !> Get the fields as fieldtypes from a file + procedure :: get_file_fieldtypes + ! NOTE: This is provided to support the legacy API and may be removed. +end type MOM_infra_file + + +!> MOM file using netCDF backend +type, extends(MOM_file) :: MOM_netcdf_file + private + + !> Framework-specific file handler content + type(netcdf_file_type) :: handle_nc + !> List of netCDF axes + type(axis_list_nc) :: axes + !> List of netCDF fields + type(field_list_nc) :: fields + !> True if the file has been opened + logical :: is_open = .false. + + contains + + !> Open a framework file and connect to the MOM_netcdf_file object + procedure :: open => open_file_nc + !> Close the MOM netcdf file + procedure :: close => close_file_nc + !> Flush buffered output to the MOM netcdf file + procedure :: flush => flush_file_nc + + !> Register an axis to the MOM netcdf file + procedure :: register_axis => register_axis_nc + !> Register a field to the MOM netcdf file + procedure :: register_field => register_field_nc + !> Write global metadata to the MOM netcdf file + procedure :: write_attribute => write_attribute_nc + + !> Write a 4D field to the MOM netcdf file + procedure :: write_field_4d => write_field_4d_nc + !> Write a 3D field to the MOM netcdf file + procedure :: write_field_3d => write_field_3d_nc + !> Write a 2D field to the MOM netcdf file + procedure :: write_field_2d => write_field_2d_nc + !> Write a 1D field to the MOM netcdf file + procedure :: write_field_1d => write_field_1d_nc + !> Write a 0D field to the MOM netcdf file + procedure :: write_field_0d => write_field_0d_nc + !> Write an axis field to the MOM netcdf file + procedure :: write_field_axis => write_field_axis_nc + + !> Return true if MOM netcdf file has been opened + procedure :: file_is_open => file_is_open_nc + !> Return number of dimensions, variables, or time levels in a MOM netcdf file + procedure :: get_file_info => get_file_info_nc + !> Get field metadata from a MOM netcdf file + procedure :: get_file_fields => get_file_fields_nc + !> Get attributes from a netCDF field + procedure :: get_field_atts => get_field_atts_nc + !> Get checksum from a netCDF field + procedure :: read_field_chksum => read_field_chksum_nc +end type MOM_netcdf_file + + +interface + !> Interface for opening a MOM file + subroutine i_open_file(handle, filename, action, MOM_domain, threading, fileset) + import :: MOM_file, MOM_domain_type + + class(MOM_file), intent(inout) :: 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 or written to and how + !! to handle existing files. The default is WRITE_ONLY. + type(MOM_domain_type), optional, intent(in) :: MOM_Domain + !< A MOM_Domain that describes the decomposition + 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). + end subroutine i_open_file + + + !> Interface for closing a MOM file + subroutine i_close_file(handle) + import :: MOM_file + class(MOM_file), intent(inout) :: handle + !< The MOM file to be closed + end subroutine i_close_file + + + !> Interface for flushing I/O in a MOM file + subroutine i_flush_file(handle) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< The MOM file to be flushed + end subroutine i_flush_file + + + !> Interface to register an axis to a MOM file + function i_register_axis(handle, label, units, longname, cartesian, sense, & + domain, data, edge_axis, calendar) result(axis) + import :: MOM_file, MOM_axis, domain1D + + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they + !! increase downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + !< IO handle for axis in MOM_file + end function i_register_axis + + + !> Interface to register a field to a netCDF file + function i_register_field(handle, axes, label, units, longname, & + pack, standard_name, checksum) result(field) + import :: MOM_file, MOM_axis, MOM_field, int64 + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axes(:) + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + type(MOM_field) :: field + !< IO handle for field in MOM_file + end function i_register_field + + + !> Interface for writing global metata to a MOM file + subroutine i_write_attribute(handle, name, attribute) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + end subroutine i_write_attribute + + + !> Interface to write_field_4d() + subroutine i_write_field_4d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_4d + + + !> Interface to write_field_3d() + subroutine i_write_field_3d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_3d + + + !> Interface to write_field_2d() + subroutine i_write_field_2d(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + import :: MOM_file, MOM_field, MOM_domain_type + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + end subroutine i_write_field_2d + + + !> Interface to write_field_1d() + subroutine i_write_field_1d(handle, field_md, field, tstamp) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + end subroutine i_write_field_1d + + + !> Interface to write_field_0d() + subroutine i_write_field_0d(handle, field_md, field, tstamp) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + end subroutine i_write_field_0d + + + !> Interface to write_field_axis() + subroutine i_write_field_axis(handle, axis) + import :: MOM_file, MOM_axis + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + end subroutine i_write_field_axis + + + !> Interface to file_is_open() + logical function i_file_is_open(handle) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle to a file to inquire about + end function i_file_is_open + + + !> Interface to get_file_info() + subroutine i_get_file_info(handle, ndim, nvar, ntime) + import :: MOM_file + class(MOM_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + end subroutine i_get_file_info + + + !> Interface to get_file_fields() + subroutine i_get_file_fields(handle, fields) + import :: MOM_file, MOM_field + class(MOM_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), dimension(:), intent(inout) :: fields + !< Field-type descriptions of all of the variables in a file. + end subroutine i_get_file_fields + + + !> Interface to get_field_atts() + subroutine i_get_field_atts(handle, field, name, units, longname, checksum) + import :: MOM_file, MOM_field, int64 + class(MOM_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + end subroutine i_get_field_atts + + + !> Interface to read_field_chksum + subroutine i_read_field_chksum(handle, field, chksum, valid_chksum) + import :: MOM_file, MOM_field, int64 + class(MOM_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + end subroutine i_read_field_chksum +end interface + +contains + +!> Initialize the linked list of framework axes +subroutine initialize_axis_list_infra(list) + class(axis_list_infra), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_axis_list_infra + + +!> Append a new axis to the list +subroutine append_axis_list_infra(list, axis, label) + class(axis_list_infra), intent(inout) :: list + type(axistype), intent(in) :: axis + character(len=*), intent(in) :: label + + type(axis_node_infra), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%axis = axis + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_axis_list_infra + + +!> Get axis based on label +function get_axis_list_infra(list, label) result(axis) + class(axis_list_infra), intent(in) :: list + character(len=*), intent(in) :: label + type(axistype) :: axis + + type(axis_node_infra), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "axis associated with " // label // " not found.") + + axis = node%axis +end function get_axis_list_infra + + +!> Deallocate axes of list +subroutine finalize_axis_list_infra(list) + class(axis_list_infra), intent(inout) :: list + + type(axis_node_infra), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_axis_list_infra + + +!> Initialize the linked list of framework axes +subroutine initialize_axis_list_nc(list) + class(axis_list_nc), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_axis_list_nc + + +!> Append a new axis to the list +subroutine append_axis_list_nc(list, axis, label) + class(axis_list_nc), intent(inout) :: list + type(netcdf_axis), intent(in) :: axis + character(len=*), intent(in) :: label + + type(axis_node_nc), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%axis = axis + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_axis_list_nc + + +!> Get axis based on label +function get_axis_list_nc(list, label) result(axis) + class(axis_list_nc), intent(in) :: list + character(len=*), intent(in) :: label + type(netcdf_axis) :: axis + + type(axis_node_nc), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "axis associated with " // label // " not found.") + + axis = node%axis +end function get_axis_list_nc + + +!> Deallocate axes of list +subroutine finalize_axis_list_nc(list) + class(axis_list_nc), intent(inout) :: list + + type(axis_node_nc), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_axis_list_nc + + +!> Initialize the linked list of framework axes +subroutine initialize_field_list_infra(list) + class(field_list_infra), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_field_list_infra + + +!> Append a new field to the list +subroutine append_field_list_infra(list, field, label) + class(field_list_infra), intent(inout) :: list + type(fieldtype), intent(in) :: field + character(len=*), intent(in) :: label + + type(field_node_infra), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%field = field + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_field_list_infra + + +!> Get axis based on label +function get_field_list_infra(list, label) result(field) + class(field_list_infra), intent(in) :: list + character(len=*), intent(in) :: label + type(fieldtype) :: field + + type(field_node_infra), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "field associated with " // label // " not found.") + + field = node%field +end function get_field_list_infra + + +!> Deallocate fields of list +subroutine finalize_field_list_infra(list) + class(field_list_infra), intent(inout) :: list + + type(field_node_infra), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_field_list_infra + + +!> Initialize the linked list of framework axes +subroutine initialize_field_list_nc(list) + class(field_list_nc), intent(inout) :: list + + ! Pre-allocate the first node and set the tail to this empty node + allocate(list%head) + list%tail => list%head +end subroutine initialize_field_list_nc + + +!> Append a new field to the list +subroutine append_field_list_nc(list, field, label) + class(field_list_nc), intent(inout) :: list + type(netcdf_field), intent(in) :: field + character(len=*), intent(in) :: label + + type(field_node_nc), pointer :: empty_node + + ! Transfer value to tail + list%tail%label = label + list%tail%field = field + + ! Extend list to next empty node + allocate(empty_node) + list%tail%next => empty_node + list%tail => empty_node +end subroutine append_field_list_nc + + +!> Get axis based on label +function get_field_list_nc(list, label) result(field) + class(field_list_nc), intent(in) :: list + character(len=*), intent(in) :: label + type(netcdf_field) :: field + + type(field_node_nc), pointer :: node + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => list%head + do while(associated(node%next)) + if (node%label == label) exit + node => node%next + enddo + if (.not. associated(node)) & + call MOM_error(FATAL, "field associated with " // label // " not found.") + + field = node%field +end function get_field_list_nc + + +!> Deallocate fields of list +subroutine finalize_field_list_nc(list) + class(field_list_nc), intent(inout) :: list + + type(field_node_nc), pointer :: node, next_node + + node => list%head + do while(associated(node)) + next_node => node + node => node%next + deallocate(next_node) + enddo +end subroutine finalize_field_list_nc + + +!> Open a MOM framework file +subroutine open_file_infra(handle, filename, action, MOM_domain, threading, fileset) + class(MOM_infra_file), intent(inout) :: handle + character(len=*), intent(in) :: filename + integer, intent(in), optional :: action + type(MOM_domain_type), optional, intent(in) :: MOM_domain + 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) + + call handle%axes%init() + call handle%fields%init() +end subroutine open_file_infra + +!> Close a MOM framework file +subroutine close_file_infra(handle) + class(MOM_infra_file), intent(inout) :: handle + + call close_file(handle%handle_infra) + call handle%axes%finalize() + call handle%fields%finalize() +end subroutine close_file_infra + +!> Flush the buffer of a MOM framework file +subroutine flush_file_infra(handle) + class(MOM_infra_file), intent(in) :: handle + + call flush_file(handle%handle_infra) +end subroutine flush_file_infra + + +!> Register an axis to the MOM framework file +function register_axis_infra(handle, label, units, longname, & + cartesian, sense, domain, data, edge_axis, calendar) result(axis) + + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they increase + !! downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + !< The axis type where this information is stored + + type(axistype) :: ax_infra + + ! Create new infra axis and assign to pre-allocated tail of axes + call write_metadata(handle%handle_infra, ax_infra, label, units, longname, & + cartesian=cartesian, sense=sense, domain=domain, data=data, & + edge_axis=edge_axis, calendar=calendar) + + call handle%axes%append(ax_infra, label) + axis%label = label +end function register_axis_infra + + +!> Register a field to the MOM framework file +function register_field_infra(handle, axes, label, units, longname, pack, & + standard_name, checksum) result(field) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), dimension(:), intent(in) :: axes + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + type(MOM_field) :: field + !< The field type where this information is stored + + type(fieldtype) :: field_infra + type(axistype), allocatable :: field_axes(:) + integer :: i + + ! Construct array of framework axes + allocate(field_axes(size(axes))) + do i = 1, size(axes) + field_axes(i) = handle%axes%get(axes(i)%label) + enddo + + call write_metadata(handle%handle_infra, field_infra, field_axes, label, & + units, longname, pack=pack, standard_name=standard_name, checksum=checksum) + + call handle%fields%append(field_infra, label) + field%label = label +end function register_field_infra + + +!> Write a 4D field to the MOM framework file +subroutine write_field_4d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) +end subroutine write_field_4d_infra + + +!> Write a 3D field to the MOM framework file +subroutine write_field_3d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) +end subroutine write_field_3d_infra + + +!> Write a 2D field to the MOM framework file +subroutine write_field_2d_infra(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, MOM_domain, field, & + tstamp=tstamp, tile_count=tile_count, fill_value=fill_value) +end subroutine write_field_2d_infra + + +!> Write a 1D field to the MOM framework file +subroutine write_field_1d_infra(handle, field_md, field, tstamp) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) +end subroutine write_field_1d_infra + + +!> Write a 0D field to the MOM framework file +subroutine write_field_0d_infra(handle, field_md, field, tstamp) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field_md%label) + call write_field(handle%handle_infra, field_infra, field, tstamp=tstamp) +end subroutine write_field_0d_infra + + +!> Write an axis field to the MOM framework file +subroutine write_field_axis_infra(handle, axis) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + + type(axistype) :: axis_infra + !< An axis type variable with information to write + + axis_infra = handle%axes%get(axis%label) + call write_field(handle%handle_infra, axis_infra) +end subroutine write_field_axis_infra + + +!> Write global metadata to the MOM framework file +subroutine write_attribute_infra(handle, name, attribute) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for writing + character(len=*), intent(in) :: name + !< The name in the file of this global attribute + character(len=*), intent(in) :: attribute + !< The value of this attribute + + call write_metadata(handle%handle_infra, name, attribute) +end subroutine write_attribute_infra + + +!> True if the framework file has been opened +logical function file_is_open_infra(handle) + class(MOM_infra_file), intent(in) :: handle + !< Handle to a file to inquire about + + file_is_open_infra = fms2_file_is_open(handle%handle_infra) +end function file_is_open_infra + + +!> Return number of dimensions, variables, or time levels in a MOM infra file +subroutine get_file_info_infra(handle, ndim, nvar, ntime) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + call get_file_info(handle%handle_infra, ndim, nvar, ntime) +end subroutine get_file_info_infra + + +!> Return the field metadata associated with a MOM framework file +subroutine get_file_fields_infra(handle, fields) + class(MOM_infra_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(fieldtype), allocatable :: fields_infra(:) + integer :: i + character(len=64) :: label + + allocate(fields_infra(size(fields))) + call get_file_fields(handle%handle_infra, fields_infra) + + do i = 1, size(fields) + call get_field_atts(fields_infra(i), name=label) + call handle%fields%append(fields_infra(i), trim(label)) + fields(i)%label = trim(label) + enddo +end subroutine get_file_fields_infra + + +!> Get time levels of a MOM framework file +subroutine get_file_times_infra(handle, time_values, ntime) + class(MOM_infra_file), intent(in) :: handle + !< Handle for a file that is open for I/O + real, allocatable, dimension(:), intent(inout) :: time_values + !< The real times for the records in file. + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + call get_file_times(handle%handle_infra, time_values, ntime=ntime) +end subroutine get_file_times_infra + + +!> Get attributes from a field +subroutine get_field_atts_infra(handle, field, name, units, longname, checksum) + class(MOM_infra_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field%label) + call get_field_atts(field_infra, name, units, longname, checksum) +end subroutine get_field_atts_infra + + +!> Interface to read_field_chksum +subroutine read_field_chksum_infra(handle, field, chksum, valid_chksum) + class(MOM_infra_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + + type(fieldtype) :: field_infra + + field_infra = handle%fields%get(field%label) + call read_field_chksum(field_infra, chksum, valid_chksum) +end subroutine read_field_chksum_infra + +!> Get the native (fieldtype) fields of a MOM framework file +subroutine get_file_fieldtypes(handle, fields) + class(MOM_infra_file), intent(in) :: handle + type(fieldtype), intent(out) :: fields(:) + + type(field_node_infra), pointer :: node + integer :: i + + ! NOTE: The tail is a pre-allocated empty node, so we check node%next + node => handle%fields%head + do i = 1, size(fields) + if (.not. associated(node%next)) & + call MOM_error(FATAL, 'fields(:) size exceeds number of registered fields.') + fields(i) = node%field + node => node%next + enddo +end subroutine get_file_fieldtypes + + +! MOM_netcdf_file methods + +!> Open a MOM netCDF file +subroutine open_file_nc(handle, filename, action, MOM_domain, threading, fileset) + class(MOM_netcdf_file), intent(inout) :: handle + character(len=*), intent(in) :: filename + integer, intent(in), optional :: action + type(MOM_domain_type), optional, intent(in) :: MOM_domain + integer, intent(in), optional :: threading + integer, intent(in), optional :: fileset + + if (.not. is_root_PE()) return + + call open_netcdf_file(handle%handle_nc, filename, action) + + handle%is_open = .true. + call handle%axes%init() + call handle%fields%init() +end subroutine open_file_nc + + +!> Close a MOM netCDF file +subroutine close_file_nc(handle) + class(MOM_netcdf_file), intent(inout) :: handle + + if (.not. is_root_PE()) return + + handle%is_open = .false. + call close_netcdf_file(handle%handle_nc) +end subroutine close_file_nc + + +!> Flush the buffer of a MOM netCDF file +subroutine flush_file_nc(handle) + class(MOM_netcdf_file), intent(in) :: handle + + if (.not. is_root_PE()) return + + call flush_netcdf_file(handle%handle_nc) +end subroutine flush_file_nc + + +!> Register an axis to the MOM netcdf file +function register_axis_nc(handle, label, units, longname, cartesian, sense, & + domain, data, edge_axis, calendar) result(axis) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a netCDF file that is open for writing + character(len=*), intent(in) :: label + !< The name in the file of this axis + character(len=*), intent(in) :: units + !< The units of this axis + character(len=*), intent(in) :: longname + !< The long description of this axis + character(len=*), optional, intent(in) :: cartesian + !< A variable indicating which direction this axis corresponds with. + !! Valid values include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer, optional, intent(in) :: sense + !< This is 1 for axes whose values increase upward, or -1 if they increase + !! downward. + type(domain1D), optional, intent(in) :: domain + !< The domain decomposion for this axis + real, dimension(:), optional, intent(in) :: data + !< The coordinate values of the points on this axis + logical, optional, intent(in) :: edge_axis + !< If true, this axis marks an edge of the tracer cells + character(len=*), optional, intent(in) :: calendar + !< The name of the calendar used with a time axis + type(MOM_axis) :: axis + + type(netcdf_axis) :: axis_nc + + if (is_root_PE()) then + axis_nc = register_netcdf_axis(handle%handle_nc, label, units, longname, & + data, cartesian, sense) + + call handle%axes%append(axis_nc, label) + endif + axis%label = label +end function register_axis_nc + + +!> Register a field to the MOM netcdf file +function register_field_nc(handle, axes, label, units, longname, pack, & + standard_name, checksum) result(field) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axes(:) + !< Handles for the axis used for this variable + character(len=*), intent(in) :: label + !< The name in the file of this variable + character(len=*), intent(in) :: units + !< The units of this variable + character(len=*), intent(in) :: longname + !< The long description of this variable + integer, optional, intent(in) :: pack + !< A precision reduction factor with which the variable. The default, 1, + !! has no reduction, but 2 is not uncommon. + character(len=*), optional, intent(in) :: standard_name + !< The standard (e.g., CMOR) name for this variable + integer(kind=int64), dimension(:), optional, intent(in) :: checksum + !< Checksum values that can be used to verify reads. + type(MOM_field) :: field + + type(netcdf_field) :: field_nc + type(netcdf_axis), allocatable :: axes_nc(:) + integer :: i + + if (is_root_PE()) then + allocate(axes_nc(size(axes))) + do i = 1, size(axes) + axes_nc(i) = handle%axes%get(axes(i)%label) + enddo + + field_nc = register_netcdf_field(handle%handle_nc, label, axes_nc, longname, units) + + call handle%fields%append(field_nc, label) + endif + field%label = label +end function register_field_nc + + +!> Write global metadata to the MOM netcdf file +subroutine write_attribute_nc(handle, name, attribute) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle for a file that is open for writing + 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 (.not. is_root_PE()) return + + call write_netcdf_attribute(handle%handle_nc, name, attribute) +end subroutine write_attribute_nc + + +!> Write a 4D field to the MOM netcdf file +subroutine write_field_4d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_4d_nc + + +!> Write a 3D field to the MOM netcdf file +subroutine write_field_3d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, intent(inout) :: field(:,:,:) + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_3d_nc + + +!> Write a 2D field to the MOM netcdf file +subroutine write_field_2d_nc(handle, field_md, MOM_domain, field, tstamp, & + tile_count, fill_value) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + type(MOM_domain_type), intent(in) :: MOM_domain + !< The MOM_Domain that describes the decomposition + real, dimension(:,:), intent(inout) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + integer, optional, intent(in) :: tile_count + !< PEs per tile (default: 1) + real, optional, intent(in) :: fill_value + !< Missing data fill value + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_2d_nc + + +!> Write a 1D field to the MOM netcdf file +subroutine write_field_1d_nc(handle, field_md, field, tstamp) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, dimension(:), intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_1d_nc + + +!> Write a 0D field to the MOM netcdf file +subroutine write_field_0d_nc(handle, field_md, field, tstamp) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_field), intent(in) :: field_md + !< Field type with metadata + real, intent(in) :: field + !< Field to write + real, optional, intent(in) :: tstamp + !< Model time of this field + + type(netcdf_field) :: field_nc + + if (.not. is_root_PE()) return + + field_nc = handle%fields%get(field_md%label) + call write_netcdf_field(handle%handle_nc, field_nc, field, time=tstamp) +end subroutine write_field_0d_nc + + +!> Write an axis field to the MOM netcdf file +subroutine write_field_axis_nc(handle, axis) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for writing + type(MOM_axis), intent(in) :: axis + !< An axis type variable with information to write + + type(netcdf_axis) :: axis_nc + + if (.not. is_root_PE()) return + + axis_nc = handle%axes%get(axis%label) + call write_netcdf_axis(handle%handle_nc, axis_nc) +end subroutine write_field_axis_nc + + +!> True if the framework file has been opened +logical function file_is_open_nc(handle) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle to a file to inquire about + + file_is_open_nc = handle%is_open +end function file_is_open_nc + + +!> Return number of dimensions, variables, or time levels in a MOM netcdf file +subroutine get_file_info_nc(handle, ndim, nvar, ntime) + class(MOM_netcdf_file), intent(in) :: handle + !< Handle for a file that is open for I/O + integer, optional, intent(out) :: ndim + !< The number of dimensions in the file + integer, optional, intent(out) :: nvar + !< The number of variables in the file + integer, optional, intent(out) :: ntime + !< The number of time levels in the file + + integer :: ndim_nc, nvar_nc + + if (.not. is_root_PE()) return + + call get_netcdf_size(handle%handle_nc, ndims=ndim_nc, nvars=nvar_nc, nsteps=ntime) + + ! MOM I/O follows legacy FMS behavior and excludes axes from field count + if (present(ndim)) ndim = ndim_nc + if (present(nvar)) nvar = nvar_nc - ndim_nc +end subroutine get_file_info_nc + + +!> Return the field metadata associated with a MOM netCDF file +subroutine get_file_fields_nc(handle, fields) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(netcdf_axis), allocatable :: axes_nc(:) + type(netcdf_field), allocatable :: fields_nc(:) + integer :: i + + if (.not. is_root_PE()) return + + call get_netcdf_fields(handle%handle_nc, axes_nc, fields_nc) + if (size(fields) /= size(fields_nc)) & + call MOM_error(FATAL, 'Number of fields in file does not match field(:).') + + do i = 1, size(axes_nc) + call handle%axes%append(axes_nc(i), axes_nc(i)%label) + enddo + + do i = 1, size(fields) + fields(i)%label = trim(fields_nc(i)%label) + call handle%fields%append(fields_nc(i), fields_nc(i)%label) + enddo +end subroutine get_file_fields_nc + + +!> Get attributes from a netCDF field +subroutine get_field_atts_nc(handle, field, name, units, longname, checksum) + class(MOM_netcdf_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field to extract information from + character(len=*), optional, intent(out) :: name + !< The variable name + character(len=*), optional, intent(out) :: units + !< The units of the variable + character(len=*), optional, intent(out) :: longname + !< The long name of the variable + integer(kind=int64), optional, intent(out) :: checksum(:) + !< The checksums of the variable in a file + + call MOM_error(FATAL, 'get_field_atts over netCDF is not yet implemented.') +end subroutine get_field_atts_nc + + +!> Interface to read_field_chksum +subroutine read_field_chksum_nc(handle, field, chksum, valid_chksum) + class(MOM_netcdf_file), intent(in) :: handle + !< File where field is stored + type(MOM_field), intent(in) :: field + !< The field whose checksum attribute is to be read + integer(kind=int64), intent(out) :: chksum + !< The checksum for the field. + logical, intent(out) :: valid_chksum + !< If true, chksum has been successfully read + + call MOM_error(FATAL, 'read_field_chksum over netCDF is not yet implemented.') +end subroutine read_field_chksum_nc + + +!> \namespace MOM_IO_file +!! +!! This file defines the MOM_file classes used to inferface with the internal +!! IO handlers, such as the configured "infra" layer (FMS) or native netCDF. +!! +!! `MOM_file`: The generic class used to reference any file type +!! Cannot be used in a variable declaration. +!! +!! `MOM_infra_file`: A file handler for use by the infra layer. Currently this +!! means an FMS file, such a restart or diagnostic output. +!! +!! `MOM_netcdf_file`: A netCDF file handler for MOM-specific I/O. This may +!! include operations outside the scope of FMS or other infra frameworks. + +end module MOM_io_file diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 new file mode 100644 index 0000000000..d09ae5cf95 --- /dev/null +++ b/src/framework/MOM_netcdf.F90 @@ -0,0 +1,755 @@ +!> MOM6 interface to netCDF operations +module MOM_netcdf + +! This file is part of MOM6. See LICENSE.md for the license. + +use, intrinsic :: iso_fortran_env, only : real32, real64 + +use netcdf, only : nf90_create, nf90_open, nf90_close +use netcdf, only : nf90_sync +use netcdf, only : NF90_CLOBBER, NF90_NOCLOBBER, NF90_WRITE, NF90_NOWRITE +use netcdf, only : nf90_enddef +use netcdf, only : nf90_def_dim, nf90_def_var +use netcdf, only : NF90_UNLIMITED +use netcdf, only : nf90_get_var +use netcdf, only : nf90_put_var, nf90_put_att +use netcdf, only : NF90_FLOAT, NF90_DOUBLE +use netcdf, only : nf90_strerror, NF90_NOERR +use netcdf, only : NF90_GLOBAL +use netcdf, only : nf90_inquire, nf90_inquire_dimension, nf90_inquire_variable +use netcdf, only : nf90_inq_dimids, nf90_inq_varids +use netcdf, only : NF90_MAX_NAME + +use MOM_error_handler, only : MOM_error, FATAL +use MOM_io_infra, only : READONLY_FILE, WRITEONLY_FILE +use MOM_io_infra, only : APPEND_FILE, OVERWRITE_FILE + +implicit none ; private + +public :: netcdf_file_type +public :: netcdf_axis +public :: netcdf_field +public :: open_netcdf_file +public :: close_netcdf_file +public :: flush_netcdf_file +public :: register_netcdf_axis +public :: register_netcdf_field +public :: write_netcdf_field +public :: write_netcdf_axis +public :: write_netcdf_attribute +public :: get_netcdf_size +public :: get_netcdf_fields + + +!> Internal time value used to indicate an uninitialized time +real, parameter :: NULLTIME = -1 +! NOTE: For now, we use the FMS-compatible value, but may change in the future. + + +!> netCDF file abstraction +type :: netcdf_file_type + private + integer :: ncid + !< netCDF file ID + character(len=:), allocatable :: filename + !< netCDF filename + logical :: define_mode + !< True if file is in define mode. + integer :: time_id + !< Time axis variable ID + real :: time + !< Current model time + integer :: time_level + !< Current time level for output +end type netcdf_file_type + + +!> Dimension axis for a netCDF file +type :: netcdf_axis + private + character(len=:), allocatable, public :: label + !< Axis label name + real, allocatable :: points(:) + !< Grid points along the axis + integer :: dimid + !< netCDF dimension ID associated with axis + integer :: varid + !< netCDF variable ID associated with axis +end type netcdf_axis + + +!> Field variable for a netCDF file +type netcdf_field + private + character(len=:), allocatable, public :: label + !< Variable name + integer :: varid + !< netCDF variable ID for field +end type netcdf_field + + +!> Write values to a field of a netCDF file +interface write_netcdf_field + module procedure write_netcdf_field_4d + module procedure write_netcdf_field_3d + module procedure write_netcdf_field_2d + module procedure write_netcdf_field_1d + module procedure write_netcdf_field_0d +end interface write_netcdf_field + +contains + +subroutine open_netcdf_file(handle, filename, mode) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + character(len=*), intent(in) :: filename + !< netCDF filename + integer, intent(in), optional :: mode + !< Input MOM I/O mode + + integer :: io_mode + ! MOM I/O mode + integer :: cmode + ! netCDF creation mode + integer :: rc + ! nf90_create return code + character(len=:), allocatable :: msg + ! netCDF error message buffer + + ! I/O configuration + io_mode = WRITEONLY_FILE + if (present(mode)) io_mode = mode + + ! Translate the MOM I/O config to the netCDF mode + select case(io_mode) + case (WRITEONLY_FILE) + rc = nf90_create(filename, nf90_noclobber, handle%ncid) + handle%define_mode = .true. + case (OVERWRITE_FILE) + rc = nf90_create(filename, nf90_clobber, handle%ncid) + handle%define_mode = .true. + case (APPEND_FILE) + rc = nf90_open(filename, nf90_write, handle%ncid) + handle%define_mode = .false. + case (READONLY_FILE) + rc = nf90_open(filename, nf90_nowrite, handle%ncid) + handle%define_mode = .false. + case default + call MOM_error(FATAL, & + 'open_netcdf_file: File ' // filename // ': Unknown mode.') + end select + call check_netcdf_call(rc, 'open_netcdf_file', 'File ' // filename) + + handle%filename = filename + + ! FMS writes the filename as an attribute + call write_netcdf_attribute(handle, 'filename', filename) +end subroutine open_netcdf_file + + +!> Close an opened netCDF file. +subroutine close_netcdf_file(handle) + type(netcdf_file_type), intent(in) :: handle + + integer :: rc + + rc = nf90_close(handle%ncid) + call check_netcdf_call(rc, 'close_netcdf_file', & + 'File "' // handle%filename // '"') +end subroutine close_netcdf_file + + +!> Flush buffered output to the netCDF file +subroutine flush_netcdf_file(handle) + type(netcdf_file_type), intent(in) :: handle + + integer :: rc + + rc = nf90_sync(handle%ncid) + call check_netcdf_call(rc, 'flush_netcdf_file', & + 'File "' // handle%filename // '"') +end subroutine flush_netcdf_file + + +!> Change netCDF mode of handle from 'define' to 'write'. +subroutine enable_netcdf_write(handle) + type(netcdf_file_type), intent(inout) :: handle + + integer :: rc + + if (handle%define_mode) then + rc = nf90_enddef(handle%ncid) + call check_netcdf_call(rc, 'enable_netcdf_write', & + 'File "' // handle%filename // '"') + handle%define_mode = .false. + endif +end subroutine enable_netcdf_write + + +!> Register a netCDF variable +function register_netcdf_field(handle, label, axes, longname, units) & + result(field) + type(netcdf_file_type), intent(in) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< netCDF field name in the file + type(netcdf_axis), intent(in) :: axes(:) + !< Axes along which field is defined + character(len=*), intent(in) :: longname + !< Long name of the netCDF field + character(len=*), intent(in) :: units + !< Field units of measurement + type(netcdf_field) :: field + !< netCDF field + + integer :: rc + ! netCDF function return code + integer :: i + ! Loop index + integer, allocatable :: dimids(:) + ! netCDF dimension IDs of axes + integer :: xtype + ! netCDF data type + + ! Gather the axis netCDF dimension IDs + allocate(dimids(size(axes))) + dimids(:) = [(axes(i)%dimid, i = 1, size(axes))] + + ! Determine the corresponding netCDF data type + ! TODO: Support a `pack`-like argument + select case (kind(1.0)) + case (real32) + xtype = NF90_FLOAT + case (real64) + xtype = NF90_DOUBLE + case default + call MOM_error(FATAL, "register_netcdf_axis: Unknown kind(real).") + end select + + ! Register the field variable + rc = nf90_def_var(handle%ncid, label, xtype, dimids, field%varid) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'File "' // handle%filename // '", Field "' // label // '"') + + ! Assign attributes + + rc = nf90_put_att(handle%ncid, field%varid, 'long_name', longname) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'Attribute "long_name" of variable "' // label // '" in file "' & + // handle%filename // '"') + + rc = nf90_put_att(handle%ncid, field%varid, 'units', units) + call check_netcdf_call(rc, 'register_netcdf_field', & + 'Attribute "units" of variable "' // label // '" in file "' & + // handle%filename // '"') +end function register_netcdf_field + + +!> Create an axis and associated dimension in a netCDF file +function register_netcdf_axis(handle, label, units, longname, points, & + cartesian, sense) result(axis) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< netCDF axis name in the file + character(len=*), intent(in), optional :: units + !< Axis units of measurement + character(len=*), intent(in), optional :: longname + !< Long name of the axis + real, intent(in), optional :: points(:) + !< Values of axis points (for fixed axes) + character(len=*), intent(in), optional :: cartesian + !< Character denoting axis direction: X, Y, Z, T, or N for none + integer, intent(in), optional :: sense + !< Axis direction; +1 if axis increases upward or -1 if downward + + type(netcdf_axis) :: axis + !< netCDF coordinate axis + + integer :: xtype + ! netCDF external data type + integer :: rc + ! netCDF function return code + logical :: unlimited + ! True if the axis is unlimited in size (e.g. time) + integer :: axis_size + ! Either the number of points in the axis, or unlimited flag + integer :: axis_sense + ! Axis direction; +1 if axis increases upward or -1 if downward + character(len=:), allocatable :: sense_attr + ! CF-compiant value of sense attribute (as 'positive') + + ! Create the axis dimension + unlimited = .false. + if (present(cartesian)) then + if (cartesian == 'T') unlimited = .true. + endif + + ! Either the axis is explicitly set with data or is declared as unlimited + if (present(points) .eqv. unlimited) then + call MOM_error(FATAL, & + "Axis must either have explicit points or be a time axis ('T').") + endif + + if (present(points)) then + axis_size = size(points) + allocate(axis%points(axis_size)) + axis%points(:) = points(:) + else + axis_size = NF90_UNLIMITED + endif + + rc = nf90_def_dim(handle%ncid, label, axis_size, axis%dimid) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Dimension "' // label // '" in file "' // handle%filename // '"') + + ! Determine the corresponding netCDF data type + ! TODO: Support a `pack`-like argument + select case (kind(1.0)) + case (real32) + xtype = NF90_FLOAT + case (real64) + xtype = NF90_DOUBLE + case default + call MOM_error(FATAL, "register_netcdf_axis: Unknown kind(real).") + end select + + ! Create a variable corresponding to the axis + rc = nf90_def_var(handle%ncid, label, xtype, axis%dimid, axis%varid) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Variable ' // label // ' in file ' // handle%filename) + + ! Define the time axis, if available + if (unlimited) then + handle%time_id = axis%varid + handle%time_level = 0 + handle%time = NULLTIME + endif + + ! Assign attributes if present + if (present(longname)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'long_name', longname) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''long_name'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + if (present(units)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'units', units) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''units'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + if (present(cartesian)) then + rc = nf90_put_att(handle%ncid, axis%varid, 'cartesian_axis', cartesian) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute ''cartesian_axis'' of variable ' // label // ' in file ' & + // handle%filename) + endif + + axis_sense = 0 + if (present(sense)) axis_sense = sense + + if (axis_sense /= 0) then + select case (axis_sense) + case (1) + sense_attr = 'up' + case (-1) + sense_attr = 'down' + case default + call MOM_error(FATAL, 'register_netcdf_axis: sense must be either ' & + // '0, 1, or -1.') + end select + rc = nf90_put_att(handle%ncid, axis%varid, 'positive', sense_attr) + call check_netcdf_call(rc, 'register_netcdf_axis', & + 'Attribute "positive" of variable "' // label // '" in file "' & + // handle%filename // '"') + endif +end function register_netcdf_axis + + +!> Write a 4D array to a compatible netCDF field +subroutine write_netcdf_field_4d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:,:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(5) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:4) = 1 + start(5) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_4d + + +!> Write a 3D array to a compatible netCDF field +subroutine write_netcdf_field_3d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(4) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:3) = 1 + start(4) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_3d + + +!> Write a 2D array to a compatible netCDF field +subroutine write_netcdf_field_2d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:,:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(3) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(:2) = 1 + start(3) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_2d + + +!> Write a 1D array to a compatible netCDF field +subroutine write_netcdf_field_1d(handle, field, values, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: values(:) + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(2) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(1) = 1 + start(2) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, values, start) + else + rc = nf90_put_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_1d + + +!> Write a scalar to a compatible netCDF field +subroutine write_netcdf_field_0d(handle, field, scalar, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_field), intent(in) :: field + !< Field metadata + real, intent(in) :: scalar + !< Field values + real, intent(in), optional :: time + !< Timestep index to write data + + integer :: rc + ! netCDF return code + integer :: start(1) + ! Start indices, if timestep is included + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + if (present(time)) then + call update_netcdf_timestep(handle, time) + start(1) = handle%time_level + rc = nf90_put_var(handle%ncid, field%varid, scalar, start) + else + rc = nf90_put_var(handle%ncid, field%varid, scalar) + endif + call check_netcdf_call(rc, 'write_netcdf_file', & + 'File "' // handle%filename // '", Field "' // field%label // '"') +end subroutine write_netcdf_field_0d + + +!> Write axis points to associated netCDF variable +subroutine write_netcdf_axis(handle, axis) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + type(netcdf_axis), intent(in) :: axis + !< field variable + + integer :: rc + ! netCDF return code + + ! Verify write mode + if (handle%define_mode) & + call enable_netcdf_write(handle) + + rc = nf90_put_var(handle%ncid, axis%varid, axis%points) + call check_netcdf_call(rc, 'write_netcdf_axis', & + 'File "' // handle%filename // '", Axis "' // axis%label // '"') +end subroutine write_netcdf_axis + + +!> Write a global attribute to a netCDF file +subroutine write_netcdf_attribute(handle, label, attribute) + type(netcdf_file_type), intent(in) :: handle + !< netCDF file handle + character(len=*), intent(in) :: label + !< File attribute + character(len=*), intent(in) :: attribute + !< File attribute value + + integer :: rc + ! netCDF return code + + rc = nf90_put_att(handle%ncid, NF90_GLOBAL, label, attribute) + call check_netcdf_call(rc, 'write_netcdf_attribute', & + 'File "' // handle%filename // '", Attribute "' // label // '"') +end subroutine write_netcdf_attribute + + +! This is a thin interface to nf90_inquire, designed to mirror the existing +! I/O API. A more axis-aware system might not need this, but for now it's here +!> Get the number of dimensions, variables, and timesteps in a netCDF file +subroutine get_netcdf_size(handle, ndims, nvars, nsteps) + type(netcdf_file_type), intent(in) :: handle + !< netCDF input file + integer, intent(out), optional :: ndims + !< number of dimensions in the file + integer, intent(out), optional :: nvars + !< number of variables in the file + integer, intent(out), optional :: nsteps + !< number of values in the file's unlimited axis + + integer :: rc + ! netCDF return code + integer :: unlimited_dimid + ! netCDF dimension ID for unlimited time axis + + rc = nf90_inquire(handle%ncid, & + nDimensions=ndims, & + nVariables=nvars, & + unlimitedDimId=unlimited_dimid & + ) + call check_netcdf_call(rc, 'get_netcdf_size', & + 'File "' // handle%filename // '"') + + rc = nf90_inquire_dimension(handle%ncid, unlimited_dimid, len=nsteps) + call check_netcdf_call(rc, 'get_netcdf_size', & + 'File "' // handle%filename // '"') +end subroutine get_netcdf_size + + +!> Get the metadata of the registered fields in a netCDF file +subroutine get_netcdf_fields(handle, axes, fields) + type(netcdf_file_type), intent(inout) :: handle + type(netcdf_axis), intent(inout), allocatable :: axes(:) + type(netcdf_field), intent(inout), allocatable :: fields(:) + + integer :: ndims + ! Number of netCDF dimensions + integer :: nvars + ! Number of netCDF dimensions + integer :: nfields + ! Number of fields in the file (i.e. non-axis variables) + integer, allocatable :: dimids(:) + ! netCDF dimension IDs of file + integer, allocatable :: varids(:) + ! netCDF variable IDs of file + integer :: unlim_dimid + ! netCDF dimension ID for the unlimited axis variable, if present + integer :: unlim_index + ! Index of the unlimited axis in axes(:), if present + character(len=NF90_MAX_NAME) :: label + ! Current dimension or variable label + integer :: len + ! Current dimension length + integer :: rc + ! netCDF return code + integer :: grp_ndims, grp_nvars + ! Group-based counts for nf90_inq_* (unused) + logical :: is_axis + ! True if the current variable is an axis + integer :: i, j, n + + integer, save :: no_parent_groups = 0 + ! Flag indicating exclusion of parent groups in netCDF file + ! NOTE: This must be passed as a variable, and cannot be declared as a + ! parameter. + + rc = nf90_inquire(handle%ncid, & + nDimensions=ndims, & + nVariables=nvars, & + unlimitedDimId=unlim_dimid & + ) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(dimids(ndims)) + rc = nf90_inq_dimids(handle%ncid, grp_ndims, dimids, no_parent_groups) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(varids(nvars)) + rc = nf90_inq_varids(handle%ncid, grp_nvars, varids) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + allocate(axes(ndims)) + do i = 1, ndims + rc = nf90_inquire_dimension(handle%ncid, dimids(i), name=label, len=len) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + ! Check for the unlimited axis + if (dimids(i) == unlim_dimid) unlim_index = i + + axes(i)%dimid = dimids(i) + axes(i)%label = trim(label) + allocate(axes(i)%points(len)) + enddo + + nfields = nvars - ndims + allocate(fields(nfields)) + + n = 0 + do i = 1, nvars + rc = nf90_inquire_variable(handle%ncid, varids(i), name=label) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + + ! Check if variable is an axis + is_axis = .false. + do j = 1, ndims + if (label == axes(j)%label) then + rc = nf90_get_var(handle%ncid, varids(i), axes(j)%points) + call check_netcdf_call(rc, 'get_netcdf_fields', & + 'File "' // handle%filename // '"') + axes(j)%varid = varids(i) + + if (j == unlim_index) then + handle%time_id = varids(i) + handle%time_level = size(axes(j)%points) + handle%time = NULLTIME + endif + + is_axis = .true. + exit + endif + enddo + if (is_axis) cycle + + n = n + 1 + fields(n)%label = trim(label) + fields(n)%varid = varids(i) + enddo +end subroutine get_netcdf_fields + + +subroutine update_netcdf_timestep(handle, time) + type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle + real, intent(in) :: time + !< New model time + + integer :: start(1) + !< Time axis start index array + integer :: rc + !< netCDF return code + + if (time > handle%time + epsilon(time)) then + handle%time = time + handle%time_level = handle%time_level + 1 + + ! Write new value to time axis + start = [handle%time_level] + rc = nf90_put_var(handle%ncid, handle%time_id, time, start=start) + call check_netcdf_call(rc, 'update_netcdf_timestep', & + 'File "' // handle%filename // '"') + endif +end subroutine update_netcdf_timestep + + +!> Check netCDF function return codes, report the error log, and abort the run. +subroutine check_netcdf_call(ncerr, header, message) + integer, intent(in) :: ncerr + !< netCDF error code + character(len=*), intent(in) :: header + !< Message header (usually calling subroutine) + character(len=*), intent(in) :: message + !< Error message (usually action which instigated the error) + + character(len=:), allocatable :: errmsg + ! Full error message, including netCDF message + + if (ncerr /= nf90_noerr) then + errmsg = trim(header) // ": " // trim(message) // new_line('/') & + // trim(nf90_strerror(ncerr)) + call MOM_error(FATAL, errmsg) + endif +end subroutine check_netcdf_call + +end module MOM_netcdf diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index a76e96499f..2939a7d907 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -8,9 +8,9 @@ module MOM_restart use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : create_file, file_type, fieldtype, file_exists, open_file, close_file -use MOM_io, only : MOM_read_data, read_data, MOM_write_field, read_field_chksum, field_exists -use MOM_io, only : get_file_info, get_file_fields, get_field_atts, get_file_times +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_file, MOM_field +use MOM_io, only : MOM_read_data, read_data, MOM_write_field, field_exists use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE @@ -1258,7 +1258,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ ! Local variables type(vardesc) :: vars(CS%max_fields) ! Descriptions of the fields that ! are to be read from the restart file. - type(fieldtype) :: fields(CS%max_fields) ! Opaque types containing metadata describing + type(MOM_field) :: fields(CS%max_fields) ! Opaque types containing metadata describing ! each variable that will be written. character(len=512) :: restartpath ! The restart file path (dir/file). character(len=256) :: restartname ! The restart file name (no dir). @@ -1272,7 +1272,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ ! versions of NetCDF, the value was 2147483647_8. integer :: start_var, next_var ! The starting variables of the ! current and next files. - type(file_type) :: IO_handle ! The I/O handle of the open fileset + type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset integer :: m, nz integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute @@ -1408,11 +1408,11 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ enddo if (CS%parallel_restartfiles) then - call create_file(IO_handle, trim(restartpath), vars, (next_var-start_var), & - fields, MULTIPLE, G=G, GV=GV, checksums=check_val) + call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & + fields, MULTIPLE, G=G, GV=GV, checksums=check_val) else - call create_file(IO_handle, trim(restartpath), vars, (next_var-start_var), & - fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val) + call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & + fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val) endif do m=start_var,next_var-1 @@ -1434,7 +1434,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ endif enddo - call close_file(IO_handle) + call IO_handle%close() num_files = num_files+1 @@ -1466,14 +1466,14 @@ subroutine restore_state(filename, directory, day, G, CS) integer :: isL, ieL, jsL, jeL integer :: nvar, ntime, pos - type(file_type) :: IO_handles(CS%max_fields) ! The I/O units of all open files. + type(MOM_infra_file) :: IO_handles(CS%max_fields) ! The I/O units of all open files. character(len=200) :: unit_path(CS%max_fields) ! The file names. logical :: unit_is_global(CS%max_fields) ! True if the file is global. character(len=8) :: hor_grid ! Variable grid info. real :: t1, t2 ! Two times. real, allocatable :: time_vals(:) - type(fieldtype), allocatable :: fields(:) + type(MOM_field), allocatable :: fields(:) logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. integer(kind=8) :: checksum_data ! The checksum value for the data that was read in. @@ -1500,7 +1500,7 @@ subroutine restore_state(filename, directory, day, G, CS) ! Get the time from the first file in the list that has one. do n=1,num_file - call get_file_times(IO_handles(n), time_vals, ntime) + call IO_handles(n)%get_file_times(time_vals, ntime) if (ntime < 1) cycle t1 = time_vals(1) @@ -1516,7 +1516,7 @@ subroutine restore_state(filename, directory, day, G, CS) ! Check the remaining files for different times and issue a warning ! if they differ from the first time. do m = n+1,num_file - call get_file_times(IO_handles(n), time_vals, ntime) + call IO_handles(n)%get_file_times(time_vals, ntime) if (ntime < 1) cycle t2 = time_vals(1) @@ -1532,13 +1532,13 @@ subroutine restore_state(filename, directory, day, G, CS) ! Read each variable from the first file in which it is found. do n=1,num_file - call get_file_info(IO_handles(n), nvar=nvar) + call IO_handles(n)%get_file_info(nvar=nvar) allocate(fields(nvar)) - call get_file_fields(IO_handles(n), fields(1:nvar)) + call IO_handles(n)%get_file_fields(fields(1:nvar)) do m=1, nvar - call get_field_atts(fields(m), name=varname) + call IO_handles(n)%get_field_atts(fields(m), name=varname) do i=1,CS%num_obsolete_vars if (adjustl(lowercase(trim(varname))) == adjustl(lowercase(trim(CS%restart_obsolete(i)%field_name)))) then call MOM_error(FATAL, "MOM_restart restore_state: Attempting to use obsolete restart field "//& @@ -1571,11 +1571,11 @@ subroutine restore_state(filename, directory, day, G, CS) call get_checksum_loop_ranges(G, pos, isL, ieL, jsL, jeL) do i=1, nvar - call get_field_atts(fields(i), name=varname) + call IO_handles(n)%get_field_atts(fields(i), name=varname) if (lowercase(trim(varname)) == lowercase(trim(CS%restart_field(m)%var_name))) then checksum_data = -1 if (CS%checksum_required) then - call read_field_chksum(fields(i), checksum_file, is_there_a_checksum) + call IO_handles(n)%read_field_chksum(fields(i), checksum_file, is_there_a_checksum) else checksum_file = -1 is_there_a_checksum = .false. ! Do not need to do data checksumming. @@ -1643,7 +1643,7 @@ subroutine restore_state(filename, directory, day, G, CS) enddo do n=1,num_file - call close_file(IO_handles(n)) + call IO_handles(n)%close() enddo ! Check whether any mandatory fields have not been found. @@ -1745,7 +1745,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct - type(file_type), dimension(:), & + type(MOM_infra_file), dimension(:), & optional, intent(out) :: IO_handles !< The I/O handles of all opened files character(len=*), dimension(:), & optional, intent(out) :: file_paths !< The full paths to open files @@ -1822,7 +1822,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (fexists) then nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath @@ -1832,7 +1832,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (fexists) then nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, MOM_domain=G%Domain) + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, MOM_domain=G%Domain) if (present(global_files)) global_files(nf) = .false. if (present(file_paths)) file_paths(nf) = filepath endif @@ -1854,7 +1854,7 @@ function open_restart_units(filename, directory, G, CS, IO_handles, file_paths, if (fexists) then nf = nf + 1 if (present(IO_handles)) & - call open_file(IO_handles(nf), trim(filepath), READONLY_FILE, & + call IO_handles(nf)%open(trim(filepath), READONLY_FILE, & threading=MULTIPLE, fileset=SINGLE_FILE) if (present(global_files)) global_files(nf) = .true. if (present(file_paths)) file_paths(nf) = filepath diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index aaa53dee59..a78c17803c 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -33,7 +33,7 @@ module MOM_ice_shelf use user_initialization, only : user_initialize_topography use MOM_io, only : field_exists, file_exists, MOM_read_data, write_version_number use MOM_io, only : slasher, fieldtype, vardesc, var_desc -use MOM_io, only : write_field, close_file, SINGLE_FILE, MULTIPLE +use MOM_io, only : close_file, SINGLE_FILE, MULTIPLE use MOM_restart, only : register_restart_field, save_restart use MOM_restart, only : restart_init, restore_state, MOM_restart_CS, register_restart_pair use MOM_time_manager, only : time_type, time_type_to_real, real_to_time, operator(>), operator(-) diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index c956c6b4be..78f739c461 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -8,7 +8,8 @@ module MOM_coord_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe 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 : close_file, create_file, file_type, fieldtype, file_exists +use MOM_io, only : create_MOM_file, file_exists +use MOM_io, only : MOM_infra_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 @@ -526,20 +527,21 @@ subroutine write_vertgrid_file(GV, US, param_file, directory) ! Local variables character(len=240) :: filepath type(vardesc) :: vars(2) - type(fieldtype) :: fields(2) - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_field) :: fields(2) + type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset filepath = trim(directory) // trim("Vertical_coordinate") 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') - call create_file(IO_handle, trim(filepath), vars, 2, fields, SINGLE_FILE, GV=GV) + call create_MOM_file(IO_handle, trim(filepath), vars, 2, fields, & + SINGLE_FILE, GV=GV) call MOM_write_field(IO_handle, fields(1), GV%Rlay, scale=US%R_to_kg_m3) call MOM_write_field(IO_handle, fields(2), GV%g_prime, scale=US%L_T_to_m_s**2*US%m_to_Z) - call close_file(IO_handle) + call IO_handle%close() end subroutine write_vertgrid_file diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index acffc9c927..2981bb9e94 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -11,7 +11,8 @@ module MOM_shared_initialization use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_param, param_file_type, log_version -use MOM_io, only : close_file, create_file, file_type, fieldtype, file_exists, field_size +use MOM_io, only : create_MOM_file, file_exists, field_size +use MOM_io, only : MOM_infra_file, MOM_field use MOM_io, only : MOM_read_data, MOM_read_vector, read_variable, stdout use MOM_io, only : open_file_to_read, close_file_to_read, SINGLE_FILE, MULTIPLE use MOM_io, only : slasher, vardesc, MOM_write_field, var_desc @@ -1346,9 +1347,9 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) character(len=40) :: mdl = "write_ocean_geometry_file" type(vardesc), dimension(:), allocatable :: & vars ! Types with metadata about the variables and their staggering - type(fieldtype), dimension(:), allocatable :: & + type(MOM_field), dimension(:), allocatable :: & fields ! Opaque types used by MOM_io to store variable metadata information - type(file_type) :: IO_handle ! The I/O handle of the fileset + type(MOM_infra_file) :: IO_handle ! The I/O handle of the fileset integer :: nFlds ! The number of variables in this file integer :: file_threading logical :: multiple_files @@ -1412,7 +1413,8 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) file_threading = SINGLE_FILE if (multiple_files) file_threading = MULTIPLE - call create_file(IO_handle, trim(filepath), vars, nFlds, fields, file_threading, dG=G) + call create_MOM_file(IO_handle, trim(filepath), vars, nFlds, fields, & + file_threading, dG=G) call MOM_write_field(IO_handle, fields(1), G%Domain, G%geoLatBu) call MOM_write_field(IO_handle, fields(2), G%Domain, G%geoLonBu) @@ -1445,7 +1447,7 @@ subroutine write_ocean_geometry_file(G, param_file, directory, US, geom_file) call MOM_write_field(IO_handle, fields(23), G%Domain, G%Dopen_v, scale=US%Z_to_m) endif - call close_file(IO_handle) + call IO_handle%close() deallocate(vars, fields) From b7e5b338ad429f904a27dcbe0cc20d307e79e57a Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 13 Jan 2023 10:16:44 -0500 Subject: [PATCH 166/629] pipeline: compile preproc executables on login nodes In order to adapt pipelines to work from a read-only NFS space we need the pre-processing step for tc4 to be [optionally] broken into two steps: a compile step and a data generation step. Changes: - Added the target "executables to tc4/Makefile, so only compilation occurs when invoked. The "all" target still compiles if needed. - Added target "preproc-compile" to .testing/Makefile whcih invokes the "executables" target of tc4/Makefile. The target "preproc" still compiles if needed. - Added `make-preproc-compile` to the gitlab pipeline prior to submitting the "make test" job to the compute nodes. - I also disconnected the "clean.stats" target from "clean.preproc" since the latter removes the pre-processing executables too and given that we can't re-compile those and re-create the stats from the same location it makes sense to keep those clean steps separated. --- .gitlab-ci.yml | 2 ++ .testing/Makefile | 4 +++- .testing/tc4/Makefile.in | 1 + 3 files changed, 6 insertions(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index fbc2854b33..6291d2bd84 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -182,6 +182,7 @@ actions:gnu: - 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 - make -s -j + - make preproc-compile -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" 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 ) @@ -201,6 +202,7 @@ actions:intel: - 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 - make -s -j + - make preproc-compile -s -j - echo -e "\e[0Ksection_end:`date +%s`:compile\r\e[0K" - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" 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 ) diff --git a/.testing/Makefile b/.testing/Makefile index 73a97229d4..0b9c57f675 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -523,6 +523,8 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) .PHONY: preproc preproc: tc4/Makefile cd tc4 && $(MAKE) LAUNCHER="$(MPIRUN)" +preproc-compile: tc4/Makefile + cd tc4 && $(MAKE) executables tc4/Makefile: tc4/configure tc4/Makefile.in cd $(@D) && ./configure || (cat config.log && false) @@ -795,7 +797,7 @@ clean.build: .PHONY: clean.stats -clean.stats: clean.preproc +clean.stats: @[ $$(basename $$(pwd)) = .testing ] rm -rf work results diff --git a/.testing/tc4/Makefile.in b/.testing/tc4/Makefile.in index 5a0e441482..714a8f19f1 100644 --- a/.testing/tc4/Makefile.in +++ b/.testing/tc4/Makefile.in @@ -16,6 +16,7 @@ OUT = ocean_hgrid.nc topog.nc temp_salt_ic.nc sponge.nc # Program output all: ocean_hgrid.nc temp_salt_ic.nc +executables: gen_data gen_grid ocean_hgrid.nc: gen_grid $(LAUNCHER) ./gen_grid From 86c39546fbbd3df4947b8faba26ca08d95653bd3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 13 Jan 2023 11:10:36 -0500 Subject: [PATCH 167/629] .testing: Add WORKSPACE cpp macro to control scratch space - Added CPP macro "WORKSPACE" which defaults to ".". This controls where the work/ and results/ directories are located as used by the target "test" in .testing/Makefile. - Use WORKSPACE=/lustre/f2/scratch/$USER/runner/$CI_RUNNER_ID in the job script so that if the runner is later moved to a read-only-from-compute disk the pipeline still works. --- .gitlab-ci.yml | 8 +-- .testing/Makefile | 124 ++++++++++++++++++++++++---------------------- 2 files changed, 69 insertions(+), 63 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6291d2bd84..3efce5170a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -182,9 +182,9 @@ actions:gnu: - 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 - make -s -j - - make preproc-compile -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" test -s -j') > job.sh + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" WORKSPACE=/lustre/f2/scratch/$USER/runner/$CI_RUNNER_ID 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 test.summary @@ -202,9 +202,9 @@ actions:intel: - 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 - make -s -j - - make preproc-compile -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" test -s -j') > job.sh + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" WORKSPACE=/lustre/f2/scratch/$USER/runner/$CI_RUNNER_ID 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 test.summary diff --git a/.testing/Makefile b/.testing/Makefile index 0b9c57f675..8a79d86e0a 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -57,6 +57,9 @@ # MOM_TARGET_LOCAL_BRANCH Target branch name # (NOTE: These would typically be configured by a CI.) # +# Paths for stages: +# WORKSPACE Location to place work/ and results/ directories (i.e. where to run the model) +# #---- # TODO: POSIX shell compatibility @@ -129,6 +132,8 @@ CONFIGS ?= $(wildcard tc*) TESTS ?= grid layout rotate restart openmp nan $(foreach d,$(DIMS),dim.$(d)) DIMS ?= t l h z q r +# Default is to place work/ and results/ in current directory +WORKSPACE ?= . #--- # Test configuration @@ -408,11 +413,11 @@ endef $(foreach d,$(DIMS),$(eval $(call TEST_DIM_RULE,$(d)))) .PHONY: run.symmetric run.asymmetric run.nans run.openmp run.cov -run.symmetric: $(foreach c,$(CONFIGS),work/$(c)/symmetric/ocean.stats) -run.asymmetric: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(CONFIGS),work/$(c)/asymmetric/ocean.stats) -run.nan: $(foreach c,$(CONFIGS),work/$(c)/nan/ocean.stats) -run.openmp: $(foreach c,$(CONFIGS),work/$(c)/openmp/ocean.stats) -run.cov: $(foreach c,$(CONFIGS),work/$(c)/cov/ocean.stats) +run.symmetric: $(foreach c,$(CONFIGS),$(WORKSPACE)/work/$(c)/symmetric/ocean.stats) +run.asymmetric: $(foreach c,$(filter-out tc3,$(CONFIGS)),$(CONFIGS),$(WORKSPACE)/work/$(c)/asymmetric/ocean.stats) +run.nan: $(foreach c,$(CONFIGS),$(WORKSPACE)/work/$(c)/nan/ocean.stats) +run.openmp: $(foreach c,$(CONFIGS),$(WORKSPACE)/work/$(c)/openmp/ocean.stats) +run.cov: $(foreach c,$(CONFIGS),$(WORKSPACE)/work/$(c)/cov/ocean.stats) # Configuration test rules # $(1): Configuration name (tc1, tc2, &c.) @@ -444,21 +449,21 @@ FAIL = ${RED}FAIL${RESET} # $(2): Test type (grid, layout, &c.) # $(3): Comparison targets (symmetric asymmetric, symmetric layout, &c.) define CMP_RULE -.PRECIOUS: $(foreach b,$(3),work/$(1)/$(b)/ocean.stats) -$(1).$(2): $(foreach b,$(3),work/$(1)/$(b)/ocean.stats) - @test "$$(shell ls -A results/$(1) 2>/dev/null)" || rm -rf results/$(1) +.PRECIOUS: $(foreach b,$(3),$(WORKSPACE)/work/$(1)/$(b)/ocean.stats) +$(1).$(2): $(foreach b,$(3),$(WORKSPACE)/work/$(1)/$(b)/ocean.stats) + @test "$$(shell ls -A $(WORKSPACE)/results/$(1) 2>/dev/null)" || rm -rf $(WORKSPACE)/results/$(1) @cmp $$^ || !( \ - mkdir -p results/$(1); \ - (diff $$^ | tee results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ + mkdir -p $(WORKSPACE)/results/$(1); \ + (diff $$^ | tee $(WORKSPACE)/results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $(1).$(2) have changed." \ ) @echo -e "$(PASS): Solutions $(1).$(2) agree." -.PRECIOUS: $(foreach b,$(3),work/$(1)/$(b)/chksum_diag) -$(1).$(2).diag: $(foreach b,$(3),work/$(1)/$(b)/chksum_diag) +.PRECIOUS: $(foreach b,$(3),$(WORKSPACE)/work/$(1)/$(b)/chksum_diag) +$(1).$(2).diag: $(foreach b,$(3),$(WORKSPACE)/work/$(1)/$(b)/chksum_diag) @cmp $$^ || !( \ - mkdir -p results/$(1); \ - (diff $$^ | tee results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ + mkdir -p $(WORKSPACE)/results/$(1); \ + (diff $$^ | tee $(WORKSPACE)/results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ echo -e "$(FAIL): Diagnostics $(1).$(2).diag have changed." \ ) @echo -e "$(PASS): Diagnostics $(1).$(2).diag agree." @@ -478,14 +483,15 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # Custom comparison rules + # Restart tests only compare the final stat record -.PRECIOUS: $(foreach b,symmetric restart target,work/%/$(b)/ocean.stats) -%.restart: $(foreach b,symmetric restart,work/%/$(b)/ocean.stats) - @test "$(shell ls -A results/$* 2>/dev/null)" || rm -rf results/$* +.PRECIOUS: $(foreach b,symmetric restart target,$(WORKSPACE)/work/%/$(b)/ocean.stats) +%.restart: $(foreach b,symmetric restart,$(WORKSPACE)/work/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORKSPACE)/results/$* 2>/dev/null)" || rm -rf $(WORKSPACE)/results/$* @cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ || !( \ - mkdir -p results/$*; \ - (diff $^ | tee results/$*/chksum_diag.restart.diff | head -n 20) ; \ + mkdir -p $(WORKSPACE)/results/$*; \ + (diff $^ | tee $(WORKSPACE)/results/$*/chksum_diag.restart.diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $*.restart have changed." \ ) @echo -e "$(PASS): Solutions $*.restart agree." @@ -493,21 +499,21 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # TODO: chksum_diag parsing of restart files # stats rule is unchanged, but we cannot use CMP_RULE to generate it. -%.regression: $(foreach b,symmetric target,work/%/$(b)/ocean.stats) - @test "$(shell ls -A results/$* 2>/dev/null)" || rm -rf results/$* +%.regression: $(foreach b,symmetric target,$(WORKSPACE)/work/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORKSPACE)/results/$* 2>/dev/null)" || rm -rf $(WORKSPACE)/results/$* @cmp $^ || !( \ - mkdir -p results/$*; \ - (diff $^ | tee results/$*/ocean.stats.regression.diff | head -n 20) ; \ + mkdir -p $(WORKSPACE)/results/$*; \ + (diff $^ | tee $(WORKSPACE)/results/$*/ocean.stats.regression.diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $*.regression have changed." \ ) @echo -e "$(PASS): Solutions $*.regression agree." # Regression testing only checks for changes in existing diagnostics -%.regression.diag: $(foreach b,symmetric target,work/%/$(b)/chksum_diag) +%.regression.diag: $(foreach b,symmetric target,$(WORKSPACE)/work/%/$(b)/chksum_diag) @! diff $^ | grep "^[<>]" | grep "^>" > /dev/null \ || ! (\ - mkdir -p results/$*; \ - (diff $^ | tee results/$*/chksum_diag.regression.diff | head -n 20) ; \ + mkdir -p $(WORKSPACE)/results/$*; \ + (diff $^ | tee $(WORKSPACE)/results/$*/chksum_diag.regression.diff | head -n 20) ; \ echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ ) @cmp $^ || ( \ @@ -536,7 +542,7 @@ tc4/configure: tc4/configure.ac #--- # Test run output files -# Rule to build work//{ocean.stats,chksum_diag}. +# Rule to build $(WORKSPACE)/work//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type # $(3): Enable coverage flag @@ -545,15 +551,15 @@ tc4/configure: tc4/configure.ac # $(6): Number of MPI ranks define STAT_RULE -work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 | preproc +$(WORKSPACE)/work/%/$(1)/ocean.stats $(WORKSPACE)/work/%/$(1)/chksum_diag: build/$(2)/MOM6 | preproc @echo "Running test $$*.$(1)..." mkdir -p $$(@D) cp -RL $$*/* $$(@D) mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override - rm -f results/$$*/std.$(1).{out,err} + rm -f $(WORKSPACE)/results/$$*/std.$(1).{out,err} cd $$(@D) \ - && $(TIME) $(5) $(MPIRUN) -n $(6) ../../../$$< 2> std.err > std.out \ + && $(TIME) $(5) $(MPIRUN) -n $(6) $(abspath $$<) 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 20 ; \ @@ -563,7 +569,7 @@ work/%/$(1)/ocean.stats work/%/$(1)/chksum_diag: build/$(2)/MOM6 | preproc ) @echo -e "$(DONE): $$*.$(1); no runtime errors." if [ $(3) ]; then \ - mkdir -p results/$$* ; \ + mkdir -p $(WORKSPACE)/results/$$* ; \ cd build/$(2) ; \ gcov -b *.gcda > gcov.$$*.$(1).out ; \ find -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; ; \ @@ -614,7 +620,7 @@ $(eval $(call STAT_RULE,cov,cov,true,,,1)) # 2. Convert DAYMAX from TIMEUNIT to seconds # 3. Apply seconds to `ocean_solo_nml` inside input.nml. # NOTE: Assumes that runtime set by DAYMAX, will fail if set by input.nml -work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc +$(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc rm -rf $(@D) mkdir -p $(@D) cp -RL $*/* $(@D) @@ -628,9 +634,9 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc && halfperiod=$$(awk -v t=$${daymax} -v dt=$${timeunit} 'BEGIN {printf "%.f", 0.5*t*dt}') \ && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Remove any previous archived output - rm -f results/$*/std.restart{1,2}.{out,err} + rm -f $(WORKSPACE)/results/$*/std.restart{1,2}.{out,err} # Run the first half-period - cd $(@D) && $(TIME) $(MPIRUN) -n 1 ../../../$< 2> std1.err > std1.out \ + cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ || !( \ cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 20 ; \ cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 20 ; \ @@ -641,7 +647,7 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc mkdir $(@D)/RESTART cd $(@D) && sed -i -e "s/input_filename *= *'n'/input_filename = 'r'/g" input.nml # Run the second half-period - cd $(@D) && $(TIME) $(MPIRUN) -n 1 ../../../$< 2> std2.err > std2.out \ + cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std2.err > std2.out \ || !( \ cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 20 ; \ cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 20 ; \ @@ -654,20 +660,20 @@ work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @if ls results/*/* &> /dev/null; then \ - if ls results/*/std.*.err &> /dev/null; then \ + @if ls $(WORKSPACE)/results/*/* &> /dev/null; then \ + if ls $(WORKSPACE)/results/*/std.*.err &> /dev/null; then \ echo "The following tests failed to complete:" ; \ - ls results/*/std.*.out \ + ls $(WORKSPACE)/results/*/std.*.out \ | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ fi; \ - if ls results/*/ocean.stats.*.diff &> /dev/null; then \ + if ls $(WORKSPACE)/results/*/ocean.stats.*.diff &> /dev/null; then \ echo "The following tests report solution regressions:" ; \ - ls results/*/ocean.stats.*.diff \ + ls $(WORKSPACE)/results/*/ocean.stats.*.diff \ | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[3]; if(length(t)>4) v=v"."t[4]; print a[2],":",v}'; \ fi; \ - if ls results/*/chksum_diag.*.diff &> /dev/null; then \ + if ls $(WORKSPACE)/results/*/chksum_diag.*.diff &> /dev/null; then \ echo "The following tests report diagnostic regressions:" ; \ - ls results/*/chksum_diag.*.diff \ + ls $(WORKSPACE)/results/*/chksum_diag.*.diff \ | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ fi; \ false ; \ @@ -683,28 +689,28 @@ test.summary: .PHONY: run.cov.unit run.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov -work/unit/std.out: build/unit/MOM_unit_tests +$(WORKSPACE)/work/unit/std.out: build/unit/MOM_unit_tests if [ $(REPORT_COVERAGE) ]; then \ find build/unit -name *.gcda -exec rm -f '{}' \; ; \ fi rm -rf $(@D) mkdir -p $(@D) cd $(@D) \ - && $(TIME) $(MPIRUN) -n 1 ../../$< 2> std.err > std.out \ + && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out \ || !( \ cat std.out | tail -n 100 ; \ cat std.err | tail -n 100 ; \ ) cd $(@D) \ - && $(TIME) $(MPIRUN) -n 2 ../../$< 2> p2.std.err > p2.std.out \ + && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.std.err > p2.std.out \ || !( \ cat p2.std.out | tail -n 100 ; \ cat p2.std.err | tail -n 100 ; \ ) # NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out -# TODO: Replace work/unit/std.out with *.gcda? -build/unit/MOM_file_parser_tests.F90.gcov: work/unit/std.out +# TODO: Replace $(WORKSPACE)/work/unit/std.out with *.gcda? +build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/std.out cd $(@D) \ && gcov -b *.gcda > gcov.unit.out find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; @@ -731,22 +737,22 @@ PCONFIGS = p0 profile: $(foreach p,$(PCONFIGS), prof.$(p)) .PHONY: prof.p0 -prof.p0: work/p0/opt/clocks.json work/p0/opt_target/clocks.json +prof.p0: $(WORKSPACE)/work/p0/opt/clocks.json $(WORKSPACE)/work/p0/opt_target/clocks.json python tools/compare_clocks.py $^ -work/p0/%/clocks.json: work/p0/%/std.out +$(WORKSPACE)/work/p0/%/clocks.json: $(WORKSPACE)/work/p0/%/std.out python tools/parse_fms_clocks.py -d $(@D) $^ > $@ -work/p0/opt/std.out: build/opt/MOM6 -work/p0/opt_target/std.out: build/opt_target/MOM6 +$(WORKSPACE)/work/p0/opt/std.out: build/opt/MOM6 +$(WORKSPACE)/work/p0/opt_target/std.out: build/opt_target/MOM6 -work/p0/%/std.out: +$(WORKSPACE)/work/p0/%/std.out: mkdir -p $(@D) cp -RL p0/* $(@D) mkdir -p $(@D)/RESTART echo -e "" > $(@D)/MOM_override cd $(@D) \ - && $(MPIRUN) -n 1 ../../../$< 2> std.err > std.out + && $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out #--- @@ -759,16 +765,16 @@ PERF_EVENTS ?= perf: $(foreach p,$(PCONFIGS), perf.$(p)) .PHONY: prof.p0 -perf.p0: work/p0/opt/profile.json work/p0/opt_target/profile.json +perf.p0: $(WORKSPACE)/work/p0/opt/profile.json $(WORKSPACE)/work/p0/opt_target/profile.json python tools/compare_perf.py $^ -work/p0/%/profile.json: work/p0/%/perf.data +$(WORKSPACE)/work/p0/%/profile.json: $(WORKSPACE)/work/p0/%/perf.data python tools/parse_perf.py -f $< > $@ -work/p0/opt/perf.data: build/opt/MOM6 -work/p0/opt_target/perf.data: build/opt_target/MOM6 +$(WORKSPACE)/work/p0/opt/perf.data: build/opt/MOM6 +$(WORKSPACE)/work/p0/opt_target/perf.data: build/opt_target/MOM6 -work/p0/%/perf.data: +$(WORKSPACE)/work/p0/%/perf.data: mkdir -p $(@D) cp -RL p0/* $(@D) mkdir -p $(@D)/RESTART @@ -799,7 +805,7 @@ clean.build: .PHONY: clean.stats clean.stats: @[ $$(basename $$(pwd)) = .testing ] - rm -rf work results + rm -rf $(WORKSPACE)/work $(WORKSPACE)/results .PHONY: clean.preproc From 1fe52f70e0a8b43b7447d1a25af7320d343ed51b Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 13 Jan 2023 12:08:00 -0500 Subject: [PATCH 168/629] pipeline: Show list of PASSes Purely asesthetic Purely aesthetic change, but on success, it's nice to see the long list of green checks. Previously we only showed any detail on a fail and on success show the one line summary. --- .gitlab-ci.yml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 3efce5170a..0462e3aa7a 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,6 +10,7 @@ stages: # We use the "fetch" strategy to speed up the startup of stages variables: JOB_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" + WORKSPACE: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/$CI_RUNNER_ID" GIT_STRATEGY: fetch # Always eport value of $JOB_DIR @@ -184,9 +185,9 @@ actions:gnu: - 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=/lustre/f2/scratch/$USER/runner/$CI_RUNNER_ID 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 test.summary + - (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 + - make WORKSPACE=$WORKSPACE test.summary actions:intel: stage: tests @@ -204,9 +205,9 @@ actions:intel: - 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=/lustre/f2/scratch/$USER/runner/$CI_RUNNER_ID 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 test.summary + - (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 + - make WORKSPACE=$WORKSPACE test.summary # Tests # From b22617c1673770e47e2f03405cd2541476eec356 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Jan 2023 06:35:30 -0500 Subject: [PATCH 169/629] +(*)Use reproducing sums to homogenize fields Added the ability to use reproducing sums to create spatially homogenized tracer fields when Z_INIT_HOMOGENIZE = True, for rotational symmetry and consistency across layouts. The previous version had used non-reproducing sums. This new code is used when HOR_REGRID_ANSWER_DATE >= 20230101, and the comments describing HOR_REGRID_ANSWER_DATE have been updated to reflect this. As a part of this change, the new publicly visible routine homogenize_field was added to the MOM_horizontal_regridding module, so that the homogenization occurs in a single part of the code rather than being spread across several files. By default this commit could lead to answer changes in some cases, depending whether and how HOR_REGRID_ANSWER_DATE is set, but it turns out that the existing single_column test cases that use this have only 4 points and happen to give the same answers with either the older or newer version of the code. This commit addresses MOM6 issue #296 (github.com/NOAA-GFDL/MOM6/issues/296), which can be closed as soon as this commit is merged in to the dev/gfdl branch of MOM6. --- src/framework/MOM_horizontal_regridding.F90 | 112 +++++++++++++----- .../MOM_state_initialization.F90 | 28 +---- .../MOM_tracer_initialization_from_Z.F90 | 1 + .../vertical/MOM_ALE_sponge.F90 | 2 + 4 files changed, 91 insertions(+), 52 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 7a0ace9279..c2fe772571 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -5,6 +5,7 @@ module MOM_horizontal_regridding use MOM_debugging, only : hchksum use MOM_coms, only : max_across_PEs, min_across_PEs, sum_across_PEs, broadcast +use MOM_coms, only : reproducing_sum use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_LOOP use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, is_root_pe @@ -24,7 +25,7 @@ module MOM_horizontal_regridding #include -public :: horiz_interp_and_extrap_tracer, myStats +public :: horiz_interp_and_extrap_tracer, myStats, homogenize_field !> Extrapolate and interpolate data interface horiz_interp_and_extrap_tracer @@ -321,7 +322,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr logical :: found_attr logical :: add_np logical :: is_ongrid - character(len=8) :: laynum type(horiz_interp_type) :: Interp type(axis_info), dimension(4) :: axes_info ! Axis information used for regridding integer :: is, ie, js, je ! compute domain indices @@ -332,8 +332,6 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr real :: I_scale ! The inverse of the scale factor for diagnostic output [conc CU-1 ~> 1] real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing ! iterations that determines when to stop iterating [CU ~> conc] - real :: npoints ! The number of points in an average [nondim] - real :: varAvg ! The sum of tracer variables being averaged, then their average [CU ~> conc] real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] @@ -461,13 +459,12 @@ 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. do k=1,kd - write(laynum,'(I8)') k ; laynum = adjustl(laynum) 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 + 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) do j=js,je do i=is,ie @@ -487,6 +484,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr start(:) = 1 ; start(3) = k count(:) = 1 ; count(1) = id ; count(2) = jd call read_variable(trim(filename), trim(varnam), tr_in, start=start, nread=count) + if (is_root_pe()) then if (add_np) then pole = 0.0 ; npole = 0.0 @@ -539,14 +537,11 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr fill(:,:) = 0.0 ; good(:,:) = 0.0 - nPoints = 0 ; varAvg = 0. do j=js,je ; do i=is,ie if (mask_out(i,j) < 1.0) then tr_out(i,j) = missing_value else good(i,j) = 1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) endif if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & (mask_out(i,j) < 1.0)) & @@ -561,13 +556,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then - !### These averages will not reproduce across PE layouts or grid rotation. - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg / real(nPoints) - endif - tr_out(:,:) = varAvg + call homogenize_field(tr_out, mask_out, G, scale, answer_date) endif ; endif ! tr_out contains input z-space data on the model grid with missing values @@ -663,7 +652,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, real :: missing_val_in ! The missing value in the input field [conc] real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] logical :: add_np - character(len=8) :: laynum type(horiz_interp_type) :: Interp type(axistype), dimension(4) :: axes_data integer :: is, ie, js, je ! compute domain indices @@ -677,8 +665,6 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, real :: I_scale ! The inverse of the scale factor for diagnostic output [conc CU-1 ~> 1] real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing ! iterations that determines when to stop iterating [CU ~> conc] - real :: npoints ! The number of points in an average [nondim] - real :: varAvg ! The sum of tracer variables being averaged, then their average [CU ~> conc] real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] @@ -791,10 +777,10 @@ 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) + ! Loop through each data level and interpolate to model grid. ! After interpolating, fill in points which will be needed to define the layers. do k=1,kd - write(laynum,'(I8)') k ; laynum = adjustl(laynum) if (is_root_pe()) then tr_in(1:id,1:jd) = data_in(1:id,1:jd,k) if (add_np) then @@ -851,14 +837,11 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, fill(:,:) = 0.0 ; good(:,:) = 0.0 - nPoints = 0 ; varAvg = 0. do j=js,je ; do i=is,ie if (mask_out(i,j) < 1.0) then tr_out(i,j) = missing_value else good(i,j) = 1.0 - nPoints = nPoints + 1 - varAvg = varAvg + tr_out(i,j) endif if ((G%mask2dT(i,j) == 1.0) .and. (z_edges_in(k) <= G%bathyT(i,j) + G%Z_ref) .and. & (mask_out(i,j) < 1.0)) & @@ -873,13 +856,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, ! Horizontally homogenize data to produce perfectly "flat" initial conditions if (PRESENT(homogenize)) then ; if (homogenize) then - !### These averages will not reproduce across PE layouts or grid rotation. - call sum_across_PEs(nPoints) - call sum_across_PEs(varAvg) - if (nPoints>0) then - varAvg = varAvg / real(nPoints) - endif - tr_out(:,:) = varAvg + call homogenize_field(tr_out, mask_out, G, scale, answer_date) endif ; endif ! tr_out contains input z-space data on the model grid with missing values @@ -920,6 +897,81 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, end subroutine horiz_interp_and_extrap_tracer_fms_id +!> Replace all values of a 2-d field with the weighted average over the valid points. +subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid type + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field !< The tracer on the model grid [A ~> a] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: weight !< The weights for the tracer [B ~> b] + real, intent(in) :: scale !< A rescaling factor that has been used for the + !! variable and has to be undone before the + !! reproducing sums [A a-1 ~> 1] + integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. + !! Dates before 20230101 use non-reproducing sums + !! in their averages, while later versions use + !! reproducing sums for rotational symmetry and + !! consistency across PE layouts. + real, optional, intent(in) :: wt_unscale !< A factor that undoes any dimensional scaling + !! of the weights so that they can be used with + !! reproducing sums [b B-1 ~> 1] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: field_for_Sums ! The field times the weights with the scaling undone [a b] + real, dimension(SZI_(G),SZJ_(G)) :: wts_for_Sums ! A copy of the wieghts with the scaling undone [b] + real :: var_unscale ! The reciprocal of the scaling factor for the field and weights [a b A-1 B-1 ~> 1] + real :: wt_descale ! A factor that undoes any dimensional scaling of the weights so that they + ! can be used with reproducing sums [b B-1 ~> 1] + real :: wt_sum ! The sum of the weights, in [b] (reproducing) or [B ~> b] (non-reproducing) + real :: varsum ! The weighted sum of field being averaged [A B ~> a b] + real :: varAvg ! The average of the field [A ~> a] + logical :: use_repro_sums ! If true, use reproducing sums. + integer :: i, j, is, ie, js, je + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + varAvg = 0.0 ! This value will be used if wt_sum is 0. + + use_repro_sums = .false. ; if (present(answer_date)) use_repro_sums = (answer_date >= 20230101) + + if (scale == 0.0) then + ! This seems like an unlikely case to ever be used, but dealing with it is better than having NaNs arise? + varAvg = 0.0 + elseif (use_repro_sums) then + wt_descale = 1.0 ; if (present(wt_unscale)) wt_descale = wt_unscale + var_unscale = wt_descale / scale + + field_for_Sums(:,:) = 0.0 + wts_for_Sums(:,:) = 0.0 + do j=js,je ; do i=is,ie + wts_for_Sums(i,j) = wt_descale * weight(i,j) + field_for_Sums(i,j) = var_unscale * (field(i,j) * weight(i,j)) + enddo ; enddo + + wt_sum = reproducing_sum(wts_for_Sums) + if (abs(wt_sum) > 0.0) & + varAvg = reproducing_sum(field_for_Sums) * (scale / wt_sum) + + else ! Do the averages with order-dependent sums to reproduce older answers. + wt_sum = 0 ; varsum = 0. + do j=js,je ; do i=is,ie + if (weight(i,j) > 0.0) then + wt_sum = wt_sum + weight(i,j) + varsum = varsum + field(i,j) * weight(i,j) + endif + enddo ; enddo + + ! Note that these averages will not reproduce across PE layouts or grid rotation. + call sum_across_PEs(wt_sum) + if (wt_sum > 0.0) then + call sum_across_PEs(varsum) + varAvg = varsum / wt_sum + endif + endif + + field(:,:) = varAvg + +end subroutine homogenize_field + + !> Create a 2d-mesh of grid coordinates from 1-d arrays. subroutine meshgrid(x, y, x_T, y_T) real, dimension(:), intent(in) :: x !< input 1-dimensional vector diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 49002d4846..1eec90f568 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -92,7 +92,7 @@ module MOM_state_initialization use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h -use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer +use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer, homogenize_field use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd use MOM_oda_incupd, only: set_up_oda_incupd_field, set_up_oda_incupd_vel_field use MOM_oda_incupd, only: calc_oda_increments, output_oda_incupd_inc @@ -2651,6 +2651,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=just_read) @@ -2910,31 +2911,14 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just endif endif - call tracer_z_init_array(temp_z, z_edges_in, kd, zi, temp_land_fill, G, nz, nlevs, eps_z, & - tv%T) - call tracer_z_init_array(salt_z, z_edges_in, kd, zi, salt_land_fill, G, nz, nlevs, eps_z, & - tv%S) + call tracer_z_init_array(temp_z, z_edges_in, kd, zi, temp_land_fill, G, nz, nlevs, eps_z, tv%T) + call tracer_z_init_array(salt_z, z_edges_in, kd, zi, salt_land_fill, G, nz, nlevs, eps_z, tv%S) if (homogenize) then ! Horizontally homogenize data to produce perfectly "flat" initial conditions do k=1,nz - nPoints = 0 ; tempAvg = 0. ; saltAvg = 0. - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - nPoints = nPoints + 1 - tempAvg = tempAvg + tv%T(i,j,k) - saltAvg = saltAvg + tv%S(i,j,k) - endif ; enddo ; enddo - - !### These averages will not reproduce across PE layouts or grid rotation. - call sum_across_PEs(nPoints) - call sum_across_PEs(tempAvg) - call sum_across_PEs(saltAvg) - if (nPoints>0) then - tempAvg = tempAvg / real(nPoints) - saltAvg = saltAvg / real(nPoints) - endif - tv%T(:,:,k) = tempAvg - tv%S(:,:,k) = saltAvg + call homogenize_field(tv%T(:,:,k), G%mask2dT, G, scale=US%degC_to_C, answer_date=hor_regrid_answer_date) + call homogenize_field(tv%S(:,:,k), G%mask2dT, G, scale=US%ppt_to_S, answer_date=hor_regrid_answer_date) enddo endif diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 7c62ea496e..bd77ec54d5 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -154,6 +154,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_hor_reg_ans_date) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 7ff3bd3701..2e2a3edf07 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -255,6 +255,7 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_hor_reg_ans_date) @@ -545,6 +546,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& + "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& "latter takes precedence.", default=default_hor_reg_ans_date) call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & From 334817233d6b45e84a414e70aa098497f1afc54a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 25 Jan 2023 18:05:34 -0500 Subject: [PATCH 170/629] (*)Corrected the units of VarMix_CS%slope_x VarMix_CS%slope_x was being set with units of [Z L-1 ~> nondim], but described in comments as though it was simply [nondim], and then used in the (apparently unused?) calculate_slopes=.false. branch in calc_slope_functions_using_just_e as though its units actually were [nondim]. This commit corrects this inconsistency, while also rescaling the internal slope variables in that routine to also have the proper units of [Z L-1 ~> nondim]. In so doing, several rescaling factors could be eliminated from the calculations. In addition, the slopes used in calc_QG_Leith_viscosity were also being rescaled with the wrong factor or had dimensionally incorrect tiny values in some denominators, and this has been corrected as well. In testing this rescaling fix, a number of other bugs were identified with USE_QG_LEITH_VISC=True (as described at github.com/mom-ocean/MOM6/issues/1590), so a fatal error message was added if this option is enabled. All answers in the MOM6-examples test suite are bitwise identical, but the code will now give a fatal error if USE_QG_LEITH_VISC=.true. --- .../lateral/MOM_hor_visc.F90 | 8 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 90 +++++++++++-------- 2 files changed, 59 insertions(+), 39 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 0574297c0c..e6dd131a99 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1936,8 +1936,14 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & "If true, use QG Leith nonlinear eddy viscosity.", & default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) + if (CS%use_QG_Leith_visc) then + call MOM_error(FATAL, "USE_QG_LEITH_VISC=True activates code that is a work-in-progress and "//& + "should not be used until a number of bugs are fixed. Specifically it does not "//& + "reproduce across PE count or layout, and may use arrays that have not been properly "//& + "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.") + endif if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then - call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& "LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.") endif diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 85049025b6..7d71a62e25 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -105,8 +105,8 @@ module MOM_lateral_mixing_coeffs !! spacing squared at v [L2 T-2 ~> m2 s-2]. real, allocatable :: Rd_dx_h(:,:) !< Deformation radius over grid spacing [nondim] - real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [nondim] - real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [nondim] + real, allocatable :: slope_x(:,:,:) !< Zonal isopycnal slope [Z L-1 ~> nondim] + real, allocatable :: slope_y(:,:,:) !< Meridional isopycnal slope [Z L-1 ~> nondim] real, allocatable :: ebt_struct(:,:,:) !< Vertical structure function to scale diffusivities with [nondim] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: & @@ -142,7 +142,7 @@ module MOM_lateral_mixing_coeffs integer :: Res_fn_power_visc !< The power of dx/Ld in the Kh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. - real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate [nondim]. + real :: Visbeck_S_max !< Upper bound on slope used in Eady growth rate [Z L-1 ~> nondim]. ! Leith parameters logical :: use_QG_Leith_GM !< If true, uses the QG Leith viscosity as the GM coefficient @@ -514,28 +514,33 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: slope_x !< Zonal isoneutral slope [Z L-1 ~> nondim] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: N2_u !< Buoyancy (Brunt-Vaisala) frequency !! at u-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: slope_y !< Meridional isoneutral slope [nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: slope_y !< Meridional isoneutral slope + !! [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: N2_v !< Buoyancy (Brunt-Vaisala) frequency !! at v-points [L2 Z-2 T-2 ~> s-2] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure ! Local variables - real :: S2 ! Interface slope squared [nondim] - real :: N2 ! Positive buoyancy frequency or zero [T-2 ~> s-2] + real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] + real :: N2 ! Positive buoyancy frequency or zero [L2 Z-2 T-2 ~> s-2] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup and Hdn [H ~> m or kg m-2]. - real :: S2max ! An upper bound on the squared slopes [nondim] + real :: S2max ! An upper bound on the squared slopes [Z2 L-2 ~> nondim] real :: wNE, wSE, wSW, wNW ! Weights of adjacent points [nondim] real :: H_u(SZIB_(G)), H_v(SZI_(G)) ! Layer thicknesses at u- and v-points [H ~> m or kg m-2] ! Note that at some points in the code S2_u and S2_v hold the running depth ! integrals of the squared slope [H ~> m or kg m-2] before the average is taken. - real :: S2_u(SZIB_(G),SZJ_(G)) ! The thickness-weighted depth average of the squared slope at u points [nondim]. - real :: S2_v(SZI_(G),SZJB_(G)) ! The thickness-weighted depth average of the squared slope at v points [nondim]. + real :: S2_u(SZIB_(G),SZJ_(G)) ! At first the thickness-weighted depth integral of the squared + ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the + ! squared slope [Z2 L-2 ~> nondim] at u points. + real :: S2_v(SZI_(G),SZJB_(G)) ! At first the thickness-weighted depth integral of the squared + ! slope [H Z2 L-2 ~> m or kg m-2] and then the average of the + ! squared slope [Z2 L-2 ~> nondim] at v points. integer :: i, j, k, is, ie, js, je, nz, l_seg @@ -545,7 +550,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C if (.not. CS%calculate_Eady_growth_rate) return if (.not. allocated(CS%SN_u)) call MOM_error(FATAL, "calc_slope_function:"// & "%SN_u is not associated with use_variable_mixing.") - if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:"// & + if (.not. allocated(CS%SN_v)) call MOM_error(FATAL, "calc_slope_function:R"// & "%SN_v is not associated with use_variable_mixing.") is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -563,7 +568,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C ! and midlatitude deformation radii, using calc_resoln_function as a template. !$OMP parallel do default(shared) private(S2,H_u,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) - do j = js,je + do j=js,je do I=is-1,ie CS%SN_u(I,j) = 0. ; H_u(I) = 0. ; S2_u(I,j) = 0. enddo @@ -599,7 +604,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C enddo !$OMP parallel do default(shared) private(S2,H_v,Hdn,Hup,H_geom,N2,wNE,wSE,wSW,wNW) - do J = js-1,je + do J=js-1,je do i=is,ie CS%SN_v(i,J) = 0. ; H_v(i) = 0. ; S2_v(i,J) = 0. enddo @@ -644,7 +649,7 @@ subroutine calc_Visbeck_coeffs_old(h, slope_x, slope_y, N2_u, N2_v, G, GV, US, C call uvchksum("calc_Visbeck_coeffs_old slope_[xy]", slope_x, slope_y, G%HI, & scale=US%Z_to_L, haloshift=1) call uvchksum("calc_Visbeck_coeffs_old N2_u, N2_v", N2_u, N2_v, G%HI, & - scale=US%L_to_Z**2 * US%s_to_T**2, scalar_pair=.true.) + scale=US%L_to_Z**2*US%s_to_T**2, scalar_pair=.true.) call uvchksum("calc_Visbeck_coeffs_old SN_[uv]", CS%SN_u, CS%SN_v, G%HI, & scale=US%s_to_T, scalar_pair=.true.) endif @@ -698,7 +703,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, enddo ; enddo !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg,vint_SN,sum_dz) - do j = G%jsc-1,G%jec+1 + do j=G%jsc-1,G%jec+1 do I=G%isc-1,G%iec vint_SN(I) = 0. sum_dz(I) = dz_neglect @@ -741,7 +746,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, enddo !$OMP parallel do default(shared) private(dnew,dz,weight,l_seg) - do J = G%jsc-1,G%jec + do J=G%jsc-1,G%jec do i=G%isc-1,G%iec+1 vint_SN(i) = 0. sum_dz(i) = dz_neglect @@ -782,14 +787,14 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, enddo enddo - do j = G%jsc,G%jec + do j=G%jsc,G%jec do I=G%isc-1,G%iec CS%SN_u(I,j) = sqrt( SN_cpy(I,j)**2 & + 0.25*( (CS%SN_v(i,J)**2 + CS%SN_v(i+1,J-1)**2) & + (CS%SN_v(i+1,J)**2 + CS%SN_v(i,J-1)**2) ) ) enddo enddo - do J = G%jsc-1,G%jec + do J=G%jsc-1,G%jec do i=G%isc,G%iec CS%SN_v(i,J) = sqrt( CS%SN_v(i,J)**2 & + 0.25*( (SN_cpy(I,j)**2 + SN_cpy(I-1,j+1)**2) & @@ -816,13 +821,13 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop logical, intent(in) :: calculate_slopes !< If true, calculate slopes !! internally otherwise use slopes stored in CS ! Local variables - real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [nondim] (for diagnostics) - real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [nondim] (for diagnostics) + real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) + real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: S2 ! Interface slope squared [nondim] - real :: N2 ! Brunt-Vaisala frequency squared [T-2 ~> s-2] + real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] + real :: N2 ! Brunt-Vaisala frequency squared [L2 Z-2 T-2 ~> s-2] real :: Hup, Hdn ! Thickness from above, below [H ~> m or kg m-2] real :: H_geom ! The geometric mean of Hup*Hdn [H ~> m or kg m-2]. real :: S2N2_u_local(SZIB_(G),SZJ_(G),SZK_(GV)) ! The depth integral of the slope times @@ -857,16 +862,16 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop if (calculate_slopes) then ! Calculate the interface slopes E_x and E_y and u- and v- points respectively do j=js-1,je+1 ; do I=is-1,ie - E_x(I,j) = US%Z_to_L*(e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) + E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) ! Mask slopes where interface intersects topography if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo do J=js-1,je ; do i=is-1,ie+1 - E_y(i,J) = US%Z_to_L*(e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) + E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) ! Mask slopes where interface intersects topography if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. enddo ; enddo - else + else ! This branch is not used. do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = CS%slope_x(I,j,k) if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. @@ -880,22 +885,22 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie S2 = ( E_x(I,j)**2 + 0.25*( & - (E_y(I,j)**2+E_y(I+1,j-1)**2)+(E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) + (E_y(I,j)**2+E_y(I+1,j-1)**2) + (E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & S2 = 0.0 S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 enddo ; enddo do J=js-1,je ; do i=is,ie S2 = ( E_y(i,J)**2 + 0.25*( & - (E_x(i,J)**2+E_x(i-1,J+1)**2)+(E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) + (E_x(i,J)**2+E_x(i-1,J+1)**2) + (E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k)*US%L_to_Z**2 / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & S2 = 0.0 S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 @@ -960,14 +965,14 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo !! (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] ! Local variables real, dimension(SZI_(G),SZJB_(G)) :: & - dslopey_dz, & ! z-derivative of y-slope at v-points [Z-1 ~> m-1] + dslopey_dz, & ! z-derivative of y-slope at v-points [L-1 ~> m-1] h_at_v, & ! Thickness at v-points [H ~> m or kg m-2] beta_v, & ! Beta at v-points [T-1 L-1 ~> s-1 m-1] grad_vort_mag_v, & ! Magnitude of vorticity gradient at v-points [T-1 L-1 ~> s-1 m-1] grad_div_mag_v ! Magnitude of divergence gradient at v-points [T-1 L-1 ~> s-1 m-1] real, dimension(SZIB_(G),SZJ_(G)) :: & - dslopex_dz, & ! z-derivative of x-slope at u-points [Z-1 ~> m-1] + dslopex_dz, & ! z-derivative of x-slope at u-points [L-1 ~> m-1] h_at_u, & ! Thickness at u-points [H ~> m or kg m-2] beta_u, & ! Beta at u-points [T-1 L-1 ~> s-1 m-1] grad_vort_mag_u, & ! Magnitude of vorticity gradient at u-points [T-1 L-1 ~> s-1 m-1] @@ -987,41 +992,50 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo if ((k > 1) .and. (k < nz)) then + ! With USE_QG_LEITH_VISC=True, this might need to change to + ! do j=js-2,je+2 ; do I=is-2,ie+1 + ! but other arrays used here (e.g., h and CS%slope_x) would also need to have wider valid halos. do j=js-1,je+1 ; do I=is-2,Ieq+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) * h(i+1,j,k) ) / & ( ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) + h(i+1,j,k) ) & - + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff ) + + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff**2 ) h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & - + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff ) + + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**2 ) Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * Ih h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo + ! With USE_QG_LEITH_VISC=True, this might need to change to + ! do J=js-2,je+1 ; do i=is-2,ie+2 do J=js-2,Jeq+1 ; do i=is-1,ie+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) * h(i,j+1,k) ) / & ( ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) + h(i,j+1,k) ) & - + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff ) + + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff**2 ) h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & - + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff ) + + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**2 ) Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * Ih h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo + ! With USE_QG_LEITH_VISC=True, this might need to be + ! do J=js-2,je+1 ; do i=is-1,ie+1 do J=js-1,je ; do i=is-1,Ieq+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) - vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * US%L_to_Z * & + vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * & ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & + ( h_at_u(I-1,j) * dslopex_dz(I-1,j) + h_at_u(I,j+1) * dslopex_dz(I,j+1) ) ) / & ( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff) enddo ; enddo + ! With USE_QG_LEITH_VISC=True, this might need to be + ! do j=js-1,je+1 ; do I=is-2,ie+1 do j=js-1,Jeq+1 ; do I=is-1,ie f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) - vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * US%L_to_Z * & + vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) & + ( h_at_v(i,J-1) * dslopey_dz(i,J-1) + h_at_v(i+1,J) * dslopey_dz(i+1,J) ) ) / & ( ( h_at_v(i,J) + h_at_v(i+1,J-1) ) + ( h_at_v(i,J-1) + h_at_v(i+1,J) ) + GV%H_subroundoff) @@ -1236,7 +1250,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "If non-zero, is an upper bound on slopes used in the "//& "Visbeck formula for diffusivity. This does not affect the "//& "isopycnal slope calculation used within thickness diffusion.", & - units="nondim", default=0.0) + units="nondim", default=0.0, scale=US%L_to_Z) else CS%Visbeck_S_max = 0. endif From 0b857c0e8202e9a775676c135094ca9aa6c567a8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Jan 2023 08:43:39 -0500 Subject: [PATCH 171/629] Cancel out rescaling factors in wave_speed Incorporated a slope squared rescaling factor into the definition of the local N2min variable in wave_speed, thereby eliminating 4 points in the code where rescaling had been necessary and another local variable. All answers and output are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 34669ae706..9c8cd099f3 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -128,7 +128,6 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: L2_to_Z2 ! A scaling factor squared from units of lateral distances to depths [Z2 L-2 ~> 1]. real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and ! its derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. @@ -156,7 +155,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: hw ! The mean of the adjacent layer thicknesses [Z ~> m] real :: sum_hc ! The sum of the layer thicknesses [Z ~> m] real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] - real :: N2min ! A minimum buoyancy frequency [T-2 ~> s-2] + real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 Z-2 T-2 ~> s-2] logical :: l_use_ebt_mode, calc_modal_structure real :: l_mono_N2_column_fraction ! A local value of mono_N2_column_fraction [nondim] real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [Z ~> m] @@ -174,8 +173,6 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed endif ; endif - L2_to_Z2 = US%L_to_Z**2 - l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode l_mono_N2_column_fraction = CS%mono_N2_column_fraction @@ -219,7 +216,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,tv,& !$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & !$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,L2_to_Z2, & +!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale, & !$OMP better_est,cg1_min2,tol_merge,tol_solve,c2_scale) & !$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & !$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & @@ -453,7 +450,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (l_use_ebt_mode) then Igu(1) = 0. ! Neumann condition for pressure modes sum_hc = Hc(1) - N2min = L2_to_Z2*gprime(2)/Hc(1) + N2min = gprime(2)/Hc(1) do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) @@ -461,12 +458,12 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !### Change to: if ( ((htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) .or. & ) ) if ( (((G%bathyT(i,j)+G%Z_ref) - sum_hc < l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) .or. & ((l_mono_N2_depth >= 0.) .and. (sum_hc > l_mono_N2_depth))) .and. & - (L2_to_Z2*gp > N2min*hw) ) then + (gp > N2min*hw) ) then ! Filters out regions where N2 increases with depth but only in a lower fraction ! of the water column or below a certain depth. - gp = US%Z_to_L**2 * (N2min*hw) + gp = N2min * hw else - N2min = L2_to_Z2 * gp/hw + N2min = gp / hw endif endif Igu(k) = 1.0/(gp*Hc(k)) From 1a51c504c58a71ca15d02319b6c00e24eb759946 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Jan 2023 12:33:58 -0500 Subject: [PATCH 172/629] Use rescaled variables for global mean T & S diags Use rescaled variables for 6 global mean temperature and salinity diagnostics, using the tmp_scale arguments to the various global mean functions so that they have conversion factors that can be verified against their declared units in their register_scalar_field calls. Also added or corrected unit descriptions for a handful of variables in the MOM_diagnostics module. All answers and output are bitwise identical. --- src/diagnostics/MOM_diagnostics.F90 | 144 ++++++++++++++-------------- 1 file changed, 71 insertions(+), 73 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 11a37c8589..ff65a3b60b 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -54,7 +54,7 @@ module MOM_diagnostics logical :: initialized = .false. !< True if this control structure has been initialized. real :: mono_N2_column_fraction = 0. !< The lower fraction of water column over which N2 is limited as !! monotonic for the purposes of calculating the equivalent - !! barotropic wave speed. + !! barotropic wave speed [nondim]. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of !! calculating the equivalent barotropic wave speed [Z ~> m]. @@ -203,7 +203,7 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! including [nondim] and [H ~> m or kg m-2]. real :: uh_tmp(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary zonal transport [H L2 T-1 ~> m3 s-1 or kg s-1] real :: vh_tmp(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary meridional transport [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. + real :: mass_cell(SZI_(G),SZJ_(G)) ! The vertically integrated mass in a grid cell [kg] real :: rho_in_situ(SZI_(G)) ! In situ density [R ~> kg m-3] real :: cg1(SZI_(G),SZJ_(G)) ! First baroclinic gravity wave speed [L T-1 ~> m s-1] real :: Rd1(SZI_(G),SZJ_(G)) ! First baroclinic deformation radius [L ~> m] @@ -221,13 +221,13 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & integer :: k_list - real, dimension(SZK_(GV)) :: temp_layer_ave ! The average temperature in a layer [degC] - real, dimension(SZK_(GV)) :: salt_layer_ave ! The average salinity in a layer [degC] - real :: thetaoga ! The volume mean potential temperature [degC] - real :: soga ! The volume mean ocean salinity [ppt] + real, dimension(SZK_(GV)) :: temp_layer_ave ! The average temperature in a layer [C ~> degC] + real, dimension(SZK_(GV)) :: salt_layer_ave ! The average salinity in a layer [S ~> ppt] + real :: thetaoga ! The volume mean potential temperature [C ~> degC] + real :: soga ! The volume mean ocean salinity [S ~> ppt] real :: masso ! The total mass of the ocean [kg] - real :: tosga ! The area mean sea surface temperature [degC] - real :: sosga ! The area mean sea surface salinity [ppt] + real :: tosga ! The area mean sea surface temperature [C ~> degC] + real :: sosga ! The area mean sea surface salinity [S ~> ppt] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -334,11 +334,11 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! mass of liquid ocean (for Bouss, use Rho0). The reproducing sum requires the use of MKS units. if (CS%id_masso > 0) then - work_2d(:,:) = 0.0 + mass_cell(:,:) = 0.0 do k=1,nz ; do j=js,je ; do i=is,ie - work_2d(i,j) = work_2d(i,j) + (GV%H_to_kg_m2*h(i,j,k)) * US%L_to_m**2*G%areaT(i,j) + mass_cell(i,j) = mass_cell(i,j) + (GV%H_to_kg_m2*h(i,j,k)) * US%L_to_m**2*G%areaT(i,j) enddo ; enddo ; enddo - masso = reproducing_sum(work_2d) + masso = reproducing_sum(mass_cell) call post_data(CS%id_masso, masso, CS%diag) endif @@ -458,37 +458,37 @@ subroutine calculate_diagnostic_fields(u, v, h, uh, vh, tv, ADp, CDp, p_surf, & ! volume mean potential temperature if (CS%id_thetaoga>0) then - thetaoga = global_volume_mean(tv%T, h, G, GV, scale=US%C_to_degC) + thetaoga = global_volume_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) call post_data(CS%id_thetaoga, thetaoga, CS%diag) endif ! area mean SST if (CS%id_tosga > 0) then - tosga = global_area_mean(tv%T(:,:,1), G, scale=US%C_to_degC) + tosga = global_area_mean(tv%T(:,:,1), G, tmp_scale=US%C_to_degC) call post_data(CS%id_tosga, tosga, CS%diag) endif ! volume mean salinity if (CS%id_soga>0) then - soga = global_volume_mean(tv%S, h, G, GV, scale=US%S_to_ppt) + soga = global_volume_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) call post_data(CS%id_soga, soga, CS%diag) endif ! area mean SSS if (CS%id_sosga > 0) then - sosga = global_area_mean(tv%S(:,:,1), G, scale=US%S_to_ppt) + sosga = global_area_mean(tv%S(:,:,1), G, tmp_scale=US%S_to_ppt) call post_data(CS%id_sosga, sosga, CS%diag) endif ! layer mean potential temperature if (CS%id_temp_layer_ave>0) then - temp_layer_ave = global_layer_mean(tv%T, h, G, GV, scale=US%C_to_degC) + temp_layer_ave = global_layer_mean(tv%T, h, G, GV, tmp_scale=US%C_to_degC) call post_data(CS%id_temp_layer_ave, temp_layer_ave, CS%diag) endif ! layer mean salinity if (CS%id_salt_layer_ave>0) then - salt_layer_ave = global_layer_mean(tv%S, h, G, GV, scale=US%S_to_ppt) + salt_layer_ave = global_layer_mean(tv%S, h, G, GV, tmp_scale=US%S_to_ppt) call post_data(CS%id_salt_layer_ave, salt_layer_ave, CS%diag) endif @@ -834,7 +834,7 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by a !! previous call to diagnostics_init. - real, dimension(SZI_(G), SZJ_(G)) :: & + real, dimension(SZI_(G),SZJ_(G)) :: & z_top, & ! Height of the top of a layer or the ocean [Z ~> m]. z_bot, & ! Height of the bottom of a layer (for id_mass) or the ! (positive) depth of the ocean (for id_col_ht) [Z ~> m]. @@ -891,7 +891,6 @@ subroutine calculate_vertical_integrals(h, tv, p_surf, G, GV, US, CS) if (GV%Boussinesq) then if (associated(tv%eqn_of_state)) then IG_Earth = 1.0 / GV%g_Earth -! do j=js,je ; do i=is,ie ; z_bot(i,j) = -P_SURF(i,j)/GV%H_to_Pa ; enddo ; enddo do j=G%jscB,G%jecB+1 ; do i=G%iscB,G%iecB+1 z_bot(i,j) = 0.0 enddo ; enddo @@ -1207,9 +1206,10 @@ end subroutine calculate_energy_diagnostics subroutine register_time_deriv(lb, f_ptr, deriv_ptr, CS) integer, intent(in), dimension(3) :: lb !< Lower index bound of f_ptr real, dimension(lb(1):,lb(2):,:), target :: f_ptr - !< Time derivative operand + !< Time derivative operand, in arbitrary units [A ~> a] real, dimension(lb(1):,lb(2):,:), target :: deriv_ptr - !< Time derivative of f_ptr + !< Time derivative of f_ptr, in units derived from + !! the arbitrary units of f_ptr [A T-1 ~> a s-1] type(diagnostics_CS), intent(inout) :: CS !< Control structure returned by previous call to !! diagnostics_init. @@ -1329,7 +1329,7 @@ subroutine post_surface_thermo_diags(IDs, G, GV, US, diag, dt_int, sfc_state, tv real, dimension(SZI_(G),SZJ_(G)), intent(in) :: ssh_ibc !< Time mean surface height with corrections !! for ice displacement and the inverse barometer [Z ~> m] - real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array + real, dimension(SZI_(G),SZJ_(G)) :: work_2d ! A 2-d work array [various] real, dimension(SZI_(G),SZJ_(G)) :: & zos ! dynamic sea lev (zero area mean) from inverse-barometer adjusted ssh [Z ~> m] real :: I_time_int ! The inverse of the time interval [T-1 ~> s-1]. @@ -1475,10 +1475,10 @@ subroutine post_transport_diagnostics(G, GV, US, uhtr, vhtr, h, IDs, diag_pre_dy type(tracer_registry_type), pointer :: Reg !< Pointer to the tracer registry ! Local variables - real, dimension(SZIB_(G), SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZI_(G), SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZIB_(G),SZJ_(G)) :: umo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G)) :: vmo2d ! Diagnostics of integrated mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: umo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vmo ! Diagnostics of layer mass transport [R Z L2 T-1 ~> kg s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tend ! Change in layer thickness due to dynamics ! [H T-1 ~> m s-1 or kg m-2 s-1]. real :: Idt ! The inverse of the time interval [T-1 ~> s-1] @@ -1637,11 +1637,11 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag flux_units = get_flux_units(GV) convert_H = GV%H_to_MKS - CS%id_masscello = register_diag_field('ocean_model', 'masscello', diag%axesTL,& + 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, & standard_name='sea_water_mass_per_unit_area', v_extensive=.true.) - CS%id_masso = register_scalar_field('ocean_model', 'masso', Time, & + CS%id_masso = register_scalar_field('ocean_model', 'masso', Time, & diag, 'Mass of liquid ocean', 'kg', standard_name='sea_water_mass') CS%id_thkcello = register_diag_field('ocean_model', 'thkcello', diag%axesTL, Time, & @@ -1683,38 +1683,38 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag standard_name='Salinity Squared') CS%id_temp_layer_ave = register_diag_field('ocean_model', 'temp_layer_ave', & - diag%axesZL, Time, 'Layer Average Ocean Temperature', 'degC') + diag%axesZL, Time, 'Layer Average Ocean Temperature', units='degC', conversion=US%C_to_degC) CS%id_salt_layer_ave = register_diag_field('ocean_model', 'salt_layer_ave', & - diag%axesZL, Time, 'Layer Average Ocean Salinity', 'psu') + diag%axesZL, Time, 'Layer Average Ocean Salinity', units='psu', conversion=US%S_to_ppt) CS%id_thetaoga = register_scalar_field('ocean_model', 'thetaoga', & - Time, diag, 'Global Mean Ocean Potential Temperature', 'degC', & + Time, diag, 'Global Mean Ocean Potential Temperature', units='degC', conversion=US%C_to_degC, & standard_name='sea_water_potential_temperature') CS%id_soga = register_scalar_field('ocean_model', 'soga', & - Time, diag, 'Global Mean Ocean Salinity', 'psu', & + Time, diag, 'Global Mean Ocean Salinity', units='psu', conversion=US%S_to_ppt, & standard_name='sea_water_salinity') - CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag,& - long_name='Global Area Average Sea Surface Temperature', & - units='degC', standard_name='sea_surface_temperature', & - cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & + CS%id_tosga = register_scalar_field('ocean_model', 'sst_global', Time, diag, & + long_name='Global Area Average Sea Surface Temperature', & + units='degC', conversion=US%C_to_degC, standard_name='sea_surface_temperature', & + cmor_field_name='tosga', cmor_standard_name='sea_surface_temperature', & cmor_long_name='Sea Surface Temperature') - CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag,& - long_name='Global Area Average Sea Surface Salinity', & - units='psu', standard_name='sea_surface_salinity', & - cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & + CS%id_sosga = register_scalar_field('ocean_model', 'sss_global', Time, diag, & + long_name='Global Area Average Sea Surface Salinity', & + units='psu', conversion=US%S_to_ppt, standard_name='sea_surface_salinity', & + cmor_field_name='sosga', cmor_standard_name='sea_surface_salinity', & cmor_long_name='Sea Surface Salinity') endif - CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & + CS%id_u = register_diag_field('ocean_model', 'u', diag%axesCuL, Time, & 'Zonal velocity', 'm s-1', conversion=US%L_T_to_m_s, cmor_field_name='uo', & cmor_standard_name='sea_water_x_velocity', cmor_long_name='Sea Water X Velocity') - CS%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & + CS%id_v = register_diag_field('ocean_model', 'v', diag%axesCvL, Time, & 'Meridional velocity', 'm s-1', conversion=US%L_T_to_m_s, cmor_field_name='vo', & cmor_standard_name='sea_water_y_velocity', cmor_long_name='Sea Water Y Velocity') - CS%id_usq = register_diag_field('ocean_model', 'usq', diag%axesCuL, Time, & + CS%id_usq = register_diag_field('ocean_model', 'usq', diag%axesCuL, Time, & 'Zonal velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) - CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & + CS%id_vsq = register_diag_field('ocean_model', 'vsq', diag%axesCvL, Time, & 'Meridional velocity squared', 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_uv = register_diag_field('ocean_model', 'uv', diag%axesTL, Time, & 'Product between zonal and meridional velocities at h-points', & @@ -1864,22 +1864,22 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag wave_speed_tol=wave_speed_tol) endif - CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & + CS%id_mass_wt = register_diag_field('ocean_model', 'mass_wt', diag%axesT1, Time, & 'The column mass for calculating mass-weighted average properties', 'kg m-2', conversion=US%RZ_to_kg_m2) if (use_temperature) then - CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & + CS%id_temp_int = register_diag_field('ocean_model', 'temp_int', diag%axesT1, Time, & 'Density weighted column integrated potential temperature', & 'degC kg m-2', conversion=US%C_to_degC*US%RZ_to_kg_m2, & - cmor_field_name='opottempmint', & - cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature',& + cmor_field_name='opottempmint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_potential_temperature', & cmor_standard_name='Depth integrated density times potential temperature') - CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & + CS%id_salt_int = register_diag_field('ocean_model', 'salt_int', diag%axesT1, Time, & 'Density weighted column integrated salinity', & 'psu kg m-2', conversion=US%S_to_ppt*US%RZ_to_kg_m2, & - cmor_field_name='somint', & - cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity',& + cmor_field_name='somint', & + cmor_long_name='integral_wrt_depth_of_product_of_sea_water_density_and_salinity', & cmor_standard_name='Depth integrated density times salinity') endif @@ -1909,18 +1909,18 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables ! Vertically integrated, budget, and surface state diagnostics - IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag,& - long_name='Total volume of liquid ocean', units='m3', & + IDs%id_volo = register_scalar_field('ocean_model', 'volo', Time, diag, & + long_name='Total volume of liquid ocean', units='m3', & standard_name='sea_water_volume') - IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time,& - standard_name = 'sea_surface_height_above_geoid', & + IDs%id_zos = register_diag_field('ocean_model', 'zos', diag%axesT1, Time, & + standard_name = 'sea_surface_height_above_geoid', & long_name= 'Sea surface height above geoid', units='m', conversion=US%Z_to_m) - IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time,& - standard_name='square_of_sea_surface_height_above_geoid', & + IDs%id_zossq = register_diag_field('ocean_model', 'zossq', diag%axesT1, Time, & + standard_name='square_of_sea_surface_height_above_geoid', & long_name='Square of sea surface height above geoid', units='m2', conversion=US%Z_to_m**2) IDs%id_ssh = register_diag_field('ocean_model', 'SSH', diag%axesT1, Time, & 'Sea Surface Height', 'm', conversion=US%Z_to_m) - IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag,& + IDs%id_ssh_ga = register_scalar_field('ocean_model', 'ssh_ga', Time, diag, & long_name='Area averaged sea surface height', units='m', conversion=US%Z_to_m, & standard_name='area_averaged_sea_surface_height') IDs%id_ssu = register_diag_field('ocean_model', 'SSU', diag%axesCu1, Time, & @@ -1931,7 +1931,7 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Sea Surface Speed', 'm s-1', conversion=US%L_T_to_m_s) if (associated(tv%T)) then - IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & + IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & 'Sea Surface Temperature', 'degC', conversion=US%C_to_degC, & cmor_field_name='tos', cmor_long_name='Sea Surface Temperature', & cmor_standard_name='sea_surface_temperature') @@ -1948,11 +1948,11 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) cmor_field_name='sossq', cmor_long_name='Square of Sea Surface Salinity ', & cmor_standard_name='square_of_sea_surface_salinity') if (tv%T_is_conT) then - IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & + IDs%id_sstcon = register_diag_field('ocean_model', 'conSST', diag%axesT1, Time, & 'Sea Surface Conservative Temperature', 'Celsius', conversion=US%C_to_degC) endif if (tv%S_is_absS) then - IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & + IDs%id_sssabs = register_diag_field('ocean_model', 'absSSS', diag%axesT1, Time, & 'Sea Surface Absolute Salinity', 'g kg-1', conversion=US%S_to_ppt) endif if (associated(tv%frazil)) then @@ -1970,7 +1970,7 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) IDs%id_Heat_PmE = register_diag_field('ocean_model', 'Heat_PmE', diag%axesT1, Time, & 'Heat flux into ocean from mass flux into ocean', & 'W m-2', conversion=US%QRZ_T_to_W_m2) - IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time,& + IDs%id_intern_heat = register_diag_field('ocean_model', 'internal_heat', diag%axesT1, Time, & 'Heat flux into ocean from geothermal or other internal sources', & 'W m-2', conversion=US%QRZ_T_to_W_m2) @@ -1981,15 +1981,13 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) type(time_type), intent(in) :: Time !< current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(transport_diag_IDs), intent(inout) :: IDs !< A structure with the diagnostic IDs. type(diag_ctrl), intent(inout) :: diag !< regulates diagnostic output - real :: H_convert character(len=48) :: thickness_units, accum_flux_units thickness_units = get_thickness_units(GV) - H_convert = GV%H_to_MKS if (GV%Boussinesq) then accum_flux_units = "m3" else @@ -1999,10 +1997,10 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) ! Diagnostics related to tracer and mass transport IDs%id_uhtr = register_diag_field('ocean_model', 'uhtr', diag%axesCuL, Time, & 'Accumulated zonal thickness fluxes to advect tracers', & - accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + accum_flux_units, y_cell_method='sum', v_extensive=.true., conversion=GV%H_to_MKS*US%L_to_m**2) IDs%id_vhtr = register_diag_field('ocean_model', 'vhtr', diag%axesCvL, Time, & 'Accumulated meridional thickness fluxes to advect tracers', & - accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=H_convert*US%L_to_m**2) + accum_flux_units, x_cell_method='sum', v_extensive=.true., conversion=GV%H_to_MKS*US%L_to_m**2) IDs%id_umo = register_diag_field('ocean_model', 'umo', & diag%axesCuL, Time, 'Ocean Mass X Transport', & 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & @@ -2019,10 +2017,10 @@ subroutine register_transport_diags(Time, G, GV, US, IDs, diag) diag%axesCv1, Time, 'Ocean Mass Y Transport Vertical Sum', & 'kg s-1', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2, & standard_name='ocean_mass_y_transport_vertical_sum', x_cell_method='sum') - IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & + IDs%id_dynamics_h = register_diag_field('ocean_model','dynamics_h', & diag%axesTl, Time, 'Layer thicknesses prior to horizontal dynamics', & thickness_units, conversion=GV%H_to_MKS, v_extensive=.true.) - IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & + IDs%id_dynamics_h_tendency = register_diag_field('ocean_model','dynamics_h_tendency', & diag%axesTl, Time, 'Change in layer thicknesses due to horizontal dynamics', & trim(thickness_units)//" s-1", conversion=GV%H_to_MKS*US%s_to_T, v_extensive=.true.) @@ -2037,7 +2035,7 @@ subroutine write_static_fields(G, GV, US, tv, diag) type(diag_ctrl), target, intent(inout) :: diag !< regulates diagnostic output ! Local variables - real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array. + real :: work_2d(SZI_(G),SZJ_(G)) ! A 2-d temporary work array [Z ~> m] integer :: id, i, j logical :: use_temperature @@ -2104,10 +2102,10 @@ subroutine write_static_fields(G, GV, US, tv, diag) x_cell_method='sum', y_cell_method='sum', area_cell_method='sum') if (id > 0) call post_data(id, G%areaBu, diag, .true.) - id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & + id = register_static_field('ocean_model', 'depth_ocean', diag%axesT1, & 'Depth of the ocean at tracer points', 'm', conversion=US%Z_to_m, & - standard_name='sea_floor_depth_below_geoid', & - cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & + standard_name='sea_floor_depth_below_geoid', & + cmor_field_name='deptho', cmor_long_name='Sea Floor Depth', & cmor_standard_name='sea_floor_depth_below_geoid', area=diag%axesT1%id_area, & x_cell_method='mean', y_cell_method='mean', area_cell_method='mean') if (id > 0) then From f3b1a61d5bb9f5292cc0cd1f03935122c6af619b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 05:08:11 -0500 Subject: [PATCH 173/629] +Add optional unscale argument to check_redundant Added an optional unscale argument to the various check_redundant and chksum_vec routines so that the values that are written out in error messages are independent of rescaling values. Also added or amended comments to document the units of numerous internal variables and function arguments in MOM_debugging.F90. All answers are bitwise identical, but there are new optional arguments to several publicly visible routines. --- src/diagnostics/MOM_debugging.F90 | 362 +++++++++++++++++++----------- 1 file changed, 236 insertions(+), 126 deletions(-) diff --git a/src/diagnostics/MOM_debugging.F90 b/src/diagnostics/MOM_debugging.F90 index fd7e891e82..15e555ee37 100644 --- a/src/diagnostics/MOM_debugging.F90 +++ b/src/diagnostics/MOM_debugging.F90 @@ -76,11 +76,11 @@ module MOM_debugging contains !> MOM_debugging_init initializes the MOM_debugging module, and sets -!! the parameterts that control which checks are active for MOM6. +!! the parameters that control which checks are active for MOM6. subroutine MOM_debugging_init(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_debugging" ! This module's name. call log_version(param_file, mdl, version, debugging=.true.) @@ -102,19 +102,24 @@ end subroutine MOM_debugging_init !> Check for consistency between the duplicated points of a 3-D C-grid vector subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] + ! Local variables character(len=24) :: mesg_k integer :: k @@ -126,30 +131,37 @@ subroutine check_redundant_vC3d(mesg, u_comp, v_comp, G, is, ie, js, je, & else ; write(mesg_k,'(" Layer",i9," ")') k ; endif call check_redundant_vC2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & - v_comp(:,:,k), G, is, ie, js, je, direction) + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo end subroutine check_redundant_vC3d !> Check for consistency between the duplicated points of a 2-D C-grid vector subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: u_resym(G%IsdB:G%IedB,G%jsd:G%jed) - real :: v_resym(G%isd:G%ied,G%JsdB:G%JedB) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of u_comp [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of v_comp [A ~> a] + real :: u_resym(G%IsdB:G%IedB,G%jsd:G%jed) ! A reconstructed symmetric version of u_comp [A ~> a] + real :: v_resym(G%isd:G%ied,G%JsdB:G%JedB) ! A reconstructed symmetric version of v_comp [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -163,6 +175,8 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if ((isd == IsdB) .and. (jsd == JsdB)) return endif + sc = 1.0 ; if (present(unscale)) sc = unscale + do i=isd,ied ; do j=jsd,jed u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) enddo ; enddo @@ -187,7 +201,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - u_comp(i,j), u_resym(i,j),u_comp(i,j)-u_resym(i,j),i,j,pe_here() + sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(3) = redundant_prints(3) + 1 endif @@ -197,7 +211,7 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & redundant_prints(3) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & - v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & + sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) redundant_prints(3) = redundant_prints(3) + 1 @@ -207,14 +221,17 @@ subroutine check_redundant_vC2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vC2d !> Check for consistency between the duplicated points of a 3-D scalar at corner points -subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k @@ -227,22 +244,28 @@ subroutine check_redundant_sB3d(mesg, array, G, is, ie, js, je) else ; write(mesg_k,'(" Layer",i9," ")') k ; endif call check_redundant_sB2d(trim(mesg)//trim(mesg_k), array(:,:,k), & - G, is, ie, js, je) + G, is, ie, js, je, unscale) enddo end subroutine check_redundant_sB3d !> Check for consistency between the duplicated points of a 2-D scalar at corner points -subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: a_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of array [A ~> a] + real :: a_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of array [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -256,6 +279,8 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) if ((isd == IsdB) .and. (jsd == JsdB)) return endif + sc = 1.0 ; if (present(unscale)) sc = unscale + do i=isd,ied ; do j=jsd,jed a_nonsym(i,j) = array(i,j) enddo ; enddo @@ -281,7 +306,7 @@ subroutine check_redundant_sB2d(mesg, array, G, is, ie, js, je) redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - array(i,j), a_resym(i,j),array(i,j)-a_resym(i,j),i,j,pe_here() + sc*array(i,j), sc*a_resym(i,j), sc*(array(i,j)-a_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 endif @@ -291,19 +316,23 @@ end subroutine check_redundant_sB2d !> Check for consistency between the duplicated points of a 3-D B-grid vector subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k @@ -315,30 +344,37 @@ subroutine check_redundant_vB3d(mesg, u_comp, v_comp, G, is, ie, js, je, & else ; write(mesg_k,'(" Layer",i9," ")') k ; endif call check_redundant_vB2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & - v_comp(:,:,k), G, is, ie, js, je, direction) + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo end subroutine check_redundant_vB3d !> Check for consistency between the duplicated points of a 2-D B-grid vector subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: u_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) - real :: v_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of u_comp [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A nonsymmetric version of v_comp [A ~> a] + real :: u_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of u_comp [A ~> a] + real :: v_resym(G%IsdB:G%IedB,G%JsdB:G%JedB) ! A reconstructed symmetric version of v_comp [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch integer :: Isq, Ieq, Jsq, Jeq, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -352,6 +388,8 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if ((isd == IsdB) .and. (jsd == JsdB)) return endif + sc = 1.0 ; if (present(unscale)) sc = unscale + do i=isd,ied ; do j=jsd,jed u_nonsym(i,j) = u_comp(i,j) ; v_nonsym(i,j) = v_comp(i,j) enddo ; enddo @@ -377,7 +415,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - u_comp(i,j), u_resym(i,j),u_comp(i,j)-u_resym(i,j),i,j,pe_here() + sc*u_comp(i,j), sc*u_resym(i,j), sc*(u_comp(i,j)-u_resym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 endif @@ -387,7 +425,7 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & redundant_prints(2) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & - v_comp(i,j), v_resym(i,j),v_comp(i,j)-v_resym(i,j),i,j, & + sc*v_comp(i,j), sc*v_resym(i,j), sc*(v_comp(i,j)-v_resym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) redundant_prints(2) = redundant_prints(2) + 1 @@ -397,14 +435,17 @@ subroutine check_redundant_vB2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vB2d !> Check for consistency between the duplicated points of a 3-D scalar at tracer points -subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k @@ -416,22 +457,28 @@ subroutine check_redundant_sT3d(mesg, array, G, is, ie, js, je) else ; write(mesg_k,'(" Layer",i9," ")') k ; endif call check_redundant_sT2d(trim(mesg)//trim(mesg_k), array(:,:,k), & - G, is, ie, js, je) + G, is, ie, js, je, unscale) enddo end subroutine check_redundant_sT3d !> Check for consistency between the duplicated points of a 2-D scalar at tracer points -subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) +subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: array !< The array to be checked for consistency in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: a_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of array with halo points updated by message passing [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch @@ -442,6 +489,8 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie if (present(js)) js_ch = js ; if (present(js)) je_ch = je + sc = 1.0 ; if (present(unscale)) sc = unscale + ! This only works on points outside of the standard computational domain. if ((is_ch == G%isc) .and. (ie_ch == G%iec) .and. & (js_ch == G%jsc) .and. (je_ch == G%jec)) return @@ -457,7 +506,7 @@ subroutine check_redundant_sT2d(mesg, array, G, is, ie, js, je) redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" Redundant points",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - array(i,j), a_nonsym(i,j),array(i,j)-a_nonsym(i,j),i,j,pe_here() + sc*array(i,j), sc*a_nonsym(i,j), sc*(array(i,j)-a_nonsym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 endif @@ -467,19 +516,23 @@ end subroutine check_redundant_sT2d !> Check for consistency between the duplicated points of a 3-D A-grid vector subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables character(len=24) :: mesg_k integer :: k @@ -491,28 +544,35 @@ subroutine check_redundant_vT3d(mesg, u_comp, v_comp, G, is, ie, js, je, & else ; write(mesg_k,'(" Layer",i9," ")') k ; endif call check_redundant_vT2d(trim(mesg)//trim(mesg_k), u_comp(:,:,k), & - v_comp(:,:,k), G, is, ie, js, je, direction) + v_comp(:,:,k), G, is, ie, js, je, direction, unscale) enddo end subroutine check_redundant_vT3d !> Check for consistency between the duplicated points of a 2-D A-grid vector subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & - direction) + direction, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - !! to be checked for consistency - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector - !! to be checked for consistency + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: is !< The starting i-index to check integer, optional, intent(in) :: ie !< The ending i-index to check integer, optional, intent(in) :: js !< The starting j-index to check integer, optional, intent(in) :: je !< The ending j-index to check integer, optional, intent(in) :: direction !< the direction flag to be !! passed to pass_vector + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables - real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) - real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input vector while [a] indicates the unscaled (e.g., mks) units to used for output. + real :: u_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of u_comp with halo points updated by message passing [A ~> a] + real :: v_nonsym(G%isd:G%ied,G%jsd:G%jed) ! A version of v_comp with halo points updated by message passing [A ~> a] + real :: sc ! A factor that undoes the scaling for the arrays to give consistent output [a A-1 ~> 1] character(len=128) :: mesg2 integer :: i, j, is_ch, ie_ch, js_ch, je_ch @@ -525,6 +585,8 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & if (present(is)) is_ch = is ; if (present(ie)) ie_ch = ie if (present(js)) js_ch = js ; if (present(js)) je_ch = je + sc = 1.0 ; if (present(unscale)) sc = unscale + ! This only works on points outside of the standard computational domain. if ((is_ch == G%isc) .and. (ie_ch == G%iec) .and. & (js_ch == G%jsc) .and. (je_ch == G%jec)) return @@ -540,7 +602,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant u-components",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," on pe ",i4)') & - u_comp(i,j), u_nonsym(i,j),u_comp(i,j)-u_nonsym(i,j),i,j,pe_here() + sc*u_comp(i,j), sc*u_nonsym(i,j), sc*(u_comp(i,j)-u_nonsym(i,j)), i, j, pe_here() write(0,'(A130)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 endif @@ -550,7 +612,7 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & redundant_prints(1) < max_redundant_prints) then write(mesg2,'(" redundant v-comps",2(1pe12.4)," differ by ", & & 1pe12.4," at i,j = ",2i4," x,y = ",2(1pe12.4)," on pe ",i4)') & - v_comp(i,j), v_nonsym(i,j),v_comp(i,j)-v_nonsym(i,j),i,j, & + sc*v_comp(i,j), sc*v_nonsym(i,j), sc*(v_comp(i,j)-v_nonsym(i,j)), i, j, & G%geoLonBu(i,j), G%geoLatBu(i,j), pe_here() write(0,'(A155)') trim(mesg)//trim(mesg2) redundant_prints(1) = redundant_prints(1) + 1 @@ -559,163 +621,202 @@ subroutine check_redundant_vT2d(mesg, u_comp, v_comp, G, is, ie, js, je, & end subroutine check_redundant_vT2d + +! It appears that none of the other routines in this file are ever called. + !> Do a checksum and redundant point check on a 3d C-grid vector. -subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_C3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call uvchksum(mesg, u_comp, v_comp, G%HI, halos) + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, scale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_C(mesg, u_comp, v_comp, G) + call check_redundant_C(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_C3d !> Do a checksum and redundant point check on a 2d C-grid vector. -subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_C2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call uvchksum(mesg, u_comp, v_comp, G%HI, halos) + call uvchksum(mesg, u_comp, v_comp, G%HI, halos, scale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_C(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_C(mesg, u_comp, v_comp, G) + call check_redundant_C(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_C2d !> Do a checksum and redundant point check on a 3d B-grid vector. -subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_B3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call Bchksum(u_comp, mesg//"(u)", G%HI, halos) - call Bchksum(v_comp, mesg//"(v)", G%HI, halos) + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_B(mesg, u_comp, v_comp, G) + call check_redundant_B(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_B3d ! Do a checksum and redundant point check on a 2d B-grid vector. -subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric) +subroutine chksum_vec_B2d(mesg, u_comp, v_comp, G, halos, scalars, symmetric, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%IsdB:,G%JsdB:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. logical, optional, intent(in) :: symmetric !< If true, do the checksums on the !! full symmetric computational domain. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric) - call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric) + call Bchksum(u_comp, mesg//"(u)", G%HI, halos, symmetric=symmetric, scale=unscale) + call Bchksum(v_comp, mesg//"(v)", G%HI, halos, symmetric=symmetric, scale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_B(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_B(mesg, u_comp, v_comp, G) + call check_redundant_B(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_B2d !> Do a checksum and redundant point check on a 3d C-grid vector. -subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_A3d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%isd:,G%jsd:,:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:,:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call hchksum(u_comp, mesg//"(u)", G%HI, halos) - call hchksum(v_comp, mesg//"(v)", G%HI, halos) + call hchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_T(mesg, u_comp, v_comp, G) + call check_redundant_T(mesg, u_comp, v_comp, G, unscale=unscale) endif endif end subroutine chksum_vec_A3d !> Do a checksum and redundant point check on a 2d C-grid vector. -subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars) +subroutine chksum_vec_A2d(mesg, u_comp, v_comp, G, halos, scalars, unscale) character(len=*), intent(in) :: mesg !< An identifying message type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector - real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector + real, dimension(G%isd:,G%jsd:), intent(in) :: u_comp !< The u-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] + real, dimension(G%isd:,G%jsd:), intent(in) :: v_comp !< The v-component of the vector to be + !! checked for consistency in arbitrary, + !! possibly rescaled units [A ~> a] integer, optional, intent(in) :: halos !< The width of halos to check (default 0) logical, optional, intent(in) :: scalars !< If true this is a pair of !! scalars that are being checked. + real, optional, intent(in) :: unscale !< A factor that undoes the scaling for the + !! arrays to give consistent output [a A-1 ~> 1] ! Local variables logical :: are_scalars are_scalars = .false. ; if (present(scalars)) are_scalars = scalars if (debug_chksums) then - call hchksum(u_comp, mesg//"(u)", G%HI, halos) - call hchksum(v_comp, mesg//"(v)", G%HI, halos) + call hchksum(u_comp, mesg//"(u)", G%HI, halos, scale=unscale) + call hchksum(v_comp, mesg//"(v)", G%HI, halos, scale=unscale) endif if (debug_redundant) then if (are_scalars) then - call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair) + call check_redundant_T(mesg, u_comp, v_comp, G, direction=To_All+Scalar_Pair, unscale=unscale) else - call check_redundant_T(mesg, u_comp, v_comp, G) + call check_redundant_T(mesg, u_comp, v_comp, G, unscale=unscale) endif endif @@ -725,12 +826,12 @@ end subroutine chksum_vec_A2d !! processors of hThick*stuff, where stuff is a 3-d array at tracer points. function totalStuff(HI, hThick, areaT, stuff) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights [m] real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed - real :: totalStuff !< the globally integrated amoutn of stuff + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: stuff !< The array of stuff to be summed in arbitrary units [a] + real :: totalStuff !< the globally integrated amount of stuff [a m3] ! Local variables - real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum ! The column integrated amount of stuff in a cell [a m3] integer :: i, j, k, nz nz = size(hThick,3) @@ -746,18 +847,22 @@ end function totalStuff !! as well as the change since the last call. subroutine totalTandS(HI, hThick, areaT, temperature, salinity, mesg) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: hThick !< The array of thicknesses to use as weights [m] real, dimension(HI%isd:,HI%jsd:), intent(in) :: areaT !< The array of cell areas [m2] - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: temperature !< The temperature field to sum - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: temperature !< The temperature field to sum [degC] + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: salinity !< The salinity field to sum [ppt] character(len=*), intent(in) :: mesg !< An identifying message ! NOTE: This subroutine uses "save" data which is not thread safe and is purely for ! extreme debugging without a proper debugger. - real, save :: totalH = 0., totalT = 0., totalS = 0. + real, save :: totalH = 0. ! The total ocean volume, saved for the next call [m3] + real, save :: totalT = 0. ! The total volume integrated ocean temperature, saved for the next call [degC m3] + real, save :: totalS = 0. ! The total volume integrated ocean salinity, saved for the next call [ppt m3] ! Local variables logical, save :: firstCall = .true. - real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum - real :: thisH, thisT, thisS, delH, delT, delS + real, dimension(HI%isc:HI%iec, HI%jsc:HI%jec) :: tmp_for_sum ! The volume of each column [m3] + real :: thisH, delH ! The total ocean volume and the change from the last call [m3] + real :: thisT, delT ! The current total volume integrated temperature and the change from the last call [degC m3] + real :: thisS, delS ! The current total volume integrated salinity and the change from the last call [ppt m3] integer :: i, j, k, nz nz = size(hThick,3) @@ -788,11 +893,13 @@ end subroutine totalTandS !> Returns false if the column integral of a given quantity is within roundoff logical function check_column_integral(nk, field, known_answer) integer, intent(in) :: nk !< Number of levels in column - real, dimension(nk), intent(in) :: field !< Field to be summed - real, optional, intent(in) :: known_answer !< If present is the expected sum, + real, dimension(nk), intent(in) :: field !< Field to be summed [arbitrary] + real, optional, intent(in) :: known_answer !< If present is the expected sum [arbitrary], !! If missing, assumed zero ! Local variables - real :: u_sum, error, expected + real :: u_sum ! The vertical sum of the field [arbitrary] + real :: error ! An estimate of the roundoff error in the sum [arbitrary] + real :: expected ! The expected vertical sum [arbitrary] integer :: k u_sum = field(1) @@ -824,12 +931,15 @@ end function check_column_integral logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_value) integer, intent(in) :: nk_1 !< Number of levels in field 1 integer, intent(in) :: nk_2 !< Number of levels in field 2 - real, dimension(nk_1), intent(in) :: field_1 !< First field to be summed - real, dimension(nk_2), intent(in) :: field_2 !< Second field to be summed + real, dimension(nk_1), intent(in) :: field_1 !< First field to be summed [arbitrary] + real, dimension(nk_2), intent(in) :: field_2 !< Second field to be summed [arbitrary] real, optional, intent(in) :: missing_value !< If column contains missing values, - !! mask them from the sum + !! mask them from the sum [arbitrary] ! Local variables - real :: u1_sum, error1, u2_sum, error2, misval + real :: u1_sum, u2_sum ! The vertical sums of the two fields [arbitrary] + real :: error1, error2 ! Estimates of the roundoff errors in the sums [arbitrary] + real :: misval ! The missing value flag, indicating elements that are to be omitted + ! from the sums [arbitrary] integer :: k ! Assign missing value @@ -844,7 +954,7 @@ logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_va ! Reintegrate and sum roundoff errors do k=2,nk_1 - if (field_1(k)/=misval) then + if (field_1(k) /= misval) then u1_sum = u1_sum + field_1(k) error1 = error1 + EPSILON(u1_sum)*MAX(ABS(u1_sum),ABS(field_1(k))) endif @@ -855,7 +965,7 @@ logical function check_column_integrals(nk_1, field_1, nk_2, field_2, missing_va ! Reintegrate and sum roundoff errors do k=2,nk_2 - if (field_2(k)/=misval) then + if (field_2(k) /= misval) then u2_sum = u2_sum + field_2(k) error2 = error2 + EPSILON(u2_sum)*MAX(ABS(u2_sum),ABS(field_2(k))) endif From 09880a8efae8e1c0b662b307c1ce34a54bae8a05 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 05:36:55 -0500 Subject: [PATCH 174/629] Use unscale args to check_redundant calls Added unscale arguments to the various check_redundant calls so that any error messages that are generated by inconsistent redundant points will be invariant to the unit scaling that is is in use. Also rescaled the units of dtbt_reset_period to [T ~> s] in the MOM_control_struct. All answers are bitwise identical, but in some rare debugging output will become consistent. --- src/core/MOM.F90 | 19 +++++++++--------- src/core/MOM_dynamics_split_RK2.F90 | 30 ++++++++++++++--------------- 2 files changed, 25 insertions(+), 24 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 07538cdec2..daa40ba052 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -296,7 +296,7 @@ module MOM logical :: use_diabatic_time_bug !< If true, uses the wrong calendar time for diabatic processes, !! as was done in MOM6 versions prior to February 2018. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the - !! barotropic time step [s]. If this is negative dtbt is never + !! barotropic time step [T ~> s]. If this is negative dtbt is never !! calculated, and if it is 0, dtbt is calculated every step. type(time_type) :: dtbt_reset_interval !< A time_time representation of dtbt_reset_period. type(time_type) :: dtbt_reset_time !< The next time DTBT should be calculated. @@ -730,9 +730,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%debug) then if (cycle_start) & call MOM_state_chksum("Before steps ", u, v, h, CS%uh, CS%vh, G, GV, US) - if (cycle_start) call check_redundant("Before steps ", u, v, G) + if (cycle_start) call check_redundant("Before steps ", u, v, G, unscale=US%L_T_to_m_s) if (do_dyn) call MOM_mech_forcing_chksum("Before steps", forces, G, US, haloshift=0) - if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G) + if (do_dyn) call check_redundant("Before steps ", forces%taux, forces%tauy, G, & + unscale=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) endif call cpu_clock_end(id_clock_other) @@ -1498,7 +1499,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & haloshift=0, scale=GV%H_to_m*US%L_to_m**2) ! call MOM_state_chksum("Pre-diabatic ", u, v, h, CS%uhtr, CS%vhtr, G, GV, vel_scale=1.0) call MOM_thermo_chksum("Pre-diabatic ", tv, G, US, haloshift=0) - call check_redundant("Pre-diabatic ", u, v, G) + call check_redundant("Pre-diabatic ", u, v, G, unscale=US%L_T_to_m_s) call MOM_forcing_chksum("Pre-diabatic", fluxes, G, US, haloshift=0) endif @@ -1531,7 +1532,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, scale=US%C_to_degC) call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, scale=US%S_to_ppt) - call check_redundant("Pre-ALE ", u, v, G) + call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_ALE) @@ -1586,7 +1587,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & 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) call hchksum(tv%S, "Post-ALE S", G%HI, haloshift=1, scale=US%S_to_ppt) - call check_redundant("Post-ALE ", u, v, G) + call check_redundant("Post-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif ! Whenever thickness changes let the diag manager know, target grids @@ -1611,7 +1612,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, & "Post-diabatic salt deficit", G%HI, haloshift=0, scale=US%RZ_to_kg_m2) ! call MOM_thermo_chksum("Post-diabatic ", tv, G, US) - call check_redundant("Post-diabatic ", u, v, G) + call check_redundant("Post-diabatic ", u, v, G, unscale=US%L_T_to_m_s) endif call disable_averaging(CS%diag) @@ -2186,7 +2187,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & "only on information available at initialization. If 0, "//& "DTBT will be set every dynamics time step. The default "//& "is set by DT_THERM. This is only used if SPLIT is true.", & - units="s", default=default_val, do_not_read=(dtbt > 0.0)) + units="s", default=default_val, scale=US%s_to_T, do_not_read=(dtbt > 0.0)) endif call get_param(param_file, "MOM", "DT_OBC_SEG_UPDATE_OBGC", CS%dt_obc_seg_period, & @@ -2988,7 +2989,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) if (CS%dtbt_reset_period > 0.0) then - CS%dtbt_reset_interval = real_to_time(CS%dtbt_reset_period) + CS%dtbt_reset_interval = real_to_time(US%T_to_s*CS%dtbt_reset_period) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. CS%dtbt_reset_time = Time_init + CS%dtbt_reset_interval * & ((Time - Time_init) / CS%dtbt_reset_interval) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index e8909e24f9..1d7a70a55c 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -406,8 +406,8 @@ 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) - call check_redundant("Start predictor uh ", uh, vh, G) + 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) endif dyn_p_surf = associated(p_surf_begin) .and. associated(p_surf_end) @@ -543,10 +543,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G) - call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G) - call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G) - call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G) + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) endif call cpu_clock_begin(id_clock_vertvisc) @@ -649,8 +649,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s 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=2, & symmetric=sym) - call check_redundant("Predictor 1 up", up, vp, G) - call check_redundant("Predictor 1 uh", uh, vh, G) + 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) endif ! up <- up + dt_pred d/dz visc d/dz up @@ -778,8 +778,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call uvchksum("Predictor avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) call hchksum(h_av, "Predictor avg h", G%HI, haloshift=0, scale=GV%H_to_m) ! call MOM_state_chksum("Predictor avg ", u_av, v_av, h_av, uh, vh, G, GV, US) - call check_redundant("Predictor up ", up, vp, G) - call check_redundant("Predictor uh ", uh, vh, G) + 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) endif ! diffu = horizontal viscosity terms (u_av) @@ -820,10 +820,10 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & symmetric=sym) - call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G) - call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G) - call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G) - call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G) + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) endif ! u_accel_bt = layer accelerations due to barotropic solver @@ -848,7 +848,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (showCallTree) call callTree_leave("btstep()") if (CS%debug) then - call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G) + call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) endif ! u = u + dt*( u_bc_accel + u_accel_bt ) From 915679db09e612215b46a236c7c0e0e48a6cda0f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 9 Jan 2023 19:09:16 -0500 Subject: [PATCH 175/629] Document units of variables in MOM_spatial_means Added or amended comments to document the units of numerous internal variables and function arguments in MOM_spatial_means.F90. Only comments are changed, and all answers are bitwise identical. --- src/diagnostics/MOM_spatial_means.F90 | 245 +++++++++++++++++--------- 1 file changed, 163 insertions(+), 82 deletions(-) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 502475d3f3..ab1210c0f5 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -22,21 +22,33 @@ module MOM_spatial_means public :: global_volume_mean, global_mass_integral, global_mass_int_EFP public :: adjust_area_mean_to_zero +! 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 functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + contains !> Return the global area mean of a variable. This uses reproducing sums. function global_area_mean(var, G, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G), SZJ_(G)), intent(in) :: var !< The variable to average - real, optional, intent(in) :: scale !< A rescaling factor for the variable - real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value - real :: global_area_mean + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the variable + !! that is reversed in the return value [a A-1 ~> 1] + real :: global_area_mean ! The mean of the variable in arbitrary unscaled units [a] or scaled units [A ~> a] ! Local variables - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: scalefac ! An overall scaling factor for the areas and variable. - real :: temp_scale ! A temporary scaling factor. + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -58,16 +70,23 @@ end function global_area_mean !> Return the global area mean of a variable. This uses reproducing sums. function global_area_mean_v(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: var !< The variable to average + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value + !! variable that converts it back to unscaled + !! (e.g., mks) units to enable the use of the + !! reproducing sums [a A-1 ~> 1], but is reversed + !! before output so that the return value has + !! the same units as var - real :: global_area_mean_v + real :: global_area_mean_v ! The mean of the variable in the same arbitrary units as var [A ~> a] ! Local variables - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: scalefac ! An overall scaling factor for the areas and variable. - real :: temp_scale ! A temporary scaling factor + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -91,14 +110,22 @@ end function global_area_mean_v !> Return the global area mean of a variable on U grid. This uses reproducing sums. function global_area_mean_u(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: var !< The variable to average + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value - real :: global_area_mean_u + !! variable that converts it back to unscaled + !! (e.g., mks) units to enable the use of the + !! reproducing sums [a A-1 ~> 1], but is reversed + !! before output so that the return value has + !! the same units as var + real :: global_area_mean_u ! The mean of the variable in the same arbitrary units as var [A ~> a] - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: scalefac ! An overall scaling factor for the areas and variable. - real :: temp_scale ! A temporary scaling factor + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] + real :: scalefac ! An overall scaling factor for the areas and variable [a m2 A-1 L-2 ~> 1] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -123,18 +150,24 @@ end function global_area_mean_u !! grid, but an alternate could be used instead. This uses reproducing sums. function global_area_integral(var, G, scale, area, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate - real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: var !< The variable to integrate in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: area !< The alternate area to use, including !! any required masking [L2 ~> m2]. real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value - real :: global_area_integral !< The returned area integral, usually in the units of var times [m2]. + !! variable that is reversed in the return value [a A-1 ~> 1] + real :: global_area_integral !< The returned area integral, usually in the units of var times an area, + !! [a m2] or [A m2 ~> a m2] depending on which optional arguments are provided ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] real :: scalefac ! An overall scaling factor for the areas and variable. - real :: temp_scale ! A temporary scaling factor. + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -163,18 +196,28 @@ end function global_area_integral function global_layer_mean(var, h, G, GV, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: var !< The variable to average in + !! arbitrary, possibly rescaled units [A ~> a] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value - real, dimension(SZK_(GV)) :: global_layer_mean + !! variable that is reversed in the return value [a A-1 ~> 1] + real, dimension(SZK_(GV)) :: global_layer_mean !< The mean of the variable in the arbitrary scaled [A] + !! or unscaled [a] units of var, depending on which optional + !! arguments are provided - real, dimension(G%isc:G%iec, G%jsc:G%jec, SZK_(GV)) :: tmpForSumming, weight + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: tmpForSumming ! An unscaled cell integral [a m3] + real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: weight ! The volume of each cell, used as a weight [m3] type(EFP_type), dimension(2*SZK_(GV)) :: laysums - real, dimension(SZK_(GV)) :: global_temp_scalar, global_weight_scalar - real :: temp_scale ! A temporary scaling factor - real :: scalefac ! A scaling factor for the variable. + real, dimension(SZK_(GV)) :: global_temp_scalar ! The global integral of the tracer in each layer [a m3] + real, dimension(SZK_(GV)) :: global_weight_scalar ! The global integral of the volume of each layer [m3] + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -202,18 +245,26 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: var !< The variable being averaged + intent(in) :: var !< The variable being averaged in + !! arbitrary, possibly rescaled units [A ~> a] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value - real :: global_volume_mean !< The thickness-weighted average of var + !! variable that is reversed in the return value [a A-1 ~> 1] + real :: global_volume_mean !< The thickness-weighted average of var in the arbitrary scaled [A] or + !! unscaled [a] units of var, depending on which optional arguments are provided - real :: temp_scale ! A temporary scaling factor - real :: scalefac ! A scaling factor for the variable. - real :: weight_here - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming, sum_weight + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: weight_here ! The volume of a grid cell [m3] + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The volume integral of the variable in a column [a m3] + real, dimension(SZI_(G),SZJ_(G)) :: sum_weight ! The volume of each column of water [m3] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -239,19 +290,25 @@ function global_mass_integral(h, G, GV, var, on_PE_only, scale, tmp_scale) 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)), & - optional, intent(in) :: var !< The variable being integrated - logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only - !! done on the local PE, and it is _not_ order invariant. - real, optional, intent(in) :: scale !< A rescaling factor for the variable + optional, intent(in) :: var !< The variable being integrated in + !! arbitrary, possibly rescaled units [A ~> a] + logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done + !! on the local PE, and it is _not_ order invariant. + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value + !! variable that is reversed in the return value [a A-1 ~> 1] real :: global_mass_integral !< The mass-weighted integral of var (or 1) in - !! kg times the units of var + !! kg times the arbitrary units of var [kg a] or [kg A ~> kg a] - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSumming - real :: scalefac ! An overall scaling factor for the areas and variable. - real :: temp_scale ! A temporary scaling factor. - logical :: global_sum + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The mass-weighted integral of the variable in a column [kg a] + real :: scalefac ! An overall scaling factor for the cell mass and variable [a kg A-1 H-1 L-2 ~> kg m-3 or 1] + real :: temp_scale ! A temporary scaling factor [1] or [a A-1 ~> 1] + logical :: global_sum ! If true do the sum globally, but if false only do the sum on the current PE. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -293,16 +350,21 @@ function global_mass_int_EFP(h, G, GV, var, on_PE_only, scale) 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)), & - optional, intent(in) :: var !< The variable being integrated + optional, intent(in) :: var !< The variable being integrated in + !! arbitrary, possibly rescaled units [A ~> a] logical, optional, intent(in) :: on_PE_only !< If present and true, the sum is only done !! on the local PE, but it is still order invariant. - real, optional, intent(in) :: scale !< A rescaling factor for the variable + real, optional, intent(in) :: scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums type(EFP_type) :: global_mass_int_EFP !< The mass-weighted integral of var (or 1) in - !! kg times the units of var + !! kg times the arbitrary units of var [kg a] ! Local variables - real, dimension(SZI_(G), SZJ_(G)) :: tmpForSum - real :: scalefac ! An overall scaling factor for the areas and variable. + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSum ! The mass-weighted integral of the variable in a column [kg a] + real :: scalefac ! An overall scaling factor for the cell mass and variable [a kg A-1 H-1 L-2 ~> kg m-3 or 1] integer :: i, j, k, is, ie, js, je, nz, isr, ier, jsr, jer is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -333,19 +395,25 @@ end function global_mass_int_EFP !! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_i_mean(array, i_mean, G, mask, scale, tmp_scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged - real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(SZJ_(G)), intent(out) :: i_mean !< Global mean of array along its i-axis [a] or [A ~> a] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the i-mean - real, optional, intent(in) :: scale !< A rescaling factor for the output variable + optional, intent(in) :: mask !< An array used for weighting the i-mean [nondim] + real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal - !! calculations that is removed from the output + !! calculations that is removed from the output [a A-1 ~> 1] ! Local variables - type(EFP_type), allocatable, dimension(:) :: asum, mask_sum - real :: scalefac ! A scaling factor for the variable. - real :: unscale ! A factor for undoing any internal rescaling before output. - real :: mask_sum_r + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] + type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] + real :: mask_sum_r ! The sum of the mask values in a row [nondim] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -419,19 +487,25 @@ end subroutine global_i_mean !! in a 1-d array using the local indexing. This uses reproducing sums. subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged - real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: array !< The variable being averaged in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis [a] or [A ~> a] real, dimension(SZI_(G),SZJ_(G)), & optional, intent(in) :: mask !< An array used for weighting the j-mean - real, optional, intent(in) :: scale !< A rescaling factor for the output variable + real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums real, optional, intent(in) :: tmp_scale !< A rescaling factor for the internal - !! calculations that is removed from the output + !! calculations that is removed from the output [a A-1 ~> 1] ! Local variables - type(EFP_type), allocatable, dimension(:) :: asum, mask_sum - real :: mask_sum_r - real :: scalefac ! A scaling factor for the variable. - real :: unscale ! A factor for undoing any internal rescaling before output. + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + type(EFP_type), allocatable, dimension(:) :: asum ! The masked sum of the variable in each row [a] + type(EFP_type), allocatable, dimension(:) :: mask_sum ! The sum of the mask values in each row [nondim] + real :: mask_sum_r ! The sum of the mask values in a row [nondim] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: unscale ! A factor for undoing any internal rescaling before output [A a-1 ~> 1] integer :: is, ie, js, je, idg_off, jdg_off integer :: i, j @@ -504,16 +578,23 @@ end subroutine global_j_mean !> Adjust 2d array such that area mean is zero without moving the zero contour subroutine adjust_area_mean_to_zero(array, G, scaling, unit_scale) type(ocean_grid_type), intent(in) :: G !< Grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted - real, optional, intent(out) :: scaling !< The scaling factor used - real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: array !< 2D array to be adjusted in + !! arbitrary, possibly rescaled units [A ~> a] + real, optional, intent(out) :: scaling !< The scaling factor used [nondim] + real, optional, intent(in) :: unit_scale !< A rescaling factor for the variable [a A-1 ~> 1] + !! that converts it back to unscaled (e.g., mks) + !! units to enable the use of the reproducing sums ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals, areaXposVals, areaXnegVals + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: posVals, negVals ! The positive or negative values in a cell or 0 [a] + real, dimension(G%isc:G%iec, G%jsc:G%jec) :: areaXposVals, areaXnegVals ! The cell area integral of the values [m2 a] + type(EFP_type), dimension(2) :: areaInt_EFP ! An EFP version integral of the values on the current PE [m2 a] + real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] + real :: I_scalefac ! The Adcroft reciprocal of scalefac [A a-1 ~> 1] + real :: areaIntPosVals, areaIntNegVals ! The global area integral of the positive and negative values [m2 a] + real :: posScale, negScale ! The scaling factor to apply to positive or negative values [nondim] integer :: i,j - type(EFP_type), dimension(2) :: areaInt_EFP - real :: scalefac ! A scaling factor for the variable. - real :: I_scalefac ! The Adcroft reciprocal of scalefac - real :: areaIntPosVals, areaIntNegVals, posScale, negScale scalefac = 1.0 ; if (present(unit_scale)) scalefac = unit_scale I_scalefac = 0.0 ; if (scalefac /= 0.0) I_scalefac = 1.0 / scalefac From ff15a765e6aac79c6c57102d9921b685ad4217ef Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 09:11:59 -0500 Subject: [PATCH 176/629] Document units of variables in MOM_checksums Added or amended comments to document the units of numerous internal variables and function arguments in MOM_checksums.F90. Only comments are changed, and all answers are bitwise identical. --- src/framework/MOM_checksums.F90 | 502 +++++++++++++++++++------------- 1 file changed, 302 insertions(+), 200 deletions(-) diff --git a/src/framework/MOM_checksums.F90 b/src/framework/MOM_checksums.F90 index aae3d3f5dc..00e4ba4918 100644 --- a/src/framework/MOM_checksums.F90 +++ b/src/framework/MOM_checksums.F90 @@ -21,6 +21,13 @@ module MOM_checksums public :: hchksum_pair, uvchksum, Bchksum_pair public :: MOM_checksums_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 functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + !> Checksums a pair of arrays (2d or 3d) staggered at tracer points interface hchksum_pair module procedure chksum_pair_h_2d, chksum_pair_h_3d @@ -96,14 +103,20 @@ module MOM_checksums !> Checksum a scalar field (consistent with array checksums) subroutine chksum0(scalar, mesg, scale, logunit) - real, intent(in) :: scalar !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message - real, optional, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scalar !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real :: scaling !< Explicit rescaling factor + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real :: scaling !< Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit - real :: rs !< Rescaled scalar + real :: rs !< Rescaled scalar [a] integer :: bc !< Scalar bitcount if (checkForNaNs .and. is_NaN(scalar)) & @@ -129,16 +142,22 @@ end subroutine chksum0 !> Checksum a 1d array (typically a column). subroutine zchksum(array, mesg, scale, logunit) - real, dimension(:), intent(in) :: array !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, dimension(:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, allocatable, dimension(:) :: rescaled_array - real :: scaling + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, allocatable, dimension(:) :: rescaled_array ! The array with scaling undone [a] + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: k - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0 if (checkForNaNs) then @@ -174,8 +193,10 @@ subroutine zchksum(array, mesg, scale, logunit) contains integer function subchk(array, scale) - real, dimension(:), intent(in) :: array !< The array to be checksummed - real, intent(in) :: scale !< A scaling factor for this array. + real, dimension(:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: k, bc subchk = 0 do k=LBOUND(array, 1), UBOUND(array, 1) @@ -186,10 +207,10 @@ integer function subchk(array, scale) end function subchk subroutine subStats(array, aMean, aMin, aMax) - real, dimension(:), intent(in) :: array !< The array to be checksummed - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, dimension(:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: k, n @@ -210,18 +231,21 @@ subroutine chksum_pair_h_2d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + !! a scalar, rather than vector logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -261,19 +285,21 @@ subroutine chksum_pair_h_3d(mesg, arrayA, arrayB, HI, haloshift, omit_corners, & scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:, :), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging - - logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging + logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe + !! a scalar, rather than vector logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -312,21 +338,27 @@ end subroutine chksum_pair_h_3d !> Checksums a 2d array staggered at tracer points. subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) - type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid - real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid - character(len=*), intent(in) :: mesg !< An identifying message + type(hor_index_type), target, intent(in) :: HI_m !< Horizontal index bounds of the model grid + real, dimension(HI_m%isd:,HI_m%jsd:), target, intent(in) :: array_m !< Field array on the model grid in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -415,10 +447,12 @@ subroutine chksum_h_2d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu contains integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di @@ -431,10 +465,10 @@ end function subchk subroutine subStats(HI, array, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, dimension(HI%isd:,HI%jsd:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n @@ -460,22 +494,25 @@ subroutine chksum_pair_B_2d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%jsd:), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + !! a scalar, rather than vector logical :: sym logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -520,21 +557,24 @@ subroutine chksum_pair_B_3d(mesg, arrayA, arrayB, HI, haloshift, symmetric, & omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed - real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayA !< The first array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%IsdB:,HI%JsdB:, :), target, intent(in) :: arrayB !< The second array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe - !! a scalar, rather than vector + !! a scalar, rather than vector logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in + real, dimension(:,:,:), pointer :: arrayA_in, arrayB_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -576,22 +616,28 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, scale, logunit) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type real, dimension(HI_m%IsdB:,HI_m%JsdB:), & - target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the !! full symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, Is, Js - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -692,10 +738,12 @@ subroutine chksum_B_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -709,12 +757,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n, IsB, JsB @@ -742,20 +790,23 @@ subroutine chksum_uv_2d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed - real, dimension(HI%isd:,HI%JsdB:), target, intent(in) :: arrayV !< The v-component array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:), target, intent(in) :: arrayU !< The u-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%JsdB:), target, intent(in) :: arrayV !< The v-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for these arrays. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a - !! a scalar, rather than vector + !! a scalar, rather than vector logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:), pointer :: arrayU_in, arrayV_in + real, dimension(:,:), pointer :: arrayU_in, arrayV_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -797,20 +848,23 @@ subroutine chksum_uv_3d(mesg, arrayU, arrayV, HI, haloshift, symmetric, & omit_corners, scale, logunit, scalar_pair) character(len=*), intent(in) :: mesg !< Identifying messages type(hor_index_type), target, intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed - real, dimension(HI%isd:,HI%JsdB:,:), target, intent(in) :: arrayV !< The v-component array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:,:), target, intent(in) :: arrayU !< The u-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + real, dimension(HI%isd:,HI%JsdB:,:), target, intent(in) :: arrayV !< The v-component array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for these arrays. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert these arrays back to unscaled + !! units for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging logical, optional, intent(in) :: scalar_pair !< If true, then the arrays describe a !! a scalar, rather than vector logical :: vector_pair integer :: turns type(hor_index_type), pointer :: HI_in - real, dimension(:,:,:), pointer :: arrayU_in, arrayV_in + real, dimension(:,:,:), pointer :: arrayU_in, arrayV_in ! Rotated arrays [A ~> a] vector_pair = .true. if (present(scalar_pair)) vector_pair = .not. scalar_pair @@ -850,23 +904,29 @@ end subroutine chksum_uv_3d !> Checksums a 2d array staggered at C-grid u points. subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%IsdB:,HI_m%jsd:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, Is - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -981,10 +1041,12 @@ subroutine chksum_u_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -998,12 +1060,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n, IsB @@ -1029,22 +1091,28 @@ end subroutine chksum_u_2d subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%isd:,HI_m%JsdB:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:) ! Field array on the input grid - real, allocatable, dimension(:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, Js - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1159,10 +1227,12 @@ subroutine chksum_v_2d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1176,12 +1246,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, n, JsB @@ -1206,20 +1276,26 @@ end subroutine chksum_v_2d !> Checksums a 3d array staggered at tracer points. subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logunit) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%isd:,HI_m%jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners @@ -1311,10 +1387,12 @@ subroutine chksum_h_3d(array_m, mesg, HI_m, haloshift, omit_corners, scale, logu integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 do k=LBOUND(array,3),UBOUND(array,3) ; do j=HI%jsc+dj,HI%jec+dj ; do i=HI%isc+di,HI%iec+di @@ -1327,10 +1405,10 @@ end function subchk subroutine subStats(HI, array, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, dimension(HI%isd:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed [a] + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, k, n @@ -1355,22 +1433,28 @@ end subroutine chksum_h_3d subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%IsdB:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k, Is, Js - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1478,10 +1562,12 @@ subroutine chksum_B_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1495,12 +1581,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, k, n, IsB, JsB @@ -1526,22 +1612,28 @@ end subroutine chksum_B_3d subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + real, dimension(HI_m%isdB:,HI_m%Jsd:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k, Is - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW logical :: do_corners, sym, sym_stats @@ -1656,10 +1748,12 @@ subroutine chksum_u_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1673,12 +1767,12 @@ end function subchk subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%IsdB:,HI%jsd:,:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Array mean - real, intent(out) :: aMin !< Array minimum - real, intent(out) :: aMax !< Array maximum + real, intent(out) :: aMean !< Array mean [a] + real, intent(out) :: aMin !< Array minimum [a] + real, intent(out) :: aMax !< Array maximum [a] integer :: i, j, k, n, IsB @@ -1703,25 +1797,31 @@ end subroutine chksum_u_3d !> Checksums a 3d array staggered at C-grid v points. subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, & scale, logunit) - type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type - real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed - character(len=*), intent(in) :: mesg !< An identifying message + type(hor_index_type), target, intent(in) :: HI_m !< A horizontal index type + real, dimension(HI_m%isd:,HI_m%JsdB:,:), target, intent(in) :: array_m !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] + character(len=*), intent(in) :: mesg !< An identifying message integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0) logical, optional, intent(in) :: symmetric !< If true, do the checksums on the full !! symmetric computational domain. logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts - real, optional, intent(in) :: scale !< A scaling factor for this array. - integer, optional, intent(in) :: logunit !< IO unit for checksum logging + real, optional, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] + integer, optional, intent(in) :: logunit !< IO unit for checksum logging - real, pointer :: array(:,:,:) ! Field array on the input grid - real, allocatable, dimension(:,:,:) :: rescaled_array + ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units + ! of the input array while [a] indicates the unscaled (e.g., mks) units that should be used + ! for checksums and output + real, pointer :: array(:,:,:) ! Field array on the input grid [A ~> a] + real, allocatable, dimension(:,:,:) :: rescaled_array ! The array with scaling undone [a] type(hor_index_type), pointer :: HI ! Horizontal index bounds of the input grid - real :: scaling + real :: scaling ! Explicit rescaling factor [a A-1 ~> 1] integer :: iounit !< Log IO unit integer :: i, j, k, Js integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift integer :: bcN, bcS, bcE, bcW - real :: aMean, aMin, aMax + real :: aMean, aMin, aMax ! Array mean, global minimum and global maximum [a] logical :: do_corners, sym, sym_stats integer :: turns ! Quarter turns from input to model grid @@ -1834,10 +1934,12 @@ subroutine chksum_v_3d(array_m, mesg, HI_m, haloshift, symmetric, omit_corners, integer function subchk(array, HI, di, dj, scale) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed in + !! arbitrary, possibly rescaled units [A ~> a] integer, intent(in) :: di !< i- direction array shift for this checksum integer, intent(in) :: dj !< j- direction array shift for this checksum - real, intent(in) :: scale !< A scaling factor for this array. + real, intent(in) :: scale !< A factor to convert this array back to unscaled units + !! for checksums and output [a A-1 ~> 1] integer :: i, j, k, bc subchk = 0 ! This line deliberately uses the h-point computational domain. @@ -1852,12 +1954,12 @@ end function subchk !subroutine subStats(HI, array, mesg, sym_stats) subroutine subStats(HI, array, sym_stats, aMean, aMin, aMax) type(hor_index_type), intent(in) :: HI !< A horizontal index type - real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed + real, dimension(HI%isd:,HI%JsdB:,:), intent(in) :: array !< The array to be checksummed [a] logical, intent(in) :: sym_stats !< If true, evaluate the statistics on the !! full symmetric computational domain. - real, intent(out) :: aMean !< Mean of array over domain - real, intent(out) :: aMin !< Minimum of array over domain - real, intent(out) :: aMax !< Maximum of array over domain + real, intent(out) :: aMean !< Mean of array over domain [a] + real, intent(out) :: aMin !< Minimum of array over domain [a] + real, intent(out) :: aMax !< Maximum of array over domain [a] integer :: i, j, k, n, JsB @@ -1884,7 +1986,7 @@ end subroutine chksum_v_3d !> chksum1d does a checksum of a 1-dimensional array. subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) - real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1). + real, dimension(:), intent(in) :: array !< The array to be summed (index starts at 1) [abitrary]. character(len=*), intent(in) :: mesg !< An identifying message. integer, optional, intent(in) :: start_i !< The starting index for the sum (default 1) integer, optional, intent(in) :: end_i !< The ending index for the sum (default all) @@ -1892,8 +1994,8 @@ subroutine chksum1d(array, mesg, start_i, end_i, compare_PEs) !! and list the root_PE value (default true) integer :: is, ie, i, bc, sum1, sum_bc - real :: sum - real, allocatable :: sum_here(:) + real :: sum ! The global sum of the array [arbitrary] + real, allocatable :: sum_here(:) ! The sum on each PE [arbitrary] logical :: compare integer :: pe_num ! pe number of the data integer :: nPEs ! Total number of processsors @@ -1943,11 +2045,11 @@ end subroutine chksum1d !> chksum2d does a checksum of all data in a 2-d array. subroutine chksum2d(array, mesg) - real, dimension(:,:), intent(in) :: array !< The array to be checksummed + real, dimension(:,:), intent(in) :: array !< The array to be checksummed [arbitrary] character(len=*), intent(in) :: mesg !< An identifying message integer :: xs,xe,ys,ye,i,j,sum1,bc - real :: sum + real :: sum ! The global sum of the array [arbitrary] xs = LBOUND(array,1) ; xe = UBOUND(array,1) ys = LBOUND(array,2) ; ye = UBOUND(array,2) @@ -1971,11 +2073,11 @@ end subroutine chksum2d !> chksum3d does a checksum of all data in a 2-d array. subroutine chksum3d(array, mesg) - real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed + real, dimension(:,:,:), intent(in) :: array !< The array to be checksummed [arbitrary] character(len=*), intent(in) :: mesg !< An identifying message integer :: xs,xe,ys,ye,zs,ze,i,j,k, bc,sum1 - real :: sum + real :: sum ! The global sum of the array [arbitrary] xs = LBOUND(array,1) ; xe = UBOUND(array,1) ys = LBOUND(array,2) ; ye = UBOUND(array,2) @@ -1999,7 +2101,7 @@ end subroutine chksum3d !> This function returns .true. if x is a NaN, and .false. otherwise. function is_NaN_0d(x) - real, intent(in) :: x !< The value to be checked for NaNs. + real, intent(in) :: x !< The value to be checked for NaNs [arbitrary] logical :: is_NaN_0d !is_NaN_0d = (((x < 0.0) .and. (x >= 0.0)) .or. & @@ -2015,7 +2117,7 @@ end function is_NaN_0d !> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_1d(x, skip_mpp) - real, dimension(:), intent(in) :: x !< The array to be checked for NaNs. + real, dimension(:), intent(in) :: x !< The array to be checked for NaNs [arbitrary] logical, optional, intent(in) :: skip_mpp !< If true, only check this array only !! on the local PE (default false). logical :: is_NaN_1d @@ -2038,7 +2140,7 @@ end function is_NaN_1d !> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_2d(x) - real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs. + real, dimension(:,:), intent(in) :: x !< The array to be checked for NaNs [arbitrary] logical :: is_NaN_2d integer :: i, j, n @@ -2055,7 +2157,7 @@ end function is_NaN_2d !> Returns .true. if any element of x is a NaN, and .false. otherwise. function is_NaN_3d(x) - real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs. + real, dimension(:,:,:), intent(in) :: x !< The array to be checked for NaNs [arbitrary] logical :: is_NaN_3d integer :: i, j, k, n @@ -2078,9 +2180,9 @@ end function is_NaN_3d !> Compute the field checksum of a scalar. function rotated_field_chksum_real_0d(field, pelist, mask_val, turns) & result(chksum) - real, intent(in) :: field !< Input scalar + real, intent(in) :: field !< Input scalar [arbitrary] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns integer(kind=int64) :: chksum !< checksum of scalar @@ -2093,9 +2195,9 @@ end function rotated_field_chksum_real_0d !> Compute the field checksum of a 1d field. function rotated_field_chksum_real_1d(field, pelist, mask_val, turns) & result(chksum) - real, dimension(:), intent(in) :: field !< Input array + real, dimension(:), intent(in) :: field !< Input array [arbitrary] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns integer(kind=int64) :: chksum !< checksum of array @@ -2108,14 +2210,14 @@ end function rotated_field_chksum_real_1d !> Compute the field checksum of a rotated 2d field. function rotated_field_chksum_real_2d(field, pelist, mask_val, turns) & result(chksum) - real, dimension(:,:), intent(in) :: field !< Unrotated input field + real, dimension(:,:), intent(in) :: field !< Unrotated input field [arbitrary] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns integer(kind=int64) :: chksum !< checksum of array ! Local variables - real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [arbitrary] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 @@ -2135,14 +2237,14 @@ end function rotated_field_chksum_real_2d !> Compute the field checksum of a rotated 3d field. function rotated_field_chksum_real_3d(field, pelist, mask_val, turns) & result(chksum) - real, dimension(:,:,:), intent(in) :: field !< Unrotated input field + real, dimension(:,:,:), intent(in) :: field !< Unrotated input field [arbitrary] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns integer(kind=int64) :: chksum !< checksum of array ! Local variables - real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [arbitrary] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 @@ -2162,14 +2264,14 @@ end function rotated_field_chksum_real_3d !> Compute the field checksum of a rotated 4d field. function rotated_field_chksum_real_4d(field, pelist, mask_val, turns) & result(chksum) - real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field + real, dimension(:,:,:,:), intent(in) :: field !< Unrotated input field [arbitrary] integer, optional, intent(in) :: pelist(:) !< PE list of ranks to checksum - real, optional, intent(in) :: mask_val !< FMS mask value + real, optional, intent(in) :: mask_val !< FMS mask value [nondim] integer, optional, intent(in) :: turns !< Number of quarter turns integer(kind=int64) :: chksum !< checksum of array ! Local variables - real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [arbitrary] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 @@ -2268,9 +2370,9 @@ end subroutine chk_sum_msg2 subroutine chk_sum_msg3(fmsg, aMean, aMin, aMax, mesg, iounit) character(len=*), intent(in) :: fmsg !< A checksum code-location specific preamble character(len=*), intent(in) :: mesg !< An identifying message supplied by top-level caller - real, intent(in) :: aMean !< The mean value of the array - real, intent(in) :: aMin !< The minimum value of the array - real, intent(in) :: aMax !< The maximum value of the array + real, intent(in) :: aMean !< The mean value of the array [arbitrary] + real, intent(in) :: aMin !< The minimum value of the array [arbitrary] + real, intent(in) :: aMax !< The maximum value of the array [arbitrary] integer, intent(in) :: iounit !< Checksum logger IO unit ! NOTE: We add zero to aMin and aMax to remove any negative zeros. @@ -2284,8 +2386,8 @@ end subroutine chk_sum_msg3 !! only thing that it does is to log the version of this module. subroutine MOM_checksums_init(param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_checksums" ! This module's name. call log_version(param_file, mdl, version) @@ -2303,7 +2405,7 @@ end subroutine chksum_error !> Does a bitcount of a number by first casting to an integer and then using BTEST !! to check bit by bit integer function bitcount(x) - real, intent(in) :: x !< Number to be bitcount + real, intent(in) :: x !< Number to be bitcount [arbitrary] integer, parameter :: xk = kind(x) !< Kind type of x From 0ab7744d4b6890383196e23a979426e317ca9332 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 09:12:38 -0500 Subject: [PATCH 177/629] Document units of arguments in MOM_io Added schematic unit descriptions to the comments describing the arguments to the MOM_io routines, and clearly indicating when they work with rescaled variables. Only comments are changed, and all answers are bitwise identical. --- src/framework/MOM_io.F90 | 196 ++++++++++++++++++++++++--------------- 1 file changed, 119 insertions(+), 77 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 6c2dc9df34..1dc6916c2c 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -148,8 +148,9 @@ module MOM_io character(len=64) :: cmor_field_name !< CMOR name character(len=64) :: cmor_units !< CMOR physical dimensions of the variable character(len=240) :: cmor_longname !< CMOR long name of the variable - real :: conversion !< for unit conversions, such as needed to - !! convert from intensive to extensive + real :: conversion !< for unit conversions, such as needed to convert + !! from intensive to extensive [various] or [a A-1 ~> 1] + !! to undo internal dimensional rescaling character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable integer :: position = -1 !< An integer encoding the horizontal position, it may !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. @@ -166,7 +167,7 @@ module MOM_io integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 !! if they increase downward. The default, 0, is ignored. integer :: ax_size = 0 !< The number of elements in this axis - real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis. + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] end type axis_info !> Type that stores for a global file attribute @@ -178,6 +179,13 @@ module MOM_io integer, public :: stdout = stdout_iso !< standard output unit integer, public :: stderr = stderr_iso !< standard output unit +! 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 functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + contains !> `create_MOM_file` wrapper for the legacy file handle, `file_type`. @@ -271,11 +279,12 @@ subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & integer :: num_extra_dims ! The number of extra possible dimensions from extra_axes integer :: isg, ieg, jsg, jeg, IsgB, IegB, JsgB, JegB integer :: var_periods, num_periods=0 - real, dimension(:), allocatable :: axis_val + real, dimension(:), allocatable :: axis_val ! Axis label values [various] real, pointer, dimension(:) :: & - gridLatT => NULL(), & ! The latitude or longitude of T or B points for - gridLatB => NULL(), & ! the purpose of labeling the output axes. - gridLonT => NULL(), gridLonB => NULL() + gridLatT => NULL(), & ! The latitude of T or B points for the purpose of labeling + gridLatB => NULL(), & ! the output axes, often in units of [degrees_N] or [km] or [m]. + gridLonT => NULL(), & ! The longitude of T or B points for the purpose of labeling + gridLonB => NULL() ! the output axes, often in units of [degrees_E] or [km] or [m]. character(len=40) :: time_units, x_axis_units, y_axis_units character(len=8) :: t_grid, t_grid_read character(len=64) :: ax_name(5) ! The axis names of a variable @@ -870,11 +879,12 @@ end subroutine read_var_sizes subroutine read_variable_0d(filename, varname, var, ncid_in, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: varname !< The variable name of the data in the file - real, intent(inout) :: var !< The scalar into which to read the data + real, intent(inout) :: var !< The scalar into which to read the data in arbitrary units [A ~> a] integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the !! file is opened and closed within this routine - real, optional, intent(in) :: scale !< A scaling factor that the variable is - !! multiplied by before it is returned + 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 :: varid, ncid, rc character(len=256) :: hdr @@ -907,11 +917,12 @@ end subroutine read_variable_0d subroutine read_variable_1d(filename, varname, var, ncid_in, scale) character(len=*), intent(in) :: filename !< The name of the file to read character(len=*), intent(in) :: varname !< The variable name of the data in the file - real, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data + real, dimension(:), intent(inout) :: var !< The 1-d array into which to read the data in arbitrary units [A ~> a] integer, optional, intent(in) :: ncid_in !< The netCDF ID of an open file. If absent, the !! file is opened and closed within this routine - real, optional, intent(in) :: scale !< A scaling factor that the variable is - !! multiplied by before it is returned + 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 :: varid, ncid, rc character(len=256) :: hdr @@ -1027,7 +1038,7 @@ end subroutine read_variable_1d_int subroutine read_variable_2d(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 + 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. @@ -1360,7 +1371,7 @@ end subroutine read_attribute_int64 subroutine read_attribute_real(filename, attname, att_val, varname, found, all_read, ncid_in) character(len=*), intent(in) :: filename !< Name of the file to read character(len=*), intent(in) :: attname !< Name of the attribute to read - real, intent(out) :: att_val !< The value of the attribute + real, intent(out) :: att_val !< The value of the attribute [arbitrary] character(len=*), optional, intent(in) :: varname !< The name of the variable whose attribute will !! be read. If missing, read a global attribute. logical, optional, intent(out) :: found !< Returns true if the attribute is found @@ -1604,6 +1615,7 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na character(len=*), optional, intent(in) :: cmor_longname !< CMOR long name real , optional, intent(in) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive + !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< The calling routine for error messages integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. @@ -1656,6 +1668,7 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & real , optional, intent(in) :: conversion !< A multiplicative factor for unit conversions, !! such as needed to convert from intensive to !! extensive or dimensional consistency testing + !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< The calling routine for error messages integer, optional, intent(in) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. @@ -1741,7 +1754,7 @@ subroutine set_axis_info(axis, name, units, longname, ax_size, ax_data, cartesia character(len=*), optional, intent(in) :: units !< The units of the axis labels character(len=*), optional, intent(in) :: longname !< Long name of the axis variable integer, optional, intent(in) :: ax_size !< The number of elements in this axis - real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis + real, dimension(:), optional, intent(in) :: ax_data !< The values of the data on the axis [arbitrary] character(len=*), optional, intent(in) :: cartesian !< A variable indicating which direction this axis !! axis corresponds with. Valid values !! include 'X', 'Y', 'Z', 'T', and 'N' (the default) for none. @@ -1801,7 +1814,7 @@ subroutine get_axis_info(axis,name,longname,units,cartesian,ax_size,ax_data) character(len=*), intent(out), optional :: cartesian !< The cartesian attribute !! of the axis [X,Y,Z,T]. integer, intent(out), optional :: ax_size !< The size of the axis. - real, optional, allocatable, dimension(:), intent(out) :: ax_data !< The axis label data. + real, optional, allocatable, dimension(:), intent(out) :: ax_data !< The axis label data [arbitrary] if (present(ax_data)) then if (allocated(ax_data)) deallocate(ax_data) @@ -1871,6 +1884,7 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & character(len=*), optional, intent(out) :: cmor_longname !< CMOR long name real , optional, intent(out) :: conversion !< for unit conversions, such as needed to !! convert from intensive to extensive + !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< calling routine? integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. @@ -1921,9 +1935,11 @@ subroutine MOM_read_data_0d(filename, fieldname, data, timelevel, scale, MOM_Dom global_file, file_may_be_4d) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, intent(inout) :: data !< Field value + real, intent(inout) :: data !< Field value in arbitrary units [A ~> a] integer, optional, intent(in) :: timelevel !< Time level to read in file - real, optional, intent(in) :: scale !< Rescale factor + 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] type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored @@ -1952,9 +1968,11 @@ subroutine MOM_read_data_1d(filename, fieldname, data, timelevel, scale, MOM_Dom global_file, file_may_be_4d) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:), intent(inout) :: data !< Field value + real, dimension(:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] integer, optional, intent(in) :: timelevel !< Time level to read in file - real, optional, intent(in) :: scale !< Rescale factor + 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] type(MOM_domain_type), optional, intent(in) :: MOM_Domain !< Model domain decomposition logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored @@ -1983,17 +2001,19 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & timelevel, position, scale, global_file, file_may_be_4d) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:), intent(inout) :: data !< Field value + real, dimension(:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: position !< Grid positioning flag - real, optional, intent(in) :: scale !< Rescale factor + 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] logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored !! as 4d arrays in the file. integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: data_in(:,:) ! Field array on the input grid + real, allocatable :: data_in(:,:) ! Field array on the input grid in arbitrary units [A ~> a] turns = MOM_domain%turns if (turns == 0) then @@ -2018,7 +2038,7 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ 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 + real, dimension(:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] integer, dimension(:), intent(in) :: start !< Starting index for each axis. !! In 2d, start(3:4) must be 1. integer, dimension(:), intent(in) :: nread !< Number of values to read along each axis. @@ -2026,12 +2046,14 @@ subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_ 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 !< Rescale factor + 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 + real, allocatable :: data_in(:,:) ! Field array on the input grid in arbitrary units [A ~> a] qturns = 0 if (present(turns)) qturns = modulo(turns, 4) @@ -2056,17 +2078,19 @@ subroutine MOM_read_data_3d(filename, fieldname, data, MOM_Domain, & timelevel, position, scale, global_file, file_may_be_4d) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:,:), intent(inout) :: data !< Field value + real, dimension(:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: position !< Grid positioning flag - real, optional, intent(in) :: scale !< Rescale factor + 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] logical, optional, intent(in) :: global_file !< If true, read from a single file logical, optional, intent(in) :: file_may_be_4d !< If true, fields may be stored !! as 4d arrays in the file. integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: data_in(:,:,:) ! Field array on the input grid + real, allocatable :: data_in(:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] turns = MOM_domain%turns if (turns == 0) then @@ -2091,15 +2115,17 @@ subroutine MOM_read_data_4d(filename, fieldname, data, MOM_Domain, & timelevel, position, scale, global_file) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, dimension(:,:,:,:), intent(inout) :: data !< Field value + real, dimension(:,:,:,:), intent(inout) :: data !< Field value in arbitrary units [A ~> a] type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: position !< Grid positioning flag - real, optional, intent(in) :: scale !< Rescale factor + 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] logical, optional, intent(in) :: global_file !< If true, read from a single file integer :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: data_in(:,:,:,:) ! Field array on the input grid + real, allocatable :: data_in(:,:,:,:) ! Field array on the input grid in arbitrary units [A ~> a] turns = MOM_domain%turns @@ -2127,16 +2153,18 @@ subroutine MOM_read_vector_2d(filename, u_fieldname, v_fieldname, u_data, v_data character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: u_fieldname !< Field variable name in u character(len=*), intent(in) :: v_fieldname !< Field variable name in v - real, dimension(:,:), intent(inout) :: u_data !< Field value in u - real, dimension(:,:), intent(inout) :: v_data !< Field value in v + real, dimension(:,:), intent(inout) :: u_data !< Field value at u points in arbitrary units [A ~> a] + real, dimension(:,:), intent(inout) :: v_data !< Field value at v points in arbitrary units [A ~> a] type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: stagger !< Grid staggering flag logical, optional, intent(in) :: scalar_pair !< True if tuple is not a vector - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the vector 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 :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: u_data_in(:,:), v_data_in(:,:) ! [uv] on the input grid + real, allocatable :: u_data_in(:,:), v_data_in(:,:) ! [uv] on the input grid in arbitrary units [A ~> a] turns = MOM_Domain%turns if (turns == 0) then @@ -2168,16 +2196,18 @@ subroutine MOM_read_vector_3d(filename, u_fieldname, v_fieldname, u_data, v_data character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: u_fieldname !< Field variable name in u character(len=*), intent(in) :: v_fieldname !< Field variable name in v - real, dimension(:,:,:), intent(inout) :: u_data !< Field value in u - real, dimension(:,:,:), intent(inout) :: v_data !< Field value in v + real, dimension(:,:,:), intent(inout) :: u_data !< Field value in u in arbitrary units [A ~> a] + real, dimension(:,:,:), intent(inout) :: v_data !< Field value in v in arbitrary units [A ~> a] type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel !< Time level to read in file integer, optional, intent(in) :: stagger !< Grid staggering flag logical, optional, intent(in) :: scalar_pair !< True if tuple is not a vector - real, optional, intent(in) :: scale !< Rescale factor + real, optional, intent(in) :: scale !< A scaling factor that the vector 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 :: turns ! Number of quarter-turns from input to model grid - real, allocatable :: u_data_in(:,:,:), v_data_in(:,:,:) ! [uv] on the input grid + real, allocatable :: u_data_in(:,:,:), v_data_in(:,:,:) ! [uv] on the input grid in arbitrary units [A ~> a] turns = MOM_Domain%turns if (turns == 0) then @@ -2208,16 +2238,18 @@ subroutine MOM_write_field_legacy_4d(IO_handle, field_md, MOM_domain, field, tst type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value in the units used in the file [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output - real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units or rescaled - real :: scale_fac ! A scaling factor to use before writing the array + real, allocatable :: field_rot(:,:,:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) @@ -2243,16 +2275,19 @@ subroutine MOM_write_field_legacy_3d(IO_handle, field_md, MOM_domain, field, tst type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) - real, optional, intent(in) :: fill_value !< Missing data fill value + real, optional, intent(in) :: fill_value !< Missing data fill value in the units used in the file [a] integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output - real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units or rescaled - real :: scale_fac ! A scaling factor to use before writing the array + + real, allocatable :: field_rot(:,:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) @@ -2278,16 +2313,19 @@ subroutine MOM_write_field_legacy_2d(IO_handle, field_md, MOM_domain, field, tst type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata type(MOM_domain_type), intent(in) :: MOM_domain !< The MOM_Domain that describes the decomposition - real, dimension(:,:), intent(inout) :: field !< Unrotated field to write - real, optional, intent(in) :: tstamp !< Model timestamp + real, dimension(:,:), intent(inout) :: field !< Unrotated field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] integer, optional, intent(in) :: tile_count !< PEs per tile (default: 1) real, optional, intent(in) :: fill_value !< Missing data fill value integer, optional, intent(in) :: turns !< Number of quarter-turns to rotate the data - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output - real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units - real :: scale_fac ! A scaling factor to use before writing the array + + real, allocatable :: field_rot(:,:) ! A rotated version of field, with the same units [a] or + ! rescaled [A ~> a] then [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: qturns ! The number of quarter turns through which to rotate field qturns = 0 ; if (present(turns)) qturns = modulo(turns, 4) @@ -2311,14 +2349,16 @@ end subroutine MOM_write_field_legacy_2d subroutine MOM_write_field_legacy_1d(IO_handle, field_md, field, tstamp, fill_value, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, dimension(:), intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written + real, dimension(:), intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output - real, dimension(:), allocatable :: array ! A rescaled copy of field - real :: scale_fac ! A scaling factor to use before writing the array + + real, dimension(:), allocatable :: array ! A rescaled copy of field [a] + real :: scale_fac ! A scaling factor to use before writing the array [a A-1 ~> 1] integer :: i scale_fac = 1.0 ; if (present(scale)) scale_fac = scale @@ -2341,12 +2381,14 @@ end subroutine MOM_write_field_legacy_1d subroutine MOM_write_field_legacy_0d(IO_handle, field_md, field, tstamp, fill_value, scale) type(file_type), intent(inout) :: IO_handle !< Handle for a file that is open for writing type(fieldtype), intent(in) :: field_md !< Field type with metadata - real, intent(in) :: field !< Field to write - real, optional, intent(in) :: tstamp !< Model timestamp - real, optional, intent(in) :: fill_value !< Missing data fill value - real, optional, intent(in) :: scale !< A scaling factor that the field is - !! multiplied by before it is written - real :: scaled_val ! A rescaled copy of field + real, intent(in) :: field !< Field to write in arbitrary units [A ~> a] + real, optional, intent(in) :: tstamp !< Model timestamp, often in [days] + real, optional, intent(in) :: fill_value !< Missing data fill value [a] + real, optional, intent(in) :: scale !< A scaling factor that the field is multiplied by before + !! it is written [a A-1 ~> 1], for example to convert it + !! from its internal units to the desired units for output + + real :: scaled_val ! A rescaled copy of field [a] scaled_val = field if (present(scale)) scaled_val = scale*field @@ -2673,9 +2715,9 @@ subroutine get_var_axes_info(filename, fieldname, axes_info) character(len=128) :: dim_name(4) integer, dimension(1) :: start, count !! cartesian axis data - real, allocatable, dimension(:) :: x - real, allocatable, dimension(:) :: y - real, allocatable, dimension(:) :: z + real, allocatable, dimension(:) :: x ! x-axis labels, often [degrees_E] or [km] or [m] + real, allocatable, dimension(:) :: y ! y-axis labels, often [degrees_N] or [km] or [m] + real, allocatable, dimension(:) :: z ! vertical axis labels [various], often [m] or [kg m-3] call open_file_to_read(filename, ncid, success=success) From 15ce275f80bc4e5b0375966dfb47969ecbd9afb3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 09:13:15 -0500 Subject: [PATCH 178/629] Document units of arguments in MOM_restart Added schematic unit descriptions to the comments describing the arguments to the MOM_restart routines, and clearly indicating when they work with rescaled variables. Only comments are changed, and all answers are bitwise identical. --- src/framework/MOM_restart.F90 | 125 ++++++++++++++++++++++------------ 1 file changed, 81 insertions(+), 44 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 2939a7d907..24ba0fa76b 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -27,29 +27,36 @@ module MOM_restart public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete, register_restart_pair +! 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 functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + !> A type for making arrays of pointers to 4-d arrays type p4d - real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array + real, dimension(:,:,:,:), pointer :: p => NULL() !< A pointer to a 4d array in arbitrary rescaled units [A ~> a] end type p4d !> A type for making arrays of pointers to 3-d arrays type p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3d array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3d array in arbitrary rescaled units [A ~> a] end type p3d !> A type for making arrays of pointers to 2-d arrays type p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2d array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2d array in arbitrary rescaled units [A ~> a] end type p2d !> A type for making arrays of pointers to 1-d arrays type p1d - real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array + real, dimension(:), pointer :: p => NULL() !< A pointer to a 1d array in arbitrary rescaled units [A ~> a] end type p1d !> A type for making arrays of pointers to scalars type p0d - real, pointer :: p => NULL() !< A pointer to a scalar + real, pointer :: p => NULL() !< A pointer to a scalar in arbitrary rescaled units [A ~> a] end type p0d !> A structure with information about a single restart field @@ -62,8 +69,8 @@ module MOM_restart character(len=32) :: var_name !< A name by which a variable may be queried. real :: conv = 1.0 !< A factor by which a restart field should be multiplied before it !! is written to a restart file, usually to convert it to MKS or - !! other standard units. When read, the restart field is multiplied - !! by the Adcroft reciprocal of this factor. + !! other standard units [a A-1 ~> 1]. When read, the restart field + !! is multiplied by the Adcroft reciprocal of this factor. end type field_restart !> A structure to store information about restart fields that are no longer used @@ -171,12 +178,13 @@ end subroutine register_restart_field_as_obsolete subroutine register_restart_field_ptr3d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -208,12 +216,13 @@ end subroutine register_restart_field_ptr3d subroutine register_restart_field_ptr4d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -245,12 +254,13 @@ end subroutine register_restart_field_ptr4d subroutine register_restart_field_ptr2d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -281,12 +291,13 @@ end subroutine register_restart_field_ptr2d !> Register a 1-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr1d(f_ptr, var_desc, mandatory, CS, conversion) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -317,12 +328,13 @@ end subroutine register_restart_field_ptr1d !> Register a 0-d field for restarts, providing the metadata in a structure subroutine register_restart_field_ptr0d(f_ptr, var_desc, mandatory, CS, conversion) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: var_desc !< A structure with metadata about this variable logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "register_restart_field: Module must be initialized before it is used.") @@ -355,13 +367,15 @@ end subroutine register_restart_field_ptr0d subroutine register_restart_pair_ptr2d(a_ptr, b_ptr, a_desc, b_desc, & mandatory, CS, conversion) real, dimension(:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] real, dimension(:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: a_desc !< First field descriptor type(vardesc), intent(in) :: b_desc !< Second field descriptor logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. call lock_check(CS, a_desc) @@ -378,14 +392,16 @@ end subroutine register_restart_pair_ptr2d !> Register a pair of rotationally equivalent 3d restart fields subroutine register_restart_pair_ptr3d(a_ptr, b_ptr, a_desc, b_desc, & mandatory, CS, conversion) - real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer - real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer + real, dimension(:,:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] + real, dimension(:,:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: a_desc !< First field descriptor type(vardesc), intent(in) :: b_desc !< Second field descriptor logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. call lock_check(CS, a_desc) @@ -403,13 +419,15 @@ end subroutine register_restart_pair_ptr3d subroutine register_restart_pair_ptr4d(a_ptr, b_ptr, a_desc, b_desc, & mandatory, CS, conversion) real, dimension(:,:,:,:), target, intent(in) :: a_ptr !< First field pointer + !! in arbitrary rescaled units [A ~> a] real, dimension(:,:,:,:), target, intent(in) :: b_ptr !< Second field pointer + !! in arbitrary rescaled units [A ~> a] type(vardesc), intent(in) :: a_desc !< First field descriptor type(vardesc), intent(in) :: b_desc !< Second field descriptor logical, intent(in) :: mandatory !< If true, abort if field is missing type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control structure real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. call lock_check(CS, a_desc) @@ -430,6 +448,7 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units hor_grid, z_grid, t_grid) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -437,7 +456,7 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -462,6 +481,7 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units hor_grid, z_grid, t_grid) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -469,7 +489,7 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -494,6 +514,7 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units hor_grid, z_grid, t_grid) real, dimension(:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -501,7 +522,7 @@ subroutine register_restart_field_2d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, '1' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -528,6 +549,7 @@ end subroutine register_restart_field_2d subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units, conversion, & hor_grid, z_grid, t_grid) real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -535,7 +557,7 @@ subroutine register_restart_field_1d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, '1' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent @@ -562,6 +584,7 @@ end subroutine register_restart_field_1d subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units, conversion, & t_grid) real, target, intent(in) :: f_ptr !< A pointer to the field to be read or written + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: name !< variable name to be used in the restart file logical, intent(in) :: mandatory !< If true, the run will abort if this field is not !! successfully read from the restart file. @@ -569,7 +592,7 @@ subroutine register_restart_field_0d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: longname !< variable long name character(len=*), optional, intent(in) :: units !< variable units real, optional, intent(in) :: conversion !< A factor to multiply a restart field by - !! before it is written, 1 by default. + !! before it is written [a A-1 ~> 1], 1 by default. character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent type(vardesc) :: vd @@ -622,7 +645,7 @@ end function query_initialized_name !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_0d(f_ptr, CS) result(query_initialized) - real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried + real, target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -646,7 +669,7 @@ end function query_initialized_0d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_1d(f_ptr, CS) result(query_initialized) - real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried + real, dimension(:), target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -671,7 +694,7 @@ end function query_initialized_1d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_2d(f_ptr, CS) result(query_initialized) real, dimension(:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -696,7 +719,7 @@ end function query_initialized_2d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_3d(f_ptr, CS) result(query_initialized) real, dimension(:,:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -721,7 +744,7 @@ end function query_initialized_3d !> Indicate whether the field pointed to by f_ptr has been initialized from a restart file. function query_initialized_4d(f_ptr, CS) result(query_initialized) real, dimension(:,:,:,:), & - target, intent(in) :: f_ptr !< A pointer to the field that is being queried + target, intent(in) :: f_ptr !< A pointer to the field that is being queried [arbitrary] type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -746,7 +769,7 @@ end function query_initialized_4d !> Indicate whether the field stored in f_ptr or with the specified variable !! name has been initialized from a restart file. function query_initialized_0d_name(f_ptr, name, CS) result(query_initialized) - real, target, intent(in) :: f_ptr !< The field that is being queried + real, target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -779,7 +802,7 @@ end function query_initialized_0d_name !! name has been initialized from a restart file. function query_initialized_1d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:), & - target, intent(in) :: f_ptr !< The field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -812,7 +835,7 @@ end function query_initialized_1d_name !! name has been initialized from a restart file. function query_initialized_2d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:,:), & - target, intent(in) :: f_ptr !< The field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -845,7 +868,7 @@ end function query_initialized_2d_name !! name has been initialized from a restart file. function query_initialized_3d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:,:,:), & - target, intent(in) :: f_ptr !< The field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -878,7 +901,7 @@ end function query_initialized_3d_name !! name has been initialized from a restart file. function query_initialized_4d_name(f_ptr, name, CS) result(query_initialized) real, dimension(:,:,:,:), & - target, intent(in) :: f_ptr !< The field that is being queried + target, intent(in) :: f_ptr !< The field that is being queried [arbitrary] character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct logical :: query_initialized @@ -929,7 +952,7 @@ end subroutine set_initialized_name !> Record that the array in f_ptr with the given name has been initialized. subroutine set_initialized_0d_name(f_ptr, name, CS) - real, target, intent(in) :: f_ptr !< The variable that has been initialized + real, target, intent(in) :: f_ptr !< The variable that has been initialized [arbitrary] character(len=*), intent(in) :: name !< The name of the field that has been initialized type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct @@ -954,7 +977,7 @@ end subroutine set_initialized_0d_name !> Record that the array in f_ptr with the given name has been initialized. subroutine set_initialized_1d_name(f_ptr, name, CS) real, dimension(:), & - target, intent(in) :: f_ptr !< The array that has been initialized + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] character(len=*), intent(in) :: name !< The name of the field that has been initialized type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct @@ -979,7 +1002,7 @@ end subroutine set_initialized_1d_name !> Record that the array in f_ptr with the given name has been initialized. subroutine set_initialized_2d_name(f_ptr, name, CS) real, dimension(:,:), & - target, intent(in) :: f_ptr !< The array that has been initialized + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] character(len=*), intent(in) :: name !< The name of the field that has been initialized type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct @@ -1004,7 +1027,7 @@ end subroutine set_initialized_2d_name !> Record that the array in f_ptr with the given name has been initialized. subroutine set_initialized_3d_name(f_ptr, name, CS) real, dimension(:,:,:), & - target, intent(in) :: f_ptr !< The array that has been initialized + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] character(len=*), intent(in) :: name !< The name of the field that has been initialized type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct @@ -1029,7 +1052,7 @@ end subroutine set_initialized_3d_name !> Record that the array in f_ptr with the given name has been initialized. subroutine set_initialized_4d_name(f_ptr, name, CS) real, dimension(:,:,:,:), & - target, intent(in) :: f_ptr !< The array that has been initialized + target, intent(in) :: f_ptr !< The array that has been initialized [arbitrary] character(len=*), intent(in) :: name !< The name of the field that has been initialized type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct @@ -1058,6 +1081,7 @@ end subroutine set_initialized_4d_name subroutine only_read_restart_field_4d(varname, f_ptr, G, CS, position, filename, directory, success, scale) character(len=*), intent(in) :: varname !< The variable name to be used in the restart file real, dimension(:,:,:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct integer, optional, intent(in) :: position !< A coded integer indicating the horizontal @@ -1067,6 +1091,8 @@ subroutine only_read_restart_field_4d(varname, f_ptr, G, CS, position, filename, character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. logical, optional, intent(out) :: success !< True if the field was read successfully real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field ! Local variables character(len=:), allocatable :: file_path ! The full path to the file with the variable @@ -1087,6 +1113,7 @@ end subroutine only_read_restart_field_4d subroutine only_read_restart_field_3d(varname, f_ptr, G, CS, position, filename, directory, success, scale) character(len=*), intent(in) :: varname !< The variable name to be used in the restart file real, dimension(:,:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct integer, optional, intent(in) :: position !< A coded integer indicating the horizontal @@ -1096,6 +1123,8 @@ subroutine only_read_restart_field_3d(varname, f_ptr, G, CS, position, filename, character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. logical, optional, intent(out) :: success !< True if the field was read successfully real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field ! Local variables character(len=:), allocatable :: file_path ! The full path to the file with the variable @@ -1116,6 +1145,7 @@ end subroutine only_read_restart_field_3d subroutine only_read_restart_field_2d(varname, f_ptr, G, CS, position, filename, directory, success, scale) character(len=*), intent(in) :: varname !< The variable name to be used in the restart file real, dimension(:,:), intent(inout) :: f_ptr !< The array for the field to be read + !! in arbitrary rescaled units [A ~> a] type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct integer, optional, intent(in) :: position !< A coded integer indicating the horizontal @@ -1125,6 +1155,8 @@ subroutine only_read_restart_field_2d(varname, f_ptr, G, CS, position, filename, character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. logical, optional, intent(out) :: success !< True if the field was read successfully real, optional, intent(in) :: scale !< A factor by which the field will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field ! Local variables character(len=:), allocatable :: file_path ! The full path to the file with the variable @@ -1146,7 +1178,9 @@ end subroutine only_read_restart_field_2d subroutine only_read_restart_pair_3d(a_ptr, b_ptr, a_name, b_name, G, CS, & stagger, filename, directory, success, scale) real, dimension(:,:,:), intent(inout) :: a_ptr !< The array for the first field to be read + !! in arbitrary rescaled units [A ~> a] real, dimension(:,:,:), intent(inout) :: b_ptr !< The array for the second field to be read + !! in arbitrary rescaled units [A ~> a] character(len=*), intent(in) :: a_name !< The first variable name to be used in the restart file character(len=*), intent(in) :: b_name !< The second variable name to be used in the restart file type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -1157,7 +1191,9 @@ subroutine only_read_restart_pair_3d(a_ptr, b_ptr, a_name, b_name, G, CS, & !! character 'r' to read automatically named files character(len=*), optional, intent(in) :: directory !< The directory in which to seek restart files. logical, optional, intent(out) :: success !< True if the field was read successfully - real, optional, intent(in) :: scale !< A factor by which the field will be scaled + real, optional, intent(in) :: scale !< A factor by which the fields will be scaled + !! [A a-1 ~> 1] to convert from the units in + !! the file to the internal units of this field ! Local variables character(len=:), allocatable :: file_path_a ! The full path to the file with the first variable @@ -1277,8 +1313,8 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. - real :: conv ! Shorthand for the conversion factor - real :: restart_time + real :: conv ! Shorthand for the conversion factor [a A-1 ~> 1] + real :: restart_time ! The model time at whic the restart file is being written [days] character(len=32) :: filename_appendix = '' ! Appendix to filename for ensemble runs integer :: length ! The length of a text string. integer(kind=8) :: check_val(CS%max_fields,1) @@ -1456,8 +1492,9 @@ subroutine restore_state(filename, directory, day, G, CS) type(MOM_restart_CS), intent(inout) :: CS !< MOM restart control struct ! Local variables - real :: scale ! A scaling factor for reading a field - real :: conv ! The output conversion factor for writing a field + real :: scale ! A scaling factor for reading a field [A a-1 ~> 1] to convert + ! from the units in the file to the internal units of this field + real :: conv ! The output conversion factor for writing a field [a A-1 ~> 1] character(len=512) :: mesg ! A message for warnings. character(len=80) :: varname ! A variable's name. integer :: num_file ! The number of files (restart files and others @@ -1471,8 +1508,8 @@ subroutine restore_state(filename, directory, day, G, CS) logical :: unit_is_global(CS%max_fields) ! True if the file is global. character(len=8) :: hor_grid ! Variable grid info. - real :: t1, t2 ! Two times. - real, allocatable :: time_vals(:) + real :: t1, t2 ! Two times from the start of different files [days]. + real, allocatable :: time_vals(:) ! Times from a file extracted with getl_file_times [days] type(MOM_field), allocatable :: fields(:) logical :: is_there_a_checksum ! Is there a valid checksum that should be checked. integer(kind=8) :: checksum_file ! The checksum value recorded in the input file. From 6c34e7fbfefc0f4afd84f2abe25030563dbfe608 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 09:14:12 -0500 Subject: [PATCH 179/629] Document units of arguments in MOM_array_transform Added schematic unit descriptions to the comments describing the arguments to the MOM_array_transform routines, and clearly indicating that they work with variables with arbitrary units. Only comments are changed, and all answers are bitwise identical. --- src/framework/MOM_array_transform.F90 | 64 +++++++++++++-------------- 1 file changed, 32 insertions(+), 32 deletions(-) diff --git a/src/framework/MOM_array_transform.F90 b/src/framework/MOM_array_transform.F90 index d524f618a3..66c9925f11 100644 --- a/src/framework/MOM_array_transform.F90 +++ b/src/framework/MOM_array_transform.F90 @@ -71,9 +71,9 @@ module MOM_array_transform !> Rotate the elements of a 2d real array along first and second axes. subroutine rotate_array_real_2d(A_in, turns, A) - real, intent(in) :: A_in(:,:) !< Unrotated array + real, intent(in) :: A_in(:,:) !< Unrotated array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:) !< Rotated array + real, intent(out) :: A(:,:) !< Rotated array [arbitrary] integer :: m, n @@ -96,9 +96,9 @@ end subroutine rotate_array_real_2d !> Rotate the elements of a 3d real array along first and second axes. subroutine rotate_array_real_3d(A_in, turns, A) - real, intent(in) :: A_in(:,:,:) !< Unrotated array + real, intent(in) :: A_in(:,:,:) !< Unrotated array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:) !< Rotated array + real, intent(out) :: A(:,:,:) !< Rotated array [arbitrary] integer :: k @@ -110,9 +110,9 @@ end subroutine rotate_array_real_3d !> Rotate the elements of a 4d real array along first and second axes. subroutine rotate_array_real_4d(A_in, turns, A) - real, intent(in) :: A_in(:,:,:,:) !< Unrotated array + real, intent(in) :: A_in(:,:,:,:) !< Unrotated array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:,:) !< Rotated array + real, intent(out) :: A(:,:,:,:) !< Rotated array [arbitrary] integer :: n @@ -174,11 +174,11 @@ end subroutine rotate_array_logical !> Rotate the elements of a 2d real array pair along first and second axes. subroutine rotate_array_pair_real_2d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:) !< Unrotated scalar array pair - real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair + real, intent(in) :: A_in(:,:) !< Unrotated scalar array pair [arbitrary] + real, intent(in) :: B_in(:,:) !< Unrotated scalar array pair [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:) !< Rotated scalar array pair - real, intent(out) :: B(:,:) !< Rotated scalar array pair + real, intent(out) :: A(:,:) !< Rotated scalar array pair [arbitrary] + real, intent(out) :: B(:,:) !< Rotated scalar array pair [arbitrary] if (modulo(turns, 2) /= 0) then call rotate_array(B_in, turns, A) @@ -192,11 +192,11 @@ end subroutine rotate_array_pair_real_2d !> Rotate the elements of a 3d real array pair along first and second axes. subroutine rotate_array_pair_real_3d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:,:) !< Unrotated scalar array pair - real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair + real, intent(in) :: A_in(:,:,:) !< Unrotated scalar array pair [arbitrary] + real, intent(in) :: B_in(:,:,:) !< Unrotated scalar array pair [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:) !< Rotated scalar array pair - real, intent(out) :: B(:,:,:) !< Rotated scalar array pair + real, intent(out) :: A(:,:,:) !< Rotated scalar array pair [arbitrary] + real, intent(out) :: B(:,:,:) !< Rotated scalar array pair [arbitrary] integer :: k @@ -227,11 +227,11 @@ end subroutine rotate_array_pair_integer !> Rotate the elements of a 2d real vector along first and second axes. subroutine rotate_vector_real_2d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:) !< First component of unrotated vector - real, intent(in) :: B_in(:,:) !< Second component of unrotated vector + real, intent(in) :: A_in(:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:) !< Second component of unrotated vector [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:) !< First component of rotated vector - real, intent(out) :: B(:,:) !< Second component of unrotated vector + real, intent(out) :: A(:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:) !< Second component of unrotated vector [arbitrary] call rotate_array_pair(A_in, B_in, turns, A, B) @@ -245,11 +245,11 @@ end subroutine rotate_vector_real_2d !> Rotate the elements of a 3d real vector along first and second axes. subroutine rotate_vector_real_3d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:,:) !< First component of unrotated vector - real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector + real, intent(in) :: A_in(:,:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:,:) !< Second component of unrotated vector [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:) !< First component of rotated vector - real, intent(out) :: B(:,:,:) !< Second component of unrotated vector + real, intent(out) :: A(:,:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:,:) !< Second component of unrotated vector [arbitrary] integer :: k @@ -261,11 +261,11 @@ end subroutine rotate_vector_real_3d !> Rotate the elements of a 4d real vector along first and second axes. subroutine rotate_vector_real_4d(A_in, B_in, turns, A, B) - real, intent(in) :: A_in(:,:,:,:) !< First component of unrotated vector - real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector + real, intent(in) :: A_in(:,:,:,:) !< First component of unrotated vector [arbitrary] + real, intent(in) :: B_in(:,:,:,:) !< Second component of unrotated vector [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, intent(out) :: A(:,:,:,:) !< First component of rotated vector - real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector + real, intent(out) :: A(:,:,:,:) !< First component of rotated vector [arbitrary] + real, intent(out) :: B(:,:,:,:) !< Second component of unrotated vector [arbitrary] integer :: n @@ -280,9 +280,9 @@ end subroutine rotate_vector_real_4d subroutine allocate_rotated_array_real_2d(A_in, lb, turns, A) ! NOTE: lb must be declared before A_in integer, intent(in) :: lb(2) !< Lower index bounds of A_in - real, intent(in) :: A_in(lb(1):, lb(2):) !< Reference array + real, intent(in) :: A_in(lb(1):, lb(2):) !< Reference array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, allocatable, intent(inout) :: A(:,:) !< Array on rotated index + real, allocatable, intent(inout) :: A(:,:) !< Array on rotated index [arbitrary] integer :: ub(2) @@ -300,9 +300,9 @@ end subroutine allocate_rotated_array_real_2d subroutine allocate_rotated_array_real_3d(A_in, lb, turns, A) ! NOTE: lb must be declared before A_in integer, intent(in) :: lb(3) !< Lower index bounds of A_in - real, intent(in) :: A_in(lb(1):, lb(2):, lb(3):) !< Reference array + real, intent(in) :: A_in(lb(1):, lb(2):, lb(3):) !< Reference array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index + real, allocatable, intent(inout) :: A(:,:,:) !< Array on rotated index [arbitrary] integer :: ub(3) @@ -320,9 +320,9 @@ end subroutine allocate_rotated_array_real_3d subroutine allocate_rotated_array_real_4d(A_in, lb, turns, A) ! NOTE: lb must be declared before A_in integer, intent(in) :: lb(4) !< Lower index bounds of A_in - real, intent(in) :: A_in(lb(1):,lb(2):,lb(3):,lb(4):) !< Reference array + real, intent(in) :: A_in(lb(1):,lb(2):,lb(3):,lb(4):) !< Reference array [arbitrary] integer, intent(in) :: turns !< Number of quarter turns - real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index + real, allocatable, intent(inout) :: A(:,:,:,:) !< Array on rotated index [arbitrary] integer:: ub(4) From 94f97a56975b8234a00609c30c5e0f2bbec24bef Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 09:14:41 -0500 Subject: [PATCH 180/629] Revise argument units in MOM_horizontal_regridding Revised the schematic unit descriptions to the comments describing the arguments to the MOM_horizontal_regridding routines, to clearly indicate when they work with rescaled variables. Only comments are changed, and all answers are bitwise identical. --- src/framework/MOM_horizontal_regridding.F90 | 106 ++++++++++++-------- 1 file changed, 62 insertions(+), 44 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index c2fe772571..83e7718311 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -33,22 +33,30 @@ module MOM_horizontal_regridding module procedure horiz_interp_and_extrap_tracer_fms_id end interface +! 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 functions in this module work with variables with arbitrary units, in which case the +! arbitrary rescaled units are indicated with [A ~> a], while the unscaled units are just [a]. + contains !> Write to the terminal some basic statistics about the k-th level of an array subroutine myStats(array, missing, is, ie, js, je, k, mesg, scale) - real, dimension(:,:), intent(in) :: array !< input array [A] - real, intent(in) :: missing !< missing value [A] + real, dimension(:,:), intent(in) :: array !< input array in arbitrary units [A ~> a] + real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] integer, intent(in) :: is !< Start index in i integer, intent(in) :: ie !< End index in i integer, intent(in) :: js !< Start index in j integer, intent(in) :: je !< End index in j integer, intent(in) :: k !< Level to calculate statistics for character(len=*), intent(in) :: mesg !< Label to use in message - real, optional, intent(in) :: scale !< A scaling factor for output. + real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] ! Local variables - real :: minA, maxA ! Minimum and maximum vvalues in the array [A] - real :: scl ! A factor for undoing any scaling of the array statistics for output. + real :: minA ! Minimum value in the array in the arbitrary units of the input array [A ~> a] + real :: maxA ! Maximum value in the array in the arbitrary units of the input array [A ~> a] + real :: scl ! A factor for undoing any scaling of the array statistics for output [a A-1 ~> 1] integer :: i,j logical :: found character(len=120) :: lMesg @@ -85,7 +93,7 @@ end subroutine myStats subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, answer_date) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), & - intent(inout) :: aout !< The array with missing values to fill [A] + intent(inout) :: aout !< The array with missing values to fill [arbitrary] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: good !< Valid data mask for incoming array !! (1==good data; 0==missing data) [nondim]. @@ -93,9 +101,9 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, intent(in) :: fill !< Same shape array of points which need !! filling (1==fill;0==dont fill) [nondim] real, dimension(SZI_(G),SZJ_(G)), & - intent(in) :: prev !< First guess where isolated holes exist [A] + intent(in) :: prev !< First guess where isolated holes exist [arbitrary] real, intent(in) :: acrit !< A minimal value for deltas between iterations that - !! determines when the smoothing has converged [A]. + !! determines when the smoothing has converged [arbitrary]. integer, optional, intent(in) :: num_pass !< The maximum number of iterations real, optional, intent(in) :: relc !< A relaxation coefficient for Laplacian [nondim] logical, optional, intent(in) :: debug !< If true, write verbose debugging messages. @@ -104,13 +112,13 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, !! as the code did in late 2018, while later versions !! add parentheses for rotational symmetry. - real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in [A] - real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing [A] + real, dimension(SZI_(G),SZJ_(G)) :: a_filled ! The aout with missing values filled in [arbitrary] + real, dimension(SZI_(G),SZJ_(G)) :: a_chg ! The change in aout due to an iteration of smoothing [arbitrary] real, dimension(SZI_(G),SZJ_(G)) :: fill_pts ! 1 for points that still need to be filled [nondim] real, dimension(SZI_(G),SZJ_(G)) :: good_ ! The values that are valid for the current iteration [nondim] real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration [nondim] - real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [A] + real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [arbitrary] real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values [nondim] real :: ngood ! The number of valid values in neighboring points [nondim] real :: nfill ! The remaining number of points to fill [nondim] @@ -262,7 +270,8 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z !< Allocatable tracer array on the horizontal - !! model grid and input-file vertical levels. [CU ~> conc] + !! model grid and input-file vertical levels + !! in arbitrary units [A ~> a] real, allocatable, dimension(:,:,:), intent(out) :: mask_z !< Allocatable tracer mask array on the horizontal !! model grid and input-file vertical levels [nondim] @@ -272,9 +281,9 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr !< Cell grid edge values for input data [Z ~> m] real, intent(out) :: missing_value !< The missing value in the returned array, scaled !! to avoid accidentally having valid values match - !! missing values [CU ~> conc] + !! missing values in the same units as tr_z [A ~> a] real, intent(in) :: scale !< Scaling factor for tracer into the internal - !! units of the model [CU conc-1 ~> 1] + !! units of the model for the units in the file [A a-1 ~> 1] logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions real, optional, intent(in) :: m_to_Z !< A conversion factor from meters to the units @@ -287,19 +296,21 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr !! extrapolation is performed by this routine real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations !! between smoothing iterations that determines when to - !! stop iterating [CU ~> conc] + !! stop iterating in the same units as tr_z [A ~> a] integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. !! Dates before 20190101 give the same answers !! as the code did in late 2018, while later versions !! add parentheses for rotational symmetry. ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums 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 [conc] then [CU ~> conc] + !! 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 [conc] then [CU ~> conc] + !! interpreted [a] then [A ~> a] real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid [nondim] real :: PI_180 ! A conversion factor from degrees to radians @@ -312,10 +323,10 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] real :: max_lat ! The maximum latitude on the input grid [degreesN] - real :: pole ! The sum of tracer values at the pole [conc] + real :: pole ! The sum of tracer values at the pole [a] real :: max_depth ! The maximum depth of the ocean [Z ~> m] real :: npole ! The number of points contributing to the pole value [nondim] - real :: missing_val_in ! The missing value in the input field [conc] + real :: missing_val_in ! The missing value in the input field [a] real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] real :: add_offset, scale_factor ! File-specific conversion factors. integer :: ans_date ! The vintage of the expressions and order of arithmetic to use @@ -329,17 +340,17 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr integer :: isd, ied, jsd, jed ! data domain indices integer :: id_clock_read logical :: debug=.false. - real :: I_scale ! The inverse of the scale factor for diagnostic output [conc CU-1 ~> 1] + real :: I_scale ! The inverse of the scale factor for diagnostic output [a A-1 ~> 1] real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing - ! iterations that determines when to stop iterating [CU ~> conc] + ! iterations that determines when to stop iterating [A ~> a] real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] - real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [A ~> a] real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [CU ~> conc] - real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [A ~> a] real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] @@ -597,7 +608,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, type(ocean_grid_type), intent(inout) :: G !< Grid object real, allocatable, dimension(:,:,:), intent(out) :: tr_z !< Allocatable tracer array on the horizontal - !! model grid and input-file vertical levels [CU ~> conc] + !! model grid and input-file vertical levels + !! in arbitrary units [A ~> a] real, allocatable, dimension(:,:,:), intent(out) :: mask_z !< Allocatable tracer mask array on the horizontal !! model grid and input-file vertical levels [nondim] @@ -607,9 +619,9 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, !< Cell grid edge values for input data [Z ~> m] real, intent(out) :: missing_value !< The missing value in the returned array, scaled !! to avoid accidentally having valid values match - !! missing values [CU ~> conc] + !! missing values, in the same arbitrary units as tr_z [A ~> a] real, intent(in) :: scale !< Scaling factor for tracer into the internal - !! units of the model [CU conc-1 ~> 1] + !! units of the model [A a-1 ~> 1] logical, optional, intent(in) :: homogenize !< If present and true, horizontally homogenize data !! to produce perfectly "flat" initial conditions logical, optional, intent(in) :: spongeOngrid !< If present and true, the sponge data are on the model grid @@ -620,21 +632,23 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, !! add parentheses for rotational symmetry. real, optional, intent(in) :: tr_iter_tol !< The tolerance for changes in tracer concentrations !! between smoothing iterations that determines when to - !! stop iterating [CU ~> conc] + !! stop iterating, in the same arbitrary units as tr_z [A ~> a] integer, optional, intent(in) :: answer_date !< The vintage of the expressions in the code. !! Dates before 20190101 give the same answers !! as the code did in late 2018, while later versions !! add parentheses for rotational symmetry. ! Local variables + ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the + ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums 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 [conc] then [CU ~> conc] + !! 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 [conc] then [CU ~> conc] + !! interpreted [a] then [A ~> a] real, dimension(:,:,:), allocatable :: data_in !< A buffer for storing the full 3-d time-interpolated array - !! on the original grid [conc] + !! on the original grid [a] real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid [nondim] real :: PI_180 ! A conversion factor from degrees to radians @@ -646,10 +660,10 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, real, dimension(:), allocatable :: lat_in ! The latitudes in the input file [degreesN] then [radians] real, dimension(:), allocatable :: lat_inp ! The input file latitudes expanded to the pole [degreesN] then [radians] real :: max_lat ! The maximum latitude on the input grid [degreesN] - real :: pole ! The sum of tracer values at the pole [conc] + real :: pole ! The sum of tracer values at the pole [a] real :: max_depth ! The maximum depth of the ocean [Z ~> m] real :: npole ! The number of points contributing to the pole value [nondim] - real :: missing_val_in ! The missing value in the input field [conc] + real :: missing_val_in ! The missing value in the input field [a] real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] logical :: add_np type(horiz_interp_type) :: Interp @@ -662,17 +676,17 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, Time, G, tr_z, mask_z, logical :: debug=.false. logical :: is_ongrid integer :: ans_date ! The vintage of the expressions and order of arithmetic to use - real :: I_scale ! The inverse of the scale factor for diagnostic output [conc CU-1 ~> 1] + real :: I_scale ! The inverse of the scale factor for diagnostic output [a A-1 ~> 1] real :: dtr_iter_stop ! The tolerance for changes in tracer concentrations between smoothing - ! iterations that determines when to stop iterating [CU ~> conc] + ! iterations that determines when to stop iterating [A ~> a] real, dimension(SZI_(G),SZJ_(G)) :: lon_out ! The longitude of points on the model grid [radians] real, dimension(SZI_(G),SZJ_(G)) :: lat_out ! The latitude of points on the model grid [radians] - real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_out ! The tracer on the model grid [A ~> a] real, dimension(SZI_(G),SZJ_(G)) :: mask_out ! The mask on the model grid [nondim] real, dimension(SZI_(G),SZJ_(G)) :: good ! Where the data is valid, this is 1 [nondim] real, dimension(SZI_(G),SZJ_(G)) :: fill ! 1 where the data needs to be filled in [nondim] - real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [CU ~> conc] - real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [CU ~> conc] + real, dimension(SZI_(G),SZJ_(G)) :: tr_outf ! The tracer concentrations after Ice-9 [A ~> a] + real, dimension(SZI_(G),SZJ_(G)) :: tr_prev ! The tracer concentrations in the layer above [A ~> a] real, dimension(SZI_(G),SZJ_(G)) :: good2 ! 1 where the data is valid after Ice-9 [nondim] real, dimension(SZI_(G),SZJ_(G)) :: fill2 ! 1 for points that still need to be filled after Ice-9 [nondim] integer :: turns @@ -900,8 +914,9 @@ end subroutine horiz_interp_and_extrap_tracer_fms_id !> Replace all values of a 2-d field with the weighted average over the valid points. subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) type(ocean_grid_type), intent(inout) :: G !< Ocean grid type - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field !< The tracer on the model grid [A ~> a] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: weight !< The weights for the tracer [B ~> b] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field !< The tracer on the model grid in arbitrary units [A ~> a] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: weight !< The weights for the tracer in arbitrary units that + !! typically differ from those used by field [B ~> b] real, intent(in) :: scale !< A rescaling factor that has been used for the !! variable and has to be undone before the !! reproducing sums [A a-1 ~> 1] @@ -915,6 +930,9 @@ subroutine homogenize_field(field, weight, G, scale, answer_date, wt_unscale) !! reproducing sums [b B-1 ~> 1] ! Local variables + ! In the following comments, [A] and [B] are used to indicate the arbitrary, possibly rescaled + ! units of the input field and the weighting array, while [a] and [b] indicate the corresponding + ! unscaled (e.g., mks) units that can be used with the reproducing sums real, dimension(SZI_(G),SZJ_(G)) :: field_for_Sums ! The field times the weights with the scaling undone [a b] real, dimension(SZI_(G),SZJ_(G)) :: wts_for_Sums ! A copy of the wieghts with the scaling undone [b] real :: var_unscale ! The reciprocal of the scaling factor for the field and weights [a b A-1 B-1 ~> 1] @@ -974,10 +992,10 @@ end subroutine homogenize_field !> Create a 2d-mesh of grid coordinates from 1-d arrays. subroutine meshgrid(x, y, x_T, y_T) - real, dimension(:), intent(in) :: x !< input 1-dimensional vector - real, dimension(:), intent(in) :: y !< input 1-dimensional vector - real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-dimensional array - real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-dimensional array + real, dimension(:), intent(in) :: x !< input 1-dimensional vector [arbitrary] + real, dimension(:), intent(in) :: y !< input 1-dimensional vector [arbitrary] + real, dimension(size(x,1),size(y,1)), intent(inout) :: x_T !< output 2-dimensional array [arbitrary] + real, dimension(size(x,1),size(y,1)), intent(inout) :: y_T !< output 2-dimensional array [arbitrary] integer :: ni, nj, i, j From a3b61c818ea7b14ae7fd962caa2cd103c6075173 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 31 Jan 2023 09:15:04 -0500 Subject: [PATCH 181/629] Document units of invcosh and its argument Document the (nondimensional) units of both real variables in MOM_intrinsic functions. Only comments are changed, and all answers are bitwise identical. --- src/framework/MOM_intrinsic_functions.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index fdda8849ae..2439c628fc 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -13,9 +13,9 @@ module MOM_intrinsic_functions !> Evaluate the inverse cosh, either using a math library or an !! equivalent expression function invcosh(x) - real, intent(in) :: x !< The argument of the inverse of cosh. NaNs will + real, intent(in) :: x !< The argument of the inverse of cosh [nondim]. NaNs will !! occur if x<1, but there is no error checking - real :: invcosh + real :: invcosh ! The inverse of cosh of x [nondim] #ifdef __INTEL_COMPILER invcosh = acosh(x) From 19f683db274f8a70997f75bf744ff757f0cae3bc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 3 Jan 2023 17:39:59 -0500 Subject: [PATCH 182/629] Document units of variables in MOM_energetic_PBL Added or amended comments to document the units of numerous internal variables in MOM_energetic_PBL.F90, and corrected a few spelling errors in comments. Only comments are changed, and all answers are bitwise identical. --- .../vertical/MOM_energetic_PBL.F90 | 107 ++++++++++-------- 1 file changed, 60 insertions(+), 47 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index bd0740ccbd..01885a0484 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -59,7 +59,7 @@ module MOM_energetic_PBL !! returned value from the previous guess or bisection before this. integer :: max_MLD_its !< The maximum number of iterations that can be used to find a !! self-consistent mixed layer depth with Use_MLD_iteration. - real :: MixLenExponent !< Exponent in the mixing length shape-function. + real :: MixLenExponent !< Exponent in the mixing length shape-function [nondim]. !! 1 is law-of-the-wall at top and bottom, !! 2 is more KPP like. real :: MKE_to_TKE_effic !< The efficiency with which mean kinetic energy released by @@ -68,11 +68,11 @@ module MOM_energetic_PBL real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1]. !! If the value is small enough, this should not affect the solution. real :: Ekman_scale_coef !< A nondimensional scaling factor controlling the inhibition of the - !! diffusive length scale by rotation. Making this larger decreases + !! diffusive length scale by rotation [nondim]. Making this larger decreases !! the diffusivity in the planetary boundary layer. real :: transLay_scale !< A scale for the mixing length in the transition layer !! at the edge of the boundary layer as a fraction of the - !! boundary layer thickness. The default is 0, but a + !! boundary layer thickness [nondim]. The default is 0, but a !! value of 0.1 might be better justified by observations. real :: MLD_tol !< A tolerance for determining the boundary layer thickness when !! Use_MLD_iteration is true [H ~> m or kg m-2]. @@ -98,7 +98,7 @@ module MOM_energetic_PBL integer :: mstar_scheme !< An encoded integer to determine which formula is used to set mstar logical :: MSTAR_FLATCAP=.true. !< Set false to use asymptotic mstar cap. real :: mstar_cap !< Since MSTAR is restoring undissipated energy to mixing, - !! there must be a cap on how large it can be. This + !! there must be a cap on how large it can be [nondim]. This !! is definitely a function of latitude (Ekman limit), !! but will be taken as constant for now. @@ -113,45 +113,45 @@ module MOM_energetic_PBL !! for using a fixed mstar is used. !/ mstar_scheme == 2 - real :: C_EK = 0.17 !< MSTAR Coefficient in rotation limit for mstar_scheme=OM4 - real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 + real :: C_EK = 0.17 !< MSTAR Coefficient in rotation limit for mstar_scheme=OM4 [nondim] + real :: MSTAR_COEF = 0.3 !< MSTAR coefficient in rotation/stabilizing balance for mstar_scheme=OM4 [nondim] !/ mstar_scheme == 3 - real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outer-most coefficient for fit). + real :: RH18_mstar_cN1 !< MSTAR_N coefficient 1 (outer-most coefficient for fit) [nondim]. !! Value of 0.275 in RH18. Increasing this !! coefficient increases mechanical mixing for all values of Hf/ust, !! but is most effective at low values (weakly developed OSBLs). - real :: RH18_mstar_cN2 !< MSTAR_N coefficient 2 (coefficient outside of exponential decay). + real :: RH18_mstar_cN2 !< MSTAR_N coefficient 2 (coefficient outside of exponential decay) [nondim]. !! Value of 8.0 in RH18. Increasing this coefficient increases MSTAR !! for all values of HF/ust, with a consistent affect across !! a wide range of Hf/ust. - real :: RH18_mstar_cN3 !< MSTAR_N coefficient 3 (exponential decay coefficient). Value of + real :: RH18_mstar_cN3 !< MSTAR_N coefficient 3 (exponential decay coefficient) [nondim]. Value of !! -5.0 in RH18. Increasing this increases how quickly the value !! of MSTAR decreases as Hf/ust increases. - real :: RH18_mstar_cS1 !< MSTAR_S coefficient for RH18 in stabilizing limit. + real :: RH18_mstar_cS1 !< MSTAR_S coefficient for RH18 in stabilizing limit [nondim]. !! Value of 0.2 in RH18. - real :: RH18_mstar_cS2 !< MSTAR_S exponent for RH18 in stabilizing limit. + real :: RH18_mstar_cS2 !< MSTAR_S exponent for RH18 in stabilizing limit [nondim]. !! Value of 0.4 in RH18. !/ Coefficient for shear/convective turbulence interaction - real :: mstar_convect_coef !< Factor to reduce mstar when statically unstable. + real :: mstar_convect_coef !< Factor to reduce mstar when statically unstable [nondim]. !/ Langmuir turbulence related parameters logical :: Use_LT = .false. !< Flag for using LT in Energy calculation integer :: LT_ENHANCE_FORM !< Integer for Enhancement functional form (various options) - real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancement - real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement + real :: LT_ENHANCE_COEF !< Coefficient in fit for Langmuir Enhancement [nondim] + real :: LT_ENHANCE_EXP !< Exponent in fit for Langmuir Enhancement [nondim] real :: LaC_MLDoEK !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Ekman depth. + !! the mixed layer depth over the Ekman depth [nondim]. real :: LaC_MLDoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukhov depth with stabilizing forcing. + !! the mixed layer depth over the Obukhov depth with stabilizing forcing [nondim]. real :: LaC_EKoOB_stab !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukhov depth with stabilizing forcing. + !! the Ekman depth over the Obukhov depth with stabilizing forcing [nondim]. real :: LaC_MLDoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the mixed layer depth over the Obukhov depth with destabilizing forcing. + !! the mixed layer depth over the Obukhov depth with destabilizing forcing [nondim]. real :: LaC_EKoOB_un !< Coefficient for Langmuir number modification based on the ratio of - !! the Ekman depth over the Obukhov depth with destabilizing forcing. - real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing. + !! the Ekman depth over the Obukhov depth with destabilizing forcing [nondim]. + real :: Max_Enhance_M = 5. !< The maximum allowed LT enhancement to the mixing [nondim]. !/ Others type(time_type), pointer :: Time=>NULL() !< A pointer to the ocean model's clock. @@ -229,8 +229,8 @@ module MOM_energetic_PBL !> A type for conveniently passing around ePBL diagnostics for a column. type, public :: ePBL_column_diags ; private !>@{ Local column copies of energy change diagnostics, all in [R Z3 T-3 ~> W m-2]. - real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing - real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay + real :: dTKE_conv, dTKE_forcing, dTKE_wind, dTKE_mixing ! Local column diagnostics [R Z3 T-3 ~> W m-2] + real :: dTKE_MKE, dTKE_mech_decay, dTKE_conv_decay ! Local column diagnostics [R Z3 T-3 ~> W m-2] !>@} real :: LA !< The value of the Langmuir number [nondim] real :: LAmod !< The modified Langmuir number by convection [nondim] @@ -570,8 +570,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! during this timestep [R Z3 T-2 ~> J m-2]. A portion nstar_FC ! of conv_PErel is available to drive mixing. real :: htot ! The total depth of the layers above an interface [H ~> m or kg m-2]. - real :: uhtot ! The depth integrated zonal and meridional velocities in the - real :: vhtot ! layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + real :: uhtot ! The depth integrated zonal velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] + real :: vhtot ! The depth integrated meridional velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] real :: Idecay_len_TKE ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. real :: h_sum ! The total thickness of the water column [H ~> m or kg m-2]. @@ -612,7 +612,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs real, dimension(SZK_(GV)+1) :: & MixLen_shape, & ! A nondimensional shape factor for the mixing length that ! gives it an appropriate asymptotic value at the bottom of - ! the boundary layer. + ! the boundary layer [nondim]. Kddt_h ! The diapycnal diffusivity times a timestep divided by the ! average thicknesses around a layer [H ~> m or kg m-2]. real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. @@ -642,9 +642,9 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! a surface mixing roughness length given by h_tt_min [H ~> m or kg m-2]. real :: h_tt_min ! A surface roughness length [H ~> m or kg m-2]. - real :: C1_3 ! = 1/3. + real :: C1_3 ! = 1/3 [nondim] real :: I_dtrho ! 1.0 / (dt * Rho0) times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1]. - ! This is used convert TKE back into ustar^3. + ! This is used convert TKE back into ustar^3 for use in a cube root. real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. real :: mstar_total ! The value of mstar used in ePBL [nondim] real :: mstar_LT ! An addition to mstar due to Langmuir turbulence [nondim] (output for diagnostic) @@ -708,8 +708,8 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs ! - needed to compute new mixing length. real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [H ~> m or kg m-2]. real :: MLD_guess_Z ! A guessed mixed layer depth, converted to height units [Z ~> m] - real :: min_MLD ! Iteration bounds [H ~> m or kg m-2], which are adjusted at each step - real :: max_MLD ! - These are initialized based on surface/bottom + real :: min_MLD, max_MLD ! Iteration bounds on MLD [H ~> m or kg m-2], which are adjusted at each step + ! - These are initialized based on surface/bottom ! 1. The iteration guesses a value (possibly from prev step or neighbor). ! 2. The iteration checks if value is converged, too shallow, or too deep. ! 3. Based on result adjusts the Max/Min and searches through the water column. @@ -726,14 +726,24 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter - real :: Surface_Scale ! Surface decay scale for vstar + real :: Surface_Scale ! Surface decay scale for vstar [nondim] logical :: calc_Te ! If true calculate the expected final temperature and salinity values. logical :: debug ! This is used as a hard-coded value for debugging. ! The following arrays are used only for debugging purposes. - real :: dPE_debug, mixing_debug - real, dimension(20) :: TKE_left_itt, PE_chg_itt, Kddt_h_itt, dPEa_dKd_itt, MKE_src_itt - real, dimension(SZK_(GV)) :: mech_TKE_k, conv_PErel_k, nstar_k + real :: dPE_debug ! An estimate of the potential energy change [R Z3 T-2 ~> J m-2] + real :: mixing_debug ! An estimate of the rate of change of potential energy due to mixing [R Z3 T-3 ~> W m-2] + real, dimension(20) :: TKE_left_itt ! The value of TKE_left after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: PE_chg_itt ! The value of PE_chg after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(20) :: Kddt_h_itt ! The value of Kddt_h_guess after each iteration [H ~> m or kg m-2] + real, dimension(20) :: dPEa_dKd_itt ! The value of dPEc_dKd after each iteration [R Z3 T-2 H-1 ~> J m-3 or J kg-1] + real, dimension(20) :: MKE_src_itt ! The value of MKE_src after each iteration [R Z3 T-2 ~> J m-2] + real, dimension(SZK_(GV)) :: mech_TKE_k ! The mechanically generated turbulent kinetic energy + ! available for mixing over a time step for each layer [R Z3 T-2 ~> J m-2]. + real, dimension(SZK_(GV)) :: conv_PErel_k ! The potential energy that has been convectively released + ! during this timestep for each layer [R Z3 T-2 ~> J m-2]. + real, dimension(SZK_(GV)) :: nstar_k ! The fraction of conv_PErel that can be converted to mixing + ! for each layer [nondim]. real, dimension(SZK_(GV)) :: dT_expect !< Expected temperature changes [C ~> degC] real, dimension(SZK_(GV)) :: dS_expect !< Expected salinity changes [S ~> ppt] integer, dimension(SZK_(GV)) :: num_itts @@ -1185,7 +1195,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs Kddt_h(K) = Kd(K) * dt_h elseif (tot_TKE + (MKE_src - PE_chg_g0) >= 0.0) then - ! This column is convctively stable and there is energy to support the suggested + ! This column is convectively stable and there is energy to support the suggested ! mixing. Keep that estimate. Kd(K) = Kd_guess0 Kddt_h(K) = Kddt_h_g0 @@ -1398,7 +1408,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs MLD_guess = 0.5*(min_MLD + max_MLD) else ! Try using the false position method or the returned value instead of simple bisection. ! Taking the occasional step with MLD_output empirically helps to converge faster. - if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4)>0)) then + if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4) > 0)) then ! Both bounds have valid change estimates and are probably in the range of possible outputs. MLD_Guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then @@ -1809,7 +1819,6 @@ subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& MStar = MStar * MStar_Conv_Red if (present(Langmuir_Number)) then - !### In this call, ustar was previously ustar_mean. Is this change deliberate, Brandon? -RWH call mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langmuir_Number, MStar, & MStar_LT, Convect_Langmuir_Number) endif @@ -1831,9 +1840,9 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm real, intent(out) :: Convect_Langmuir_number !< Langmuir number including buoyancy flux [nondim] !/ - real, parameter :: Max_ratio = 1.0e16 ! The maximum value of a nondimensional ratio. - real :: enhance_mstar ! A multiplicative scaling of mstar due to Langmuir turbulence. - real :: mstar_LT_add ! A value that is added to mstar due to Langmuir turbulence. + real, parameter :: Max_ratio = 1.0e16 ! The maximum value of a nondimensional ratio [nondim]. + real :: enhance_mstar ! A multiplicative scaling of mstar due to Langmuir turbulence [nondim]. + real :: mstar_LT_add ! A value that is added to mstar due to Langmuir turbulence [nondim]. real :: iL_Ekman ! Inverse of Ekman length scale [Z-1 ~> m-1]. real :: iL_Obukhov ! Inverse of Obukhov length scale [Z-1 ~> m-1]. real :: I_ustar ! The Adcroft reciprocal of ustar [T Z-1 ~> s m-1] @@ -1841,10 +1850,14 @@ subroutine Mstar_Langmuir(CS, US, Abs_Coriolis, Buoyancy_Flux, UStar, BLD, Langm real :: MLD_Ekman ! The ratio of the mixed layer depth to the Ekman layer depth [nondim]. real :: Ekman_Obukhov ! The Ekman layer thickness divided by the Obukhov depth [nondim]. real :: MLD_Obukhov ! The mixed layer depth divided by the Obukhov depth [nondim]. - real :: MLD_Obukhov_stab ! Ratios of length scales where MLD is boundary layer depth [nondim]. - real :: Ekman_Obukhov_stab ! > - real :: MLD_Obukhov_un ! Ratios of length scales where MLD is boundary layer depth - real :: Ekman_Obukhov_un ! > + real :: MLD_Obukhov_stab ! The mixed layer depth divided by the Obukhov depth under stable + ! conditions or 0 under unstable conditions [nondim]. + real :: Ekman_Obukhov_stab ! The Ekman layer thickness divided by the Obukhov depth under stable + ! conditions or 0 under unstable conditions [nondim]. + real :: MLD_Obukhov_un ! The mixed layer depth divided by the Obukhov depth under unstable + ! conditions or 0 under stable conditions [nondim]. + real :: Ekman_Obukhov_un ! The Ekman layer thickness divided by the Obukhov depth under unstable + ! conditions or 0 under stable conditions [nondim]. ! Set default values for no Langmuir effects. enhance_mstar = 1.0 ; mstar_LT_add = 0.0 @@ -1910,9 +1923,9 @@ subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units real, optional, intent(in) :: m_to_MLD_units !< A conversion factor from meters - !! to the desired units for MLD + !! to the desired units for MLD, sometimes [m Z-1 ~> 1] ! Local variables - real :: scale ! A dimensional rescaling factor + real :: scale ! A dimensional rescaling factor, often [nondim] or [m Z-1 ~> 1] integer :: i,j scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units @@ -1939,7 +1952,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) # include "version_variable.h" character(len=40) :: mdl = "MOM_energetic_PBL" ! This module's name. character(len=20) :: tmpstr - real :: omega_frac_dflt + real :: omega_frac_dflt ! The default for omega_frac [nondim] integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -2390,7 +2403,7 @@ subroutine energetic_PBL_end(CS) type(energetic_PBL_CS), intent(inout) :: CS !< Energetic_PBL control structure character(len=256) :: mesg - real :: avg_its + real :: avg_its ! The averaged number of iterations used by ePBL [nondim] if (allocated(CS%ML_depth)) deallocate(CS%ML_depth) if (allocated(CS%LA)) deallocate(CS%LA) From cd9ef0af2e086dfcf9ec3cd1d1566dabdabfc300 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 21 Jan 2023 13:08:31 -0500 Subject: [PATCH 183/629] Document units of variables in MOM_diapyc_energy_req Added or amended comments to document the units of numerous internal variables in MOM_diapyc_energy_req.F90, and corrected a few spelling errors in comments. Also eliminated an unused variable. All answers are bitwise identical. --- .../vertical/MOM_diapyc_energy_req.F90 | 89 ++++++++++++------- 1 file changed, 57 insertions(+), 32 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 2ddf8b8c7a..bbc4c9bf96 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -68,9 +68,11 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real, dimension(GV%ke+1) :: & Kd, & ! A column of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1]. h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. - real :: ustar, absf, htot + real :: ustar ! The local friction velocity [Z T-1 ~> m s-1] + real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] + real :: htot ! The sum of the thicknesses [H ~> m or kg m-2]. real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. - real :: tmp1 ! A temporary array. + real :: tmp1 ! A temporary array [H Z ~> m2 or kg m-1] integer :: i, j, k, is, ie, js, je, nz logical :: may_print is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -100,7 +102,7 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) Kd(1) = 0.0 ; Kd(nz+1) = 0.0 do K=2,nz tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z @@ -168,24 +170,38 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! mixing effects with other yet lower layers [C H ~> degC m or degC kg m-2]. Sh_b, & ! An effective salinity times a thickness in the layer below, including implicit ! mixing effects with other yet lower layers [S H ~> ppt m or ppt kg m-2]. - dT_to_dPE, & ! Partial derivative of column potential energy with the temperature and salinity - dS_to_dPE, & ! changes within a layer [R Z L2 T-2 C-1 ~> J m-2 degC-1] and [R Z L2 T-2 S-1 ~> J m-2 ppt-1] - dT_to_dColHt, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt, & ! and salinity changes within a layer [Z C-1 ~> m degC-1] and [Z S-1 ~> m ppt-1]. - dT_to_dColHt_a, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt_a, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers higher in the water column [Z C-1 ~> m degC-1] and [Z S-1 ~> m ppt-1]. - dT_to_dColHt_b, & ! Partial derivatives of the total column height with the temperature - dS_to_dColHt_b, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers lower in the water column [Z C-1 ~> m degC-1] and [Z S-1 ~> m ppt-1]. - dT_to_dPE_a, & ! Partial derivatives of column potential energy with the temperature - dS_to_dPE_a, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers higher in the water column, in - ! units of [R Z L2 T-2 C-1 ~> J m-2 degC-1] and [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - dT_to_dPE_b, & ! Partial derivatives of column potential energy with the temperature - dS_to_dPE_b, & ! and salinity changes within a layer, including the implicit effects - ! of mixing with layers lower in the water column, in - ! units of [R Z L2 T-2 C-1 ~> J m-2 degC-1] and [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dPE, & ! Partial derivative of column potential energy with the temperature changes within + ! a layer [R Z L2 T-2 C-1 ~> J m-2 degC-1] + dS_to_dPE, & ! Partial derivative of column potential energy with the salinity changes within + ! a layer [R Z L2 T-2 S-1 ~> J m-2 ppt-1] + dT_to_dColHt, & ! Partial derivative of the total column height with the temperature + ! changes within a layer [Z C-1 ~> m degC-1] + dS_to_dColHt, & ! Partial derivative of the total column height with the + ! salinity changes within a layer [Z S-1 ~> m ppt-1]. + dT_to_dColHt_a, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_a, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! of mixing with layers higher in the water column [Z S-1 ~> m ppt-1]. + dT_to_dColHt_b, & ! Partial derivative of the total column height with the temperature changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column [Z C-1 ~> m degC-1]. + dS_to_dColHt_b, & ! Partial derivative of the total column height with the salinity changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column [Z S-1 ~> m ppt-1]. + dT_to_dPE_a, & ! Partial derivative of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column, in units of [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_a, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers higher + ! in the water column, in units of [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + dT_to_dPE_b, & ! Partial derivative of column potential energy with the temperature changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column, in units of [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + dS_to_dPE_b, & ! Partial derivative of column potential energy with the salinity changes + ! within a layer, including the implicit effects of mixing with layers lower + ! in the water column, in units of [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. hp_a, & ! An effective pivot thickness of the layer including the effects ! of coupling with layers above [H ~> m or kg m-2]. This is the first term ! in the denominator of b1 in a downward-oriented tridiagonal solver. @@ -243,16 +259,26 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! The following are a bunch of diagnostic arrays for debugging purposes. real, dimension(GV%ke) :: & - Ta, Sa, Tb, Sb + Ta, Tb, & ! Copies of temperature profiles for debugging [C ~> degC] + Sa, Sb ! Copies of salinity profiles for debugging [S ~> ppt] real, dimension(GV%ke+1) :: & - dPEa_dKd, dPEa_dKd_est, dPEa_dKd_err, dPEa_dKd_trunc, dPEa_dKd_err_norm, & - dPEb_dKd, dPEb_dKd_est, dPEb_dKd_err, dPEb_dKd_trunc, dPEb_dKd_err_norm - real :: PE_chg_tot1A, PE_chg_tot2A, T_chg_totA - real :: PE_chg_tot1B, PE_chg_tot2B, T_chg_totB - real :: PE_chg_tot1C, PE_chg_tot2C, T_chg_totC - real :: PE_chg_tot1D, PE_chg_tot2D, T_chg_totD - real, dimension(GV%ke+1) :: dPEchg_dKd - real :: PE_chg(6) + dPEa_dKd, dPEa_dKd_est, & ! Estimates of the partial derivative of the column potential energy + ! change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEb_dKd, dPEb_dKd_est, & ! Estimates of the partial derivative of the column potential energy + ! change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEa_dKd_err, dPEb_dKd_err, & ! Differences in estimates of the partial derivative of the column + ! potential energy change with Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + dPEa_dKd_err_norm, dPEb_dKd_err_norm, & ! Normalized changes in sensitivities [nondim] + dPEa_dKd_trunc, dPEb_dKd_trunc ! Estimates of the truncation error in estimates of the partial + ! derivative of the column potential energy change with + ! Kddt_h [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. + real :: PE_chg_tot1A, PE_chg_tot2A ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1B, PE_chg_tot2B ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1C, PE_chg_tot2C ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: PE_chg_tot1D, PE_chg_tot2D ! Changes in column potential energy [R Z L2 T-2 ~> J m-2] + real :: T_chg_totA, T_chg_totB ! Vertically integrated temperature changes [C H ~> degC m or degC kg m-2] + real :: T_chg_totC, T_chg_totD ! Vertically integrated temperature changes [C H ~> degC m or degC kg m-2] + real :: PE_chg(6) ! The potential energy change within the first few iterations [R Z L2 T-2 ~> J m-2] integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug @@ -309,7 +335,6 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! PE_chg_k(1) = 0.0 ; PE_chg_k(nz+1) = 0.0 ! PEchg(:) = 0.0 PE_chg_k(:,:) = 0.0 ; ColHt_cor_k(:,:) = 0.0 - dPEchg_dKd(:) = 0.0 if (surface_BL) then ! This version is appropriate for a surface boundary layer. old_PE_calc = .false. @@ -1031,7 +1056,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realizedd by applying a huge value of Kddt_h at the + !! be realized by applying a huge value of Kddt_h at the !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. From 7a9d151cfb17085eeb241d4964c2cf9d275c383c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:27:02 -0500 Subject: [PATCH 184/629] Document units of 16 variables in MOM_opacity Added or amended comments to document the units of 16 internal variables in MOM_opacity.F90, and corrected a spelling error in a comment. Only comments are changed, and all answers are bitwise identical. --- .../vertical/MOM_opacity.F90 | 27 ++++++++++--------- 1 file changed, 14 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index ccedb5c607..43462131ca 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -68,7 +68,7 @@ module MOM_opacity !! The default is 10 m-1 - a value for muddy water. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. - logical :: warning_issued !< A flag that is used to avoid repetative warnings. + logical :: warning_issued !< A flag that is used to avoid repetitive warnings. !>@{ Diagnostic IDs integer :: id_sw_pen = -1, id_sw_vis_pen = -1 @@ -402,7 +402,7 @@ end subroutine opacity_from_chl !> This sets the blue-wavelength opacity according to the scheme proposed by !! Morel and Antoine (1994). function opacity_morel(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. + real, intent(in) :: chl_data !< The chlorophyll-A concentration in [mg m-3] real :: opacity_morel !< The returned opacity [m-1] ! The following are coefficients for the optical model taken from Morel and @@ -411,8 +411,8 @@ function opacity_morel(chl_data) ! appropriate when using an interactive ecosystem model that predicts ! three-dimensional chl-a values. real, dimension(6), parameter :: & - Z2_coef = (/7.925, -6.644, 3.662, -1.815, -0.218, 0.502/) - real :: Chl, Chl2 ! The log10 of chl_data (in mg m-3), and Chl^2. + Z2_coef = (/7.925, -6.644, 3.662, -1.815, -0.218, 0.502/) ! Extinction length coefficients [m] + real :: Chl, Chl2 ! The log10 of chl_data (in mg m-3), and Chl^2 [nondim] Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl opacity_morel = 1.0 / ( (Z2_coef(1) + Z2_coef(2)*Chl) + Chl2 * & @@ -430,9 +430,9 @@ function SW_pen_frac_morel(chl_data) ! chlorophyll-a through the water column. Other approaches may be more ! appropriate when using an interactive ecosystem model that predicts ! three-dimensional chl-a values. - real :: Chl, Chl2 ! The log10 of chl_data in mg m-3, and Chl^2. + real :: Chl, Chl2 ! The log10 of chl_data in mg m-3, and Chl^2 [nondim] real, dimension(6), parameter :: & - V1_coef = (/0.321, 0.008, 0.132, 0.038, -0.017, -0.007/) + V1_coef = (/0.321, 0.008, 0.132, 0.038, -0.017, -0.007/) ! Penetrating fraction coefficients [nondim] Chl = log10(min(max(chl_data,0.02),60.0)) ; Chl2 = Chl*Chl SW_pen_frac_morel = 1.0 - ( (V1_coef(1) + V1_coef(2)*Chl) + Chl2 * & @@ -442,7 +442,7 @@ end function SW_pen_frac_morel !> This sets the blue-wavelength opacity according to the scheme proposed by !! Manizza, M. et al, 2005. function opacity_manizza(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. + real, intent(in) :: chl_data !< The chlorophyll-A concentration [mg m-3] real :: opacity_manizza !< The returned opacity [m-1] ! This sets the blue-wavelength opacity according to the scheme proposed by Manizza, M. et al, 2005. @@ -460,15 +460,16 @@ subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_ real, dimension(max(optics%nbands,1),SZI_(G),SZK_(GV)), & optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer [Z-1 ~> m-1], !! but with units that can be altered by opacity_scale. - real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity. + real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity [nondim] or + !! [Z H-1 ~> 1 or m3 kg-1] real, dimension(max(optics%nbands,1),SZI_(G)), & optional, intent(out) :: penSW_top !< The shortwave radiation [Q R Z T-1 ~> W m-2] !! at the surface in each of the nbands bands !! that penetrates beyond the surface skin layer. - real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux. + real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim]? ! Local variables - real :: scale_opacity, scale_penSW ! Rescaling factors + real :: scale_opacity, scale_penSW ! Rescaling factors [nondim]? integer :: i, is, ie, k, nz, n is = G%isc ; ie = G%iec ; nz = GV%ke @@ -604,7 +605,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l ! is moved upward [C H ~> degC m or degC kg m-2] real :: SWa ! fraction of the absorbed shortwave that is ! moved to layers above with adjustAbsorptionProfile [nondim] - real :: coSWa_frac ! The fraction of SWa that is actually moved upward. + real :: coSWa_frac ! The fraction of SWa that is actually moved upward [nondim] real :: min_SW_heat ! A minimum remaining shortwave heating within a timestep that will be simply ! absorbed in the next layer for computational efficiency, instead of ! continuing to penetrate [C H ~> degC m or degC kg m-2]. @@ -617,7 +618,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l ! was not entirely absorbed. logical :: TKE_calc ! If true, calculate the implications to the ! TKE budget of the shortwave heating. - real :: C1_6, C1_60 + real :: C1_6, C1_60 ! Rational fractions [nondim] integer :: is, ie, nz, i, k, ks, n if (nsw < 1) return @@ -830,7 +831,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & real :: SW_trans ! fraction of shortwave radiation not ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation - ! not absorbed because the layers are too thin. + ! not absorbed because the layers are too thin [nondim]. real :: Ih_limit ! inverse of the total depth at which the ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: min_SW_heat ! A minimum remaining shortwave heating within a timestep that will be simply From 905493947368ce975cf03d48e969e663745260ec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:27:52 -0500 Subject: [PATCH 185/629] Document units of 21 variables in MOM_bulk_mixed_layer Added or amended comments to document the units of 21 internal variables in MOM_bulk_mixed_layer.F90, and corrected a few spelling errors in comments. Only comments are changed, and all answers are bitwise identical. --- .../vertical/MOM_bulk_mixed_layer.F90 | 49 ++++++++++--------- 1 file changed, 26 insertions(+), 23 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 9d118f9096..5e530bea3d 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -253,7 +253,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C uhtot, & ! The depth integrated zonal velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] vhtot, & ! The depth integrated meridional velocity in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] - netMassInOut, & ! The net mass flux (if non-Boussinsq) or volume flux (if + netMassInOut, & ! The net mass flux (if non-Boussinesq) or volume flux (if ! Boussinesq - i.e. the fresh water flux (P+R-E)) into the ! ocean over a time step [H ~> m or kg m-2]. NetMassOut, & ! The mass flux (if non-Boussinesq) or volume flux (if Boussinesq) @@ -287,11 +287,11 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! denominator of MKE_rate; the two elements have differing ! units of [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. real :: Irho0 ! 1.0 / rho_0 [R-1 ~> m3 kg-1] - real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) + real :: Inkml, Inkmlm1! 1.0 / REAL(nkml) and 1.0 / REAL(nkml-1) [nondim] real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. - real :: RmixConst - + real :: RmixConst ! A combination of constants used in the river mixing energy + ! calculation [L2 T-2 R-2 ~> m8 s-2 kg-2] real, dimension(SZI_(G)) :: & dKE_FC, & ! The change in mean kinetic energy due to free convection ! [Z L2 T-2 ~> m3 s-2]. @@ -316,7 +316,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! layers before detrainment in to the interior [H ~> m or kg m-2]. max_BL_det ! If non-negative, the maximum amount of entrainment from ! the buffer layers that will be allowed this time step [H ~> m or kg m-2]. - real :: dHsfc, dHD ! Local copies of nondimensional parameters. + real :: dHsfc, dHD ! Local copies of nondimensional parameters [nondim] real :: H_nbr ! A minimum thickness based on neighboring thicknesses [H ~> m or kg m-2]. real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z T-1 ~> m s-1]. @@ -344,9 +344,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C Inkml = 1.0 / REAL(CS%nkml) if (CS%nkml > 1) Inkmlm1 = 1.0 / REAL(CS%nkml-1) - Irho0 = 1.0 / (GV%Rho0) + Irho0 = 1.0 / GV%Rho0 dt__diag = dt ; if (present(dt_diag)) dt__diag = dt_diag - Idt_diag = 1.0 / (dt__diag) + Idt_diag = 1.0 / dt__diag write_diags = .true. ; if (present(last_call)) write_diags = last_call p_ref(:) = 0.0 ; p_ref_cv(:) = tv%P_Ref @@ -795,8 +795,8 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! entrained [C H ~> degC m or degC kg m-2]. Stot, & ! The integrated salt of layers which are fully entrained ! [H S ~> m ppt or ppt kg m-2]. - uhtot, & ! The depth integrated zonal and meridional velocities in - vhtot, & ! the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1]. + uhtot, & ! The depth integrated zonal velocities in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] + vhtot, & ! The depth integrated meridional velocities in the mixed layer [H L T-1 ~> m2 s-1 or kg m-1 s-1] KE_orig, & ! The total mean kinetic energy per unit area in the mixed layer before ! convection, [H L2 T-2 ~> m3 s-2 or kg s-2]. h_orig_k1 ! The depth of layer k1 before convective adjustment [H ~> m or kg m-2]. @@ -984,13 +984,13 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! entrainment [H ~> m or kg m-2]. real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. real :: T_precip ! The temperature of the precipitation [C ~> degC]. - real :: C1_3, C1_6 ! 1/3 and 1/6. - real :: En_fn, Frac, x1 ! Nondimensional temporary variables. + real :: C1_3, C1_6 ! 1/3 and 1/6 [nondim] + real :: En_fn, Frac, x1 ! Nondimensional temporary variables [nondim]. real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3]. - real :: h_min, h_max ! The minimum, maximum, and previous estimates for - real :: h_prev ! h_ent [H ~> m or kg m-2]. + real :: h_min, h_max ! The minimum and maximum estimates for h_ent [H ~> m or kg m-2] + real :: h_prev ! The previous estimate for h_ent [H ~> m or kg m-2] real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. real :: dh_Newt ! The Newton's method estimate of the change in ! h_ent between iterations [H ~> m or kg m-2]. @@ -1005,7 +1005,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: Idt ! 1.0/dt [T-1 ~> s-1] integer :: is, ie, nz, i, k, ks, itt, n real, dimension(max(nsw,1)) :: & - C2, & ! Temporary variable R H-1 ~> kg m-4 or m-1]. + C2, & ! Temporary variable [R H-1 ~> kg m-4 or m-1]. r_SW_top ! Temporary variables [H R ~> kg m-2 or kg2 m-5]. Angstrom = GV%Angstrom_H @@ -1451,7 +1451,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & intent(inout) :: d_eb !< The downward increase across a layer in the !! layer in the entrainment from below [H ~> m or kg m-2]. !! Positive values go with mass gain by a layer. - real, dimension(SZI_(G)), intent(inout) :: htot !< The accumlated mixed layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(inout) :: htot !< The accumulated mixed layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(inout) :: Ttot !< The depth integrated mixed layer temperature !! [C H ~> degC m or degC kg m-2]. real, dimension(SZI_(G)), intent(inout) :: Stot !< The depth integrated mixed layer salinity @@ -1892,7 +1892,7 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real :: h_tgt_old ! The previous thickness of the recipient layer [H ~> m or kg m-2] real :: I_hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m3 kg-1] real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes - ! when extraploating to match a target density [C2 S-2 ~> degC2 ppt-2] + ! when extrapolating to match a target density [C2 S-2 ~> degC2 ppt-2] real :: dT_dR ! The ratio of temperature changes to density changes when ! extrapolating [C R-1 ~> degC m3 kg-1] real :: dS_dR ! The ratio of salinity changes to density changes when @@ -2262,13 +2262,16 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: h_det_h2 ! The amount of detrained water and mixed layer ! water that will go directly into the lower ! buffer layer [H ~> m or kg m-2]. - real :: h_det_to_h2, h_ml_to_h2 ! All of the variables hA_to_hB are the thickness fluxes - real :: h_det_to_h1, h_ml_to_h1 ! from one layer to another [H ~> m or kg m-2], - real :: h1_to_h2, h1_to_k0 ! with h_det the detrained water, h_ml - real :: h2_to_k1, h2_to_k1_rem ! the actively mixed layer, h1 and h2 the upper - ! and lower buffer layers, and k0 and k1 the - ! interior layers that are just lighter and - ! just denser than the lower buffer layer. + + real :: h_det_to_h2, h_ml_to_h2 ! The fluxes of detrained and mixed layer water to + ! the lower buffer layer [H ~> m or kg m-2]. + real :: h_det_to_h1, h_ml_to_h1 ! The fluxes of detrained and mixed layer water to + ! the upper buffer layer [H ~> m or kg m-2]. + real :: h1_to_h2, h1_to_k0 ! The fluxes of upper buffer layer water to the lower buffer layer + ! and to an interior layer that is just denser than the lower + ! buffer layer [H ~> m or kg m-2]. + real :: h2_to_k1, h2_to_k1_rem ! Fluxes of lower buffer layer water to the interior layer that + ! is just denser than the lower buffer layer [H ~> m or kg m-2]. real :: R0_det, T_det, S_det ! Detrained values of R0 [R ~> kg m-3], T [C ~> degC] and S [S ~> ppt] real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer [R ~> kg m-3] From 05c2983273ba5cb3875b6e011156dd14414df2bc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:28:24 -0500 Subject: [PATCH 186/629] Clean up of a get_param call in vertvisc_init Revised the line breaks for a get_param call in vertvisc_init to put the units, default, and scale arguments on the same line, and used a merged scaling factor in the same call. Also added or amended comments to document the units of 9 internal variables in this same file. All answers and output are bitwise identical. --- .../vertical/MOM_vert_friction.F90 | 25 ++++++++++--------- 1 file changed, 13 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6488ba5b1b..819b2ea8b3 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -84,8 +84,8 @@ module MOM_vert_friction !! will often equal CFL_trunc. real :: truncRampTime !< The time-scale over which to ramp up the value of !! CFL_trunc from CFL_truncS to CFL_truncE [T ~> s] - real :: CFL_truncS !< The start value of CFL_trunc - real :: CFL_truncE !< The end/target value of CFL_trunc + real :: CFL_truncS !< The start value of CFL_trunc [nondim] + real :: CFL_truncE !< The end/target value of CFL_trunc [nondim] logical :: CFLrampingIsActivated = .false. !< True if the ramping has been initialized type(time_type) :: rampStartTime !< The time at which the ramping of CFL_trunc starts @@ -209,7 +209,7 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! for a column real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the !! bottom, normalized by the GL90 bottom - !! boundary layer thickness + !! boundary layer thickness [nondim] real, dimension(SZIB_(G),SZK_(GV)+1), intent(inout) :: a_cpl_gl90 !< Coupling coefficient associated !! with GL90 across interfaces; is not !! included in a_cpl [Z T-1 ~> m s-1]. @@ -362,7 +362,8 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! by the density [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: accel_underflow ! An acceleration magnitude that is so small that values that are less ! than this are diagnosed as 0 [L T-2 ~> m s-2]. - real :: zDS, hfr, h_a ! Temporary variables used with direct_stress. + real :: zDS, h_a ! Temporary thickness variables used with direct_stress [H ~> m or kg m-2] + real :: hfr ! Temporary ratio of thicknesses used with direct_stress [nondim] real :: surface_stress(SZIB_(G))! The same as stress, unless the wind stress ! stress is applied as a body force [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, allocatable, dimension(:,:,:) :: KE_term ! A term in the kinetic energy budget @@ -982,8 +983,8 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme ! [H-1 ~> m-1 or m2 kg-1]. I_Htbl, & ! The inverse of the top boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. - zcol1, & ! The height of the interfaces to the north and south of a - zcol2, & ! v-point [H ~> m or kg m-2]. + zcol1, & ! The height of the interfaces to the south of a v-point [H ~> m or kg m-2]. + zcol2, & ! The height of the interfaces to the north of a v-point [H ~> m or kg m-2]. Ztop_min, & ! The deeper of the two adjacent surface heights [H ~> m or kg m-2]. Dmin, & ! The shallower of the two adjacent bottom depths converted to ! thickness units [H ~> m or kg m-2]. @@ -1520,7 +1521,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, z_t, & ! The distance from the top, sometimes normalized ! by Hmix, [H ~> m or kg m-2] or [nondim]. kv_TBL, & ! The viscosity in a top boundary layer under ice [Z2 T-1 ~> m2 s-1]. - tbl_thick + tbl_thick ! The thickness of the top boundary layer [H ~> m or kg m-2] real, dimension(SZIB_(G),SZK_(GV)+1) :: & Kv_tot, & ! The total viscosity at an interface [Z2 T-1 ~> m2 s-1]. Kv_add ! A viscosity to add [Z2 T-1 ~> m2 s-1]. @@ -1921,8 +1922,8 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS ! Local variables - real :: maxvel ! Velocities components greater than maxvel - real :: truncvel ! are truncated to truncvel, both [L T-1 ~> m s-1]. + real :: maxvel ! Velocities components greater than maxvel are truncated [L T-1 ~> m s-1] + real :: truncvel ! The speed to which velocity components greater than maxvel are set [L T-1 ~> m s-1] real :: CFL ! The local CFL number [nondim] real :: H_report ! A thickness below which not to report truncations [H ~> m or kg m-2] real :: vel_report(SZIB_(G),SZJB_(G)) ! The velocity to report [L T-1 ~> m s-1] @@ -2262,9 +2263,9 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "viscosity coefficient. This method is valid in stacked shallow water mode.", & default=.false.) call get_param(param_file, mdl, "KD_GL90", CS%kappa_gl90, & - "The scalar diffusivity used in GL90 vertical viscosity "//& - "scheme.", units="m2 s-1", default=0.0, & - scale=US%m_to_Z**2*US%T_to_s, do_not_log=.not.CS%use_GL90_in_SSW) + "The scalar diffusivity used in GL90 vertical viscosity scheme.", & + units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, & + do_not_log=.not.CS%use_GL90_in_SSW) call get_param(param_file, mdl, "READ_KD_GL90", CS%read_kappa_gl90, & "If true, read a file (given by KD_GL90_FILE) containing the "//& "spatially varying diffusivity KD_GL90 used in the GL90 scheme.", default=.false., & From f9649d392d0f4ed1ff1ed067123836c72e29c2e4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:30:15 -0500 Subject: [PATCH 187/629] Document units of 14 variables in MOM_tidal_mixing Added or amended comments to document the units of 14 internal variables in MOM_tidal_mixing.F90. Only comments are changed, and all answers are bitwise identical. --- .../vertical/MOM_tidal_mixing.F90 | 31 ++++++++++++------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 4380ceb4bd..23b37bd26d 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -50,7 +50,7 @@ module MOM_tidal_mixing real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: N2_int(:,:,:) !< Buoyancy frequency squared at interfaces [T-2 ~> s-2] real, allocatable :: vert_dep_3d(:,:,:) !< The 3-d mixing energy deposition vertical fraction [nondim]? - real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme, in UNITS? + real, allocatable :: Schmittner_coeff_3d(:,:,:) !< The coefficient in the Schmittner et al mixing scheme [nondim] real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, !! interpolated to model vertical coordinate [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces @@ -123,7 +123,7 @@ module MOM_tidal_mixing real :: utide !< constant tidal amplitude [Z T-1 ~> m s-1] if READ_TIDEAMP is false. real :: kappa_itides !< topographic wavenumber and non-dimensional scaling [Z-1 ~> m-1]. - real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height + real :: kappa_h2_factor !< factor for the product of wavenumber * rms sgs height [nondim] character(len=200) :: inputdir !< The directory in which to find input files logical :: use_CVMix_tidal = .false. !< true if CVMix is to be used for determining @@ -157,7 +157,7 @@ module MOM_tidal_mixing real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided !! by the bottom stratification [R Z3 T-2 ~> J m-2]. real, allocatable :: Nb(:,:) !< The near bottom buoyancy frequency [T-1 ~> s-1]. - real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input + real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input [nondim] real, allocatable :: h2(:,:) !< Squared bottom depth variance [Z2 ~> m2]. real, allocatable :: tideamp(:,:) !< RMS tidal amplitude [Z T-1 ~> m s-1] real, allocatable :: h_src(:) !< tidal constituent input layer thickness [m] @@ -240,8 +240,12 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di character(len=200) :: filename, h2_file, Niku_TKE_input_file ! Input file names character(len=200) :: tideamp_file ! Input file names or paths character(len=80) :: tideamp_var, rough_var, TKE_input_var ! Input file variable names - real :: utide, hamp, prandtl_tidal, max_frac_rough - real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data + real :: hamp ! The magnitude of the sub-gridscale bottom depth variance [Z ~> m] + real :: utide ! The RMS tidal amplitude [Z T-1 ~> m s-1] + real :: max_frac_rough ! A limit on the depth variance as a fraction of the total depth [nondim] + real :: prandtl_tidal ! Prandtl number used by CVMix tidal mixing schemes to convert vertical + ! diffusivities into viscosities [nondim] + real :: Niku_scale ! local variable for scaling the Nikurashin TKE flux data [nondim] integer :: i, j, is, ie, js, je integer :: isd, ied, jsd, jed @@ -543,11 +547,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di if (CS%Lee_wave_dissipation) then - call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE",Niku_TKE_input_file, & + call get_param(param_file, mdl, "NIKURASHIN_TKE_INPUT_FILE", Niku_TKE_input_file, & "The path to the file containing the TKE input from lee "//& "wave driven mixing. Used with LEE_WAVE_DISSIPATION.", & fail_if_missing=.true.) - call get_param(param_file, mdl, "NIKURASHIN_SCALE",Niku_scale, & + call get_param(param_file, mdl, "NIKURASHIN_SCALE", Niku_scale, & "A non-dimensional factor by which to scale the lee-wave "//& "driven TKE input. Used with LEE_WAVE_DISSIPATION.", & units="nondim", default=1.0) @@ -590,7 +594,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di "Prandtl number used by CVMix tidal mixing schemes "//& "to convert vertical diffusivities into viscosities.", & units="nondim", default=1.0, do_not_log=.true.) - call CVMix_put(CS%CVMix_glb_params,'Prandtl',prandtl_tidal) + call CVMix_put(CS%CVMix_glb_params, 'Prandtl', prandtl_tidal) call get_param(param_file, mdl, "TIDAL_ENERGY_TYPE",tidal_energy_type, & "The type of input tidal energy flux dataset. Valid values are"//& @@ -776,7 +780,9 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(SZK_(GV)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] real, dimension(SZK_(GV)+1) :: vert_dep ! vertical deposition [nondim] real, dimension(SZK_(GV)+1) :: iFaceHeight ! Height of interfaces [m] - real, dimension(SZK_(GV)+1) :: SchmittnerSocn + real, dimension(SZK_(GV)+1) :: SchmittnerSocn ! A larger value of the Schmittner coefficint to + ! use in the Southern Ocean [nondim]. If this is smaller + ! than Schmittner_coeff, that standard value is used. real, dimension(SZK_(GV)) :: cellHeight ! Height of cell centers [m] real, dimension(SZK_(GV)) :: tidal_qe_md ! Tidal dissipation energy interpolated from 3d input ! to model coordinates [R Z3 T-3 ~> W m-2] @@ -784,7 +790,10 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(SZK_(GV)) :: Schmittner_coeff ! A coefficient in the Schmittner et al (2014) mixing ! parameterization [nondim] real, dimension(SZK_(GV)) :: h_m ! Cell thickness [m] - real, allocatable, dimension(:,:) :: exp_hab_zetar + real, allocatable, dimension(:,:) :: exp_hab_zetar ! A badly documented array that appears to be + ! related to the distribution of tidal mixing energy, with unusual array + ! extents that are not explained, that is set and used by the CVMix + ! tidal mixing schemes, perhaps in [m3 kg-1]? real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] real :: Simmons_coeff ! A coefficient in the Simmons et al (2004) mixing parameterization [nondim] @@ -1628,7 +1637,7 @@ subroutine read_tidal_constituents(G, US, tidal_energy_file, param_file, CS) type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module ! local variables - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! A rational constant [nondim] real, dimension(SZI_(G),SZJ_(G)) :: & tidal_qk1, & ! qk1 coefficient used in Schmittner & Egbert [nondim] tidal_qo1 ! qo1 coefficient used in Schmittner & Egbert [nondim] From 6927909fbda79e75576fcb36c343fee8a4260d32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:30:42 -0500 Subject: [PATCH 188/629] Document units of a variable in MOM_ALE_sponge Amended comments to document the units of 1 internal variable in MOM_ALE_sponge.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_ALE_sponge.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 2e2a3edf07..584ccccc93 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -78,7 +78,7 @@ module MOM_ALE_sponge 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 :: scale = 1.0 !< A multiplicative factor by which to rescale input data + real :: scale = 1.0 !< A multiplicative factor by which to rescale input data [various] real, dimension(:,:), pointer :: p => NULL() !< pointer to the data [various] real, dimension(:,:), pointer :: h => NULL() !< pointer the data grid [H ~> m or kg m-2] character(len=:), allocatable :: name !< The name of the input field From 536d649155bdff990023e9aa5078e4c9136245c4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:31:16 -0500 Subject: [PATCH 189/629] Document units of a variable in MOM_kappa_shear Amended comments to document the units of 1 internal variable in MOM_kappa_shear.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index a1a5a22322..4e07b1d8ed 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -664,8 +664,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_int, & ! The temperature interpolated to an interface [C ~> degC]. Sal_int, & ! The salinity interpolated to an interface [S ~> ppt]. - dbuoy_dT, & ! The partial derivatives of buoyancy with changes in temperature - dbuoy_dS, & ! and salinity, [Z T-2 C-1 ~> m s-2 degC-1] and [Z T-2 S-1 ~> m s-2 ppt-1]. + dbuoy_dT, & ! The partial derivative of buoyancy with changes in temperature [Z T-2 C-1 ~> m s-2 degC-1] + dbuoy_dS, & ! The partial derivative of buoyancy with changes in salinity [Z T-2 S-1 ~> m s-2 ppt-1] I_L2_bdry, & ! The inverse of the square of twice the harmonic mean ! distance to the top and bottom boundaries [Z-2 ~> m-2]. K_Q, & ! Diffusivity divided by TKE [T ~> s]. From 5c28263e861c0ec5f517cc0e1e659528d9aaca86 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:33:33 -0500 Subject: [PATCH 190/629] Document units of an argument to find_maxF_kb Amended comments to document the units of an argument to the private subroutine find_maxF_kb in MOM_entrainment_diffusive.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_entrain_diffusive.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 332321b209..51a28db0e9 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -1814,9 +1814,9 @@ subroutine find_maxF_kb(h_bl, Sref, Ent_bl, I_dSkbp1, min_ent_in, max_ent_in, & !! limited value at ent=max_ent_in in this !! array [H ~> m or kg m-2]. real, dimension(SZI_(G)), & - optional, intent(in) :: F_thresh !< If F_thresh is present, return the first - !! value found that has F > F_thresh, or - !! the maximum. + optional, intent(in) :: F_thresh !< If F_thresh is present, return the first value + !! found that has F > F_thresh [H ~> m or kg m-2], or + !! the maximum root if it is absent. ! Maximize F = ent*ds_kb*I_dSkbp1 in the range min_ent < ent < max_ent. ! ds_kb may itself be limited to positive values in determine_dSkb, which gives From 6f5c2f42f6210189a0bad16239a4929f799e1aea Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:34:20 -0500 Subject: [PATCH 191/629] Document units of 2 variables in MOM_CVMix_KPP Amended comments to document the units of 2 internal variables in MOM_CVMix_KPP.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 3ac31ef466..0127f8c556 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -619,7 +619,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [nondim] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement multiplier [nondim] ! Local variables integer :: i, j, k ! Loop indices @@ -920,7 +920,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor [nondim] ! Local variables ! Variables for passing to CVMix routines, often in MKS units From 9f53a8ecbeef1530c51a06a24356acfb91d9ec10 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:34:46 -0500 Subject: [PATCH 192/629] Document units of 3 variables in MOM_CVMix_conv Amended comments to document the units of 3 internal variables in MOM_CVMix_conv.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_CVMix_conv.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index a0b24dee70..e26c061929 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -57,7 +57,7 @@ logical function CVMix_conv_init(Time, G, GV, US, param_file, diag, CS) type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(CVMix_conv_cs), intent(inout) :: CS !< CVMix convection control structure - real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities. + real :: prandtl_conv !< Turbulent Prandtl number used in convective instabilities [nondim] logical :: useEPBL !< If True, use the ePBL boundary layer scheme. ! This include declares and sets the variable "version". @@ -154,10 +154,10 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) !! here [Z2 T-1 ~> m2 s-1]. ! local variables - real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density, this is a dummy + real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density [kg m-3], this is a dummy !! variable since here convection is always !! computed based on Brunt Vaisala. - real, dimension(SZK_(GV)) :: rho_1d !< water density in a column, this is also + real, dimension(SZK_(GV)) :: rho_1d !< water density in a column [kg m-3], this is also !! a dummy variable, same reason as above. real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency [s-2] real, dimension(SZK_(GV)+1) :: kv_col !< Viscosities at interfaces in the column [m2 s-1] From b29ed5c37a04236e017e8d5fefc11c89614c2a16 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:35:16 -0500 Subject: [PATCH 193/629] Document units of a variable in MOM_bkgnd_mixing Amended comments to document the units of 1 internal variable in MOM_bkgnd_mixing.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 6d016aa18b..12a32e7376 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -116,7 +116,7 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL ! Local variables real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set Prandtl ! number unless it is provided as a parameter - real :: prandtl_bkgnd_comp ! Kv/CS%Kd. Gets compared with user-specified prandtl_bkgnd. + real :: prandtl_bkgnd_comp ! Kv/CS%Kd [nondim]. Gets compared with user-specified prandtl_bkgnd. ! This include declares and sets the variable "version". # include "version_variable.h" From aa0ec8ccf5b355a355e6735aeceb9b32098be62a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:35:42 -0500 Subject: [PATCH 194/629] Document units of a variable in MOM_regularize_layers Amended comments to document the units of 1 internal variable in MOM_regularize_layers.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_regularize_layers.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index bb81d367c6..5380b4cda0 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -142,7 +142,7 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) S_2d, & ! A 2-d version of tv%S [S ~> ppt]. Rcv, & ! A 2-d version of the coordinate density [R ~> kg m-3]. h_2d_init, & ! The initial value of h_2d [H ~> m or kg m-2]. - T_2d_init, & ! THe initial value of T_2d [C ~> degC]. + T_2d_init, & ! The initial value of T_2d [C ~> degC]. S_2d_init, & ! The initial value of S_2d [S ~> ppt]. d_eb, & ! The downward increase across a layer in the entrainment from ! below [H ~> m or kg m-2]. The sign convention is that positive values of @@ -176,8 +176,8 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) real :: h_add ! The thickness to add to the layers above an interface [H ~> m or kg m-2] real :: h_det_tot ! The total thickness detrained by the mixed layers [H ~> m or kg m-2] real :: max_def_rat ! The maximum value of the ratio of the thickness deficit to the minimum depth [nondim] - real :: Rcv_min_det ! The lightest (min) and densest (max) coordinate density - real :: Rcv_max_det ! that can detrain into a layer [R ~> kg m-3]. + real :: Rcv_min_det ! The lightest coordinate density that can detrain into a layer [R ~> kg m-3] + real :: Rcv_max_det ! The densest coordinate density that can detrain into a layer [R ~> kg m-3] real :: int_top, int_bot ! The interface depths above and below a layer [H ~> m or kg m-2], positive upward. real :: h_predicted ! An updated thickness [H ~> m or kg m-2] From fdab7fd3efd24e2baa9b2751b2ee4a6aae3750cf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:36:08 -0500 Subject: [PATCH 195/629] Document units of a variable in MOM_set_viscosity Amended comments to document the units of 1 internal variable in MOM_set_viscosity.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 91c85ced26..2a9e7deeba 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -257,8 +257,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! the depth of each interface [nondim]. real :: L_direct ! The value of L above volume Vol_direct [nondim]. real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. - real :: Vol_err_max ! The volume errors for the upper and lower bounds on - real :: Vol_err_min ! the correct value for L [H ~> m or kg m-2]. + real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [H ~> m or kg m-2] + real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [H ~> m or kg m-2] real :: Vol_0 ! A deeper volume with known width L0 [H ~> m or kg m-2]. real :: L0 ! The value of L above volume Vol_0 [nondim]. real :: dVol ! vol - Vol_0 [H ~> m or kg m-2]. From cf846eb61c22e0e2314010d441686b6538774c37 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:36:42 -0500 Subject: [PATCH 196/629] Document units of 7 variables in MOM_sponge Amended comments to document the units of 7 internal variables, arguments or elements of types in MOM_sponge.F90. Only comments are changed, and all answers are bitwise identical. --- src/parameterizations/vertical/MOM_sponge.F90 | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 48e9320c8e..0ef732a024 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -30,11 +30,11 @@ module MOM_sponge !> A structure for creating arrays of pointers to 3D arrays type, public :: p3d - real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array + real, dimension(:,:,:), pointer :: p => NULL() !< A pointer to a 3D array [various] end type p3d !> A structure for creating arrays of pointers to 2D arrays type, public :: p2d - real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array + real, dimension(:,:), pointer :: p => NULL() !< A pointer to a 2D array [various] end type p2d !> This control structure holds memory and parameters for the MOM_sponge module @@ -203,15 +203,15 @@ subroutine set_up_sponge_field(sp_val, f_ptr, G, GV, nlay, CS, sp_val_i_mean) 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) :: sp_val !< The reference profiles of the quantity being registered. + intent(in) :: sp_val !< The reference profiles of the quantity being registered [various] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - target, intent(in) :: f_ptr !< a pointer to the field which will be damped + target, intent(in) :: f_ptr !< a pointer to the field which will be damped [various] integer, intent(in) :: nlay !< the number of layers in this quantity type(sponge_CS), pointer :: CS !< A pointer to the control structure for this module that !! is set by a previous call to initialize_sponge. real, dimension(SZJ_(G),SZK_(GV)),& optional, intent(in) :: sp_val_i_mean !< The i-mean reference value for - !! this field with i-mean sponges. + !! this field with i-mean sponges [various] integer :: j, k, col character(len=256) :: mesg ! String for error messages @@ -331,11 +331,11 @@ subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) eta_anom, & ! Anomalies in the interface height, relative to the i-mean ! target value [Z ~> m]. fld_anom ! Anomalies in a tracer concentration, relative to the - ! i-mean target value. + ! i-mean target value [various] real, dimension(SZJ_(G), SZK_(GV)+1) :: & eta_mean_anom ! The i-mean interface height anomalies [Z ~> m]. real, allocatable, dimension(:,:,:) :: & - fld_mean_anom ! THe i-mean tracer concentration anomalies. + fld_mean_anom ! The i-mean tracer concentration anomalies [various] real, dimension(SZI_(G), SZK_(GV)+1) :: & h_above, & ! The total thickness above an interface [H ~> m or kg m-2]. h_below ! The total thickness below an interface [H ~> m or kg m-2]. From 7e7b279054c01221593082022f5d28b484a09778 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 06:37:47 -0500 Subject: [PATCH 197/629] Document units of variables in MOM_internal_tides Added or amended comments to document the units of numerous internal variables in MOM_internal_tides.F90, and corrected a few spelling errors in comments. Only comments are changed, and all answers are bitwise identical. --- .../lateral/MOM_internal_tides.F90 | 232 ++++++++++-------- 1 file changed, 126 insertions(+), 106 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 0f951b355a..6dda4c1b1c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -64,9 +64,9 @@ module MOM_internal_tides !! is possible (i.e. ridge cells) ! (could be in G control structure) real, allocatable, dimension(:,:) :: trans - !< partial transmission coeff for each "coast cell" + !< partial transmission coeff for each "coast cell" [nondim] real, allocatable, dimension(:,:) :: residual - !< residual of reflection and transmission coeff for each "coast cell" + !< residual of reflection and transmission coeff for each "coast cell" [nondim] real, allocatable, dimension(:,:,:,:) :: cp !< horizontal phase speed [L T-1 ~> m s-1] real, allocatable, dimension(:,:,:,:,:) :: TKE_leak_loss @@ -144,7 +144,7 @@ module MOM_internal_tides id_allprocesses_loss_mode, & id_Ub_mode, & id_cp_mode - ! Diag handles considering: all modes, freqs, and angles + ! Diag handles considering: all modes, frequencies, and angles integer, allocatable, dimension(:,:) :: & id_En_ang_mode, & id_itidal_loss_ang_mode @@ -185,7 +185,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & !! mode [L T-1 ~> m s-1]. ! Local variables real, dimension(SZI_(G),SZJ_(G),2) :: & - test + test ! A test unit vector used to determine grid rotation in halos [nondim] 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] @@ -196,15 +196,18 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] drag_scale, & ! bottom drag scale [T-1 ~> s-1] - itidal_loss_mode, allprocesses_loss_mode - ! energy loss rates for a given mode and frequency (summed over angles) [R Z3 T-3 ~> W m-2] - real :: frac_per_sector, f2, Kmag2 + itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over + ! all angles) [R Z3 T-3 ~> W m-2] + real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] + real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] + real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] real :: I_D_here ! The inverse of the local depth [Z-1 ~> m-1] - real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] - real :: freq2 ! The frequency squared [T-2 ~> s-2] - real :: c_phase ! The phase speed [L T-1 ~> m s-1] + real :: I_rho0 ! The inverse fo the Boussinesq density [R-1 ~> m3 kg-1] + real :: freq2 ! The frequency squared [T-2 ~> s-2] + real :: c_phase ! The phase speed [L T-1 ~> m s-1] real :: loss_rate ! An energy loss rate [T-1 ~> s-1] - real :: Fr2_max + real :: Fr2_max ! The column maximum internal wave Froude number squared [nondim] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] real :: en_subRO ! A tiny energy to prevent division by zero [R Z3 T-2 ~> J m-2] real :: En_new, En_check ! Energies for debugging [R Z3 T-2 ~> J m-2] @@ -223,7 +226,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & cn_subRO = 1e-30*US%m_s_to_L_T en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T - ! init local arrays + ! initialize local arrays drag_scale(:,:) = 0. Ub(:,:,:,:) = 0. @@ -548,7 +551,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & if (CS%id_TKE_itidal_input > 0) call post_data(CS%id_TKE_itidal_input, & TKE_itidal_input, CS%diag) - ! Output 2-D energy density (summed over angles) for each freq and mode + ! Output 2-D energy density (summed over angles) for each frequency and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then tot_En(:,:) = 0.0 do a=1,CS%nAngle ; do j=js,je ; do i=is,ie @@ -557,7 +560,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & call post_data(CS%id_En_mode(fr,m), tot_En, CS%diag) endif ; enddo ; enddo - ! Output 3-D (i,j,a) energy density for each freq and mode + ! Output 3-D (i,j,a) energy density for each frequency and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then call post_data(CS%id_En_ang_mode(fr,m), CS%En(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo @@ -606,7 +609,7 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & call post_data(CS%id_tot_allprocesses_loss, tot_allprocesses_loss, CS%diag) endif - ! Output 2-D energy loss (summed over angles) for each freq and mode + ! Output 2-D energy loss (summed over angles) for each frequency and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) @@ -622,17 +625,17 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) endif ; enddo ; enddo - ! Output 3-D (i,j,a) energy loss for each freq and mode + ! Output 3-D (i,j,a) energy loss for each frequency and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then call post_data(CS%id_itidal_loss_ang_mode(fr,m), CS%TKE_itidal_loss(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo - ! Output 2-D period-averaged horizontal near-bottom mode velocity for each freq and mode + ! Output 2-D period-averaged horizontal near-bottom mode velocity for each frequency and mode do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then call post_data(CS%id_Ub_mode(fr,m), Ub(:,:,fr,m), CS%diag) endif ; enddo ; enddo - ! Output 2-D horizontal phase velocity for each freq and mode + ! 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) endif ; enddo ; enddo @@ -654,9 +657,10 @@ subroutine sum_En(G, US, CS, En, label) ! Local variables real :: En_sum ! The total energy in MKS units for potential output [J] integer :: a - ! real :: En_sum_diff, En_sum_pdiff + ! real :: En_sum_diff ! Change in energy from the expected value [J] + ! real :: En_sum_pdiff ! Percentage change in energy from the expected value [nondim] ! character(len=160) :: mesg ! The text of an error message - ! real :: days + ! real :: days ! The time in days for use in output messages [days] En_sum = 0.0 do a=1,CS%nAngle @@ -808,29 +812,33 @@ subroutine refract(En, cn, freq, dt, G, US, NAngle, use_PPMang) ! Local variables integer, parameter :: stencil = 2 real, dimension(SZI_(G),1-stencil:NAngle+stencil) :: & - En2d + En2d ! The internal gravity wave energy density in zonal slices [R Z3 T-2 ~> J m-2] real, dimension(1-stencil:NAngle+stencil) :: & - cos_angle, sin_angle + cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(SZI_(G)) :: & - Dk_Dt_Kmag, Dl_Dt_Kmag + Dk_Dt_Kmag, Dl_Dt_Kmag ! Rates of angular refraction [T-1 ~> s-1] real, dimension(SZI_(G),0:nAngle) :: & - Flux_E + Flux_E ! The flux of energy between successive angular wedges within a timestep [R Z3 T-2 ~> J m-2] real, dimension(SZI_(G),SZJ_(G),1-stencil:NAngle+stencil) :: & - CFL_ang - real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point - real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: cn_v !< Internal wave group velocity at V-point - real, dimension(G%isd:G%ied,G%jsd:G%jed) :: cnmask !< Local mask for group velocity + CFL_ang ! The CFL number of angular refraction [nondim] + real, dimension(G%IsdB:G%IedB,G%jsd:G%jed) :: cn_u !< Internal wave group velocity at U-point [L T-1 ~> m s-1] + real, dimension(G%isd:G%ied,G%JsdB:G%JedB) :: cn_v !< Internal wave group velocity at V-point [L T-1 ~> m s-1] + real, dimension(G%isd:G%ied,G%jsd:G%jed) :: cnmask !< Local mask for group velocity [nondim] real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. real :: favg ! The average Coriolis parameter at a point [T-1 ~> s-1]. real :: df_dy, df_dx ! The x- and y- gradients of the Coriolis parameter [T-1 L-1 ~> s-1 m-1]. real :: dlnCn_dx ! The x-gradient of the wave speed divided by itself [L-1 ~> m-1]. real :: dlnCn_dy ! The y-gradient of the wave speed divided by itself [L-1 ~> m-1]. - real :: Angle_size, dt_Angle_size, angle - real :: Ifreq, Kmag2, I_Kmag + real :: Angle_size ! The size of each wedge of angles [rad] + real :: dt_Angle_size ! The time step divided by the angle size [T rad-1 ~> s rad-1] + real :: angle ! The central angle of each wedge [rad] + real :: Ifreq ! The inverse of the wave frequency [T ~> s] + real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] + real :: I_Kmag ! The inverse of the magnitude of the horizontal wavenumber [L ~> m] real :: cn_subRO ! A tiny wave speed to prevent division by zero [L T-1 ~> m s-1] integer :: is, ie, js, je, asd, aed, na integer :: i, j, a - real :: wgt1, wgt2 + real :: wgt1, wgt2 ! Weights in an average, both of which may be 0 [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; na = size(En,3) asd = 1-stencil ; aed = NAngle+stencil @@ -938,18 +946,18 @@ end subroutine refract !! piecewise parabolic scheme. This needs to be called from within i and j spatial loops. subroutine PPM_angular_advect(En2d, CFL_ang, Flux_En, NAngle, dt, halo_ang) integer, intent(in) :: NAngle !< The number of wave orientations in the - !! discretized wave energy spectrum. + !! discretized wave energy spectrum [nondim] real, intent(in) :: dt !< Time increment [T ~> s]. integer, intent(in) :: halo_ang !< The halo size in angular space real, dimension(1-halo_ang:NAngle+halo_ang), & intent(in) :: En2d !< The internal gravity wave energy density as a !! function of angular resolution [R Z3 T-2 ~> J m-2]. real, dimension(1-halo_ang:NAngle+halo_ang), & - intent(in) :: CFL_ang !< The CFL number of the energy advection across angles + intent(in) :: CFL_ang !< The CFL number of the energy advection across angles [nondim] real, dimension(0:NAngle), intent(out) :: Flux_En !< The time integrated internal wave energy flux !! across angles [R Z3 T-2 ~> J m-2]. ! Local variables - real :: flux + real :: flux ! The internal wave energy flux across angles [R Z3 T-3 ~> W m-2]. real :: u_ang ! Angular propagation speed [Rad T-1 ~> Rad s-1] real :: Angle_size ! The size of each orientation wedge in radians [Rad] real :: I_Angle_size ! The inverse of the orientation wedges [Rad-1] @@ -1052,11 +1060,16 @@ subroutine propagate(En, cn, freq, dt, G, US, CS, NAngle, residual_loss) real, dimension(SZI_(G),SZJB_(G)) :: & speed_y ! The magnitude of the group velocity at the Cv points [L T-1 ~> m s-1]. real, dimension(0:NAngle) :: & - cos_angle, sin_angle + cos_angle, sin_angle ! The cosine and sine of each angle [nondim] real, dimension(NAngle) :: & - Cgx_av, Cgy_av, dCgx, dCgy + Cgx_av, & ! The average projection of the wedge into the x-direction [nondim] + Cgy_av, & ! The average projection of the wedge into the y-direction [nondim] + dCgx, & ! The difference in x-projections between the edges of each angular band [nondim]. + dCgy ! The difference in y-projections between the edges of each angular band [nondim]. real :: f2 ! The squared Coriolis parameter [T-2 ~> s-2]. - real :: Angle_size, I_Angle_size, angle + real :: Angle_size ! The size of each wedge of angles [rad] + real :: I_Angle_size ! The inverse of the size of each wedge of angles [rad-1] + real :: angle ! The central angle of each wedge [rad] real :: Ifreq ! The inverse of the frequency [T ~> s] real :: freq2 ! The frequency squared [T-2 ~> s-2] type(loop_bounds_type) :: LB @@ -1172,26 +1185,32 @@ subroutine propagate_corner_spread(En, energized_wedge, NAngle, speed, dt, G, CS type(loop_bounds_type), intent(in) :: LB !< A structure with the active energy loop bounds. ! Local variables integer :: i, j, ish, ieh, jsh, jeh, m - real :: TwoPi, Angle_size - real :: energized_angle ! angle through center of current wedge - real :: theta ! angle at edge of wedge - real :: Nsubrays ! number of sub-rays for averaging + real :: TwoPi ! The radius of the circumference of a circle to its radius [nondim] + real :: Angle_size ! The size of each angular wedge [radians] + real :: energized_angle ! angle through center of current wedge [radians] + real :: theta ! angle at edge of each sub-wedge [radians] + real :: Nsubrays ! number of sub-rays for averaging [nondim] ! count includes the two rays that bound the current wedge, ! i.e. those at -dtheta/2 and +dtheta/2 from energized angle - real :: I_Nsubwedges ! inverse of number of sub-wedges - real :: cos_thetaDT, sin_thetaDT ! cos(theta)*dt, sin(theta)*dt - real :: xNE,xNW,xSW,xSE,yNE,yNW,ySW,ySE ! corner point coordinates of advected fluid parcel - real :: CFL_xNE,CFL_xNW,CFL_xSW,CFL_xSE,CFL_yNE,CFL_yNW,CFL_ySW,CFL_ySE,CFL_max - real :: xN,xS,xE,xW,yN,yS,yE,yW ! intersection point coordinates of parcel edges and grid - real :: xCrn,yCrn ! grid point contained within advected fluid parcel - real :: xg,yg ! grid point of interest - real :: slopeN,slopeW,slopeS,slopeE, bN,bW,bS,bE ! parameters defining parcel sides - real :: aNE,aN,aNW,aW,aSW,aS,aSE,aE,aC ! sub-areas of advected parcel - real :: a_total ! total area of advected parcel - ! real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x,y ! coordinates of cell corners - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx,Idy ! inverse of dx,dy at cell corners - real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx,dy ! dx,dy at cell corners + real :: I_Nsubwedges ! inverse of number of sub-wedges [nondim] + real :: cos_thetaDT, sin_thetaDT ! cos(theta)*dt, sin(theta)*dt [T ~> s] + real :: xNE, xNW, xSW, xSE ! corner point x-coordinates of advected fluid parcel [L ~> m] + real :: yNE, yNW, ySW, ySE ! corner point y-coordinates of advected fluid parcel [L ~> m] + real :: CFL_xNE, CFL_xNW, CFL_xSW, CFL_xSE ! Various x-direction CFL numbers for propagation [nondim] + real :: CFL_yNE, CFL_yNW, CFL_ySW, CFL_ySE ! Various y-direction CFL numbers for propagation [nondim] + real :: CFL_max ! The maximum of the x- and y-CFL numbers for propagation [nondim] + real :: xN, xS, xE, xW ! intersection point x-coordinates of parcel edges and grid [L ~> m] + real :: yN, yS, yE, yW ! intersection point y-coordinates of parcel edges and grid [L ~> m] + real :: xCrn, yCrn ! Coordinates of grid point contained within advected fluid parcel [L ~> m] + real :: xg, yg ! Positions of grid point of interest [L ~> m] + real :: slopeN, slopeW, slopeS, slopeE ! Coordinate-space slopes of parcel sides [nondim] + real :: bN, bW, bS, bE ! parameters defining parcel sides [L ~> m] + real :: aNE, aN, aNW, aW, aSW, aS, aSE, aE, aC ! sub-areas of advected parcel [L2 ~> m2] + real :: a_total ! total area of advected parcel [L2 ~> m2] + ! real :: a1,a2,a3,a4 ! areas used in calculating polygon areas (sub-areas) of advected parcel [L2 ~> m2] + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: x, y ! coordinates of cell corners [L ~> m] + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: Idx, Idy ! inverse of dx,dy at cell corners [L-1 ~> m-1] + real, dimension(G%IsdB:G%IedB,G%Jsd:G%Jed) :: dx, dy ! dx,dy at cell corners [L ~> m] real, dimension(2) :: E_new ! Energy in cell after advection for subray [R Z3 T-2 ~> J m-2]; set size ! here to define Nsubrays - this should be made an input option later! @@ -1449,9 +1468,9 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res real, dimension(G%IsdB:G%IedB,G%jsd:G%jed), & intent(in) :: speed_x !< The magnitude of the group velocity at the !! Cu points [L T-1 ~> m s-1]. - real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band. + real, dimension(Nangle), intent(in) :: Cgx_av !< The average x-projection in each angular band [nondim] real, dimension(Nangle), intent(in) :: dCgx !< The difference in x-projections between the - !! edges of each angular band. + !! edges of each angular band [nondim]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control structure @@ -1465,8 +1484,8 @@ subroutine propagate_x(En, speed_x, Cgx_av, dCgx, dt, G, US, Nangle, CS, LB, res real, dimension(SZIB_(G),SZJ_(G)) :: & flux_x ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. real, dimension(SZIB_(G)) :: & - cg_p, flux1 - !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p + cg_p, & ! The x-direction group velocity [L T-1 ~> m s-1] + flux1 ! A 1-d copy of the x-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! Left and right energy fluxes [R Z3 L2 T-2 ~> J] integer :: i, j, ish, ieh, jsh, jeh, a @@ -1545,8 +1564,9 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res EnL, EnR ! South and north face energy densities [R Z3 T-2 ~> J m-2]. real, dimension(SZI_(G),SZJB_(G)) :: & flux_y ! The internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. - real, dimension(SZI_(G)) :: cg_p, flux1 - !real, dimension(SZI_(G),SZJB_(G),Nangle) :: En_m, En_p + real, dimension(SZI_(G)) :: & + cg_p, & ! The y-direction group velocity [L T-1 ~> m s-1] + flux1 ! A 1-d copy of the y-direction internal wave energy flux [R Z3 L2 T-3 ~> J s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed,Nangle) :: & Fdt_m, Fdt_p! South and north energy fluxes [R Z3 L2 T-2 ~> J] integer :: i, j, ish, ieh, jsh, jeh, a @@ -1823,23 +1843,18 @@ subroutine teleport(En, NAngle, CS, G, LB) real :: TwoPi ! 2*pi = 6.2831853... [nondim] real :: Angle_size ! size of beam wedge [rad] real, dimension(1:NAngle) :: angle_i ! angle of incident ray wrt equator [rad] - real, dimension(1:NAngle) :: cos_angle, sin_angle + real, dimension(1:NAngle) :: cos_angle ! Cosine of the beam angle relative to eastward [nondim] + real, dimension(1:NAngle) :: sin_angle ! Sine of the beam angle relative to eastward [nondim] real :: En_tele ! energy to be "teleported" [R Z3 T-2 ~> J m-2] character(len=160) :: mesg ! The text of an error message integer :: i, j, a - !integer :: isd, ied, jsd, jed ! start and end local indices on data domain - ! ! (values include halos) - !integer :: isc, iec, jsc, jec ! start and end local indices on PE - ! ! (values exclude halos) integer :: ish, ieh, jsh, jeh ! start and end local indices on data domain ! leaving out outdated halo points (march in) integer :: id_g, jd_g ! global (decomposition-invariant) indices integer :: jos, ios ! offsets - real :: cos_normal, sin_normal, angle_wall - ! cos/sin of cross-ridge normal, ridge angle + real :: cos_normal, sin_normal ! cos/sin of cross-ridge normal direction [nondim] + real :: angle_wall ! The coastline angle or the complementary angle [radians] - !isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - !isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh TwoPi = 8.0*atan(1.0) @@ -1909,11 +1924,12 @@ subroutine correct_halo_rotation(En, test, G, NAngle) real, dimension(SZI_(G),SZJ_(G),2), & intent(in) :: test !< An x-unit vector that has been passed through !! the halo updates, to enable the rotation of the - !! wave energies in the halo region to be corrected. + !! wave energies in the halo region to be corrected [nondim]. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. ! Local variables - real, dimension(G%isd:G%ied,NAngle) :: En2d + real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density + ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new integer :: a, i, j, isd, ied, jsd, jed, m, fr @@ -1960,18 +1976,19 @@ end subroutine correct_halo_rotation !> Calculates left/right edge values for PPM reconstruction in x-direction. subroutine PPM_reconstruction_x(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. - real, parameter :: oneSixth = 1./6. - real :: h_ip1, h_im1 - real :: dMx, dMn + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, parameter :: oneSixth = 1./6. ! One sixth [nondim] + real :: h_ip1, h_im1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points + ! relative to the center point [R Z3 T-2 ~> J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2034,18 +2051,19 @@ end subroutine PPM_reconstruction_x !> Calculates left/right edge valus for PPM reconstruction in y-direction. subroutine PPM_reconstruction_y(h_in, h_l, h_r, G, LB, simple_2nd) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D). + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in a sector (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_l !< Left edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_r !< Right edge value of reconstruction (2D) [R Z3 T-2 ~> J m-2] type(loop_bounds_type), intent(in) :: LB !< A structure with the active loop bounds. logical, intent(in) :: simple_2nd !< If true, use the arithmetic mean !! energy densities as default edge values !! for a simple 2nd order scheme. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slopes. - real, parameter :: oneSixth = 1./6. - real :: h_jp1, h_jm1 - real :: dMx, dMn + real, dimension(SZI_(G),SZJ_(G)) :: slp ! The slope in energy density times the cell width [R Z3 T-2 ~> J m-2] + real, parameter :: oneSixth = 1./6. ! One sixth [nondim] + real :: h_jp1, h_jm1 ! The energy densities at adjacent points [R Z3 T-2 ~> J m-2] + real :: dMx, dMn ! The maximum and minimum of values of energy density at adjacent points + ! relative to the center point [R Z3 T-2 ~> J m-2] character(len=256) :: mesg ! The text of an error message integer :: i, j, isl, iel, jsl, jel, stencil @@ -2105,22 +2123,24 @@ end subroutine PPM_reconstruction_y !> Limits the left/right edge values of the PPM reconstruction !! to give a reconstruction that is positive-definite. Here this is -!! reinterpreted as giving a constant thickness if the mean thickness is less +!! reinterpreted as giving a constant value if the mean value is less !! than h_min, with a minimum of h_min otherwise. subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Thickness of layer (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value (2D). - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value (2D). - real, intent(in) :: h_min !< The minimum thickness that can be - !! obtained by a concave parabolic fit. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Energy density in each sector (2D) [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_L !< Left edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: h_R !< Right edge value of reconstruction [R Z3 T-2 ~> J m-2] + real, intent(in) :: h_min !< The minimum value that can be + !! obtained by a concave parabolic fit [R Z3 T-2 ~> J m-2] integer, intent(in) :: iis !< Start i-index for computations integer, intent(in) :: iie !< End i-index for computations integer, intent(in) :: jis !< Start j-index for computations integer, intent(in) :: jie !< End j-index for computations ! Local variables - real :: curv, dh, scale - integer :: i,j + real :: curv ! The cell-area normalized curvature [R Z3 T-2 ~> J m-2] + real :: dh ! The difference between the edge values [R Z3 T-2 ~> J m-2] + real :: scale ! A rescaling factor used to give a minimum cell value of at least h_min [nondim] + integer :: i, j do j=jis,jie ; do i=iis,iie ! This limiter prevents undershooting minima within the domain with @@ -2194,12 +2214,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure ! Local variables - real :: Angle_size ! size of wedges, rad - real, allocatable :: angles(:) ! orientations of wedge centers, rad + real :: Angle_size ! size of wedges [rad] + real, allocatable :: angles(:) ! orientations of wedge centers [rad] real, dimension(:,:), allocatable :: h2 ! topographic roughness scale squared [Z2 ~> m2] real :: kappa_itides ! characteristic topographic wave number [L-1 ~> m-1] real, dimension(:,:), allocatable :: ridge_temp ! array for temporary storage of flags - ! of cells with double-reflecting ridges + ! of cells with double-reflecting ridges [nondim] logical :: use_int_tides, use_temperature real :: kappa_h2_factor ! A roughness scaling factor [nondim] real :: RMS_roughness_frac ! The maximum RMS topographic roughness as a fraction of the @@ -2431,7 +2451,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (trim(refl_angle_file) /= '' ) call MOM_error(FATAL, & "REFL_ANGLE_FILE: "//trim(filename)//" not found") endif - ! replace NANs with null value + ! replace NaNs with null value do j=G%jsc,G%jec ; do i=G%isc,G%iec if (is_NaN(CS%refl_angle(i,j))) CS%refl_angle(i,j) = CS%nullangle enddo ; enddo @@ -2526,7 +2546,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) Time, 'East face unblocked width', 'm', conversion=US%L_to_m) CS%id_land_mask = register_diag_field('ocean_model', 'land_mask', diag%axesT1, & Time, 'Land mask', 'nondim') - ! Output reflection parameters as diags here (not needed every timestep) + ! Output reflection parameters as diagnostics here (not needed every timestep) if (CS%id_refl_ang > 0) call post_data(CS%id_refl_ang, CS%refl_angle, CS%diag) if (CS%id_refl_pref > 0) call post_data(CS%id_refl_pref, CS%refl_pref, CS%diag) if (CS%id_trans > 0) call post_data(CS%id_trans, CS%trans, CS%diag) @@ -2584,21 +2604,21 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) axes_ang, is_h_point=.true.) do fr=1,CS%nFreq ; write(freq_name(fr), '("freq",i1)') fr ; enddo do m=1,CS%nMode ; do fr=1,CS%nFreq - ! Register 2-D energy density (summed over angles) for each freq and mode + ! Register 2-D energy density (summed over angles) for each frequency and mode write(var_name, '("Itide_En_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_mode(fr,m) = register_diag_field('ocean_model', var_name, & diag%axesT1, Time, var_descript, 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 3-D (i,j,a) energy density for each freq and mode + ! Register 3-D (i,j,a) energy density for each frequency and mode write(var_name, '("Itide_En_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide angular energy density in frequency ",i1," mode ",i1)') fr, m CS%id_En_ang_mode(fr,m) = register_diag_field('ocean_model', var_name, & axes_ang, Time, var_descript, 'J m-2 band-1', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 2-D energy loss (summed over angles) for each freq and mode + ! Register 2-D energy loss (summed over angles) for each frequency and mode ! wave-drag only write(var_name, '("Itide_wavedrag_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m @@ -2612,7 +2632,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 3-D (i,j,a) energy loss for each freq and mode + ! Register 3-D (i,j,a) energy loss for each frequency and mode ! wave-drag only write(var_name, '("Itide_wavedrag_loss_ang_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to wave-drag from frequency ",i1," mode ",i1)') fr, m @@ -2620,14 +2640,14 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) axes_ang, Time, var_descript, 'W m-2 band-1', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) - ! Register 2-D period-averaged near-bottom horizontal velocity for each freq and mode + ! Register 2-D period-averaged near-bottom horizontal velocity for each frequency and mode write(var_name, '("Itide_Ub_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Near-bottom horizontal velocity for frequency ",i1," mode ",i1)') fr, m CS%id_Ub_mode(fr,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) - ! Register 2-D horizonal phase velocity for each freq and mode + ! Register 2-D horizontal phase velocity for each frequency and mode write(var_name, '("Itide_cp_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Horizontal phase velocity for frequency ",i1," mode ",i1)') fr, m CS%id_cp_mode(fr,m) = register_diag_field('ocean_model', var_name, & @@ -2643,7 +2663,7 @@ end subroutine internal_tides_init !> This subroutine deallocates the memory associated with the internal tides control structure subroutine internal_tides_end(CS) - type(int_tide_CS), intent(inout) :: CS !< Internal tide control struct + type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure if (allocated(CS%En)) deallocate(CS%En) if (allocated(CS%frequency)) deallocate(CS%frequency) From e85260a368dd445f358f026bb087e7e7ceb1d13a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Jan 2023 18:13:38 -0500 Subject: [PATCH 198/629] Document units of variables in MOM_tidal_forcing Added or amended comments to document the units of 13 internal variables in MOM_tidal_forcing.F90, and corrected a few spelling errors in comments. Only comments are changed, and all answers are bitwise identical. --- .../lateral/MOM_tidal_forcing.F90 | 50 ++++++++++--------- 1 file changed, 26 insertions(+), 24 deletions(-) diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 63b0ced556..b2fd8f0ea5 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -30,11 +30,10 @@ module MOM_tidal_forcing !! constituents that could be used. !> Simple type to store astronomical longitudes used to calculate tidal phases. type, public :: astro_longitudes - real :: & - s, & !< Mean longitude of moon [rad] - h, & !< Mean longitude of sun [rad] - p, & !< Mean longitude of lunar perigee [rad] - N !< Longitude of ascending node [rad] + real :: s !< Mean longitude of moon [rad] + real :: h !< Mean longitude of sun [rad] + real :: p !< Mean longitude of lunar perigee [rad] + real :: N !< Longitude of ascending node [rad] end type astro_longitudes !> The control structure for the MOM_tidal_forcing module @@ -67,13 +66,15 @@ module MOM_tidal_forcing type(astro_longitudes) :: tidal_longitudes !< Astronomical longitudes used to calculate !! tidal phases at t = 0. real, allocatable :: & - sin_struct(:,:,:), & !< The sine and cosine based structures that can - cos_struct(:,:,:), & !< be associated with the astronomical forcing [nondim]. - cosphasesal(:,:,:), & !< The cosine and sine of the phase of the - sinphasesal(:,:,:), & !< self-attraction and loading amphidromes [nondim]. + sin_struct(:,:,:), & !< The sine based structures that can be associated with + !! the astronomical forcing [nondim]. + cos_struct(:,:,:), & !< The cosine based structures that can be associated with + !! the astronomical forcing [nondim]. + cosphasesal(:,:,:), & !< The cosine of the phase of the self-attraction and loading amphidromes [nondim]. + sinphasesal(:,:,:), & !< The sine of the phase of the self-attraction and loading amphidromes [nondim]. ampsal(:,:,:), & !< The amplitude of the SAL [Z ~> m]. - cosphase_prev(:,:,:), & !< The cosine and sine of the phase of the - sinphase_prev(:,:,:), & !< amphidromes in the previous tidal solutions [nondim]. + cosphase_prev(:,:,:), & !< The cosine of the phase of the amphidromes in the previous tidal solutions [nondim]. + sinphase_prev(:,:,:), & !< The sine of the phase of the amphidromes in the previous tidal solutions [nondim]. amp_prev(:,:,:) !< The amplitude of the previous tidal solution [Z ~> m]. type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL integer :: sal_sht_Nd !< Maximum degree for SHT [nondim] @@ -95,7 +96,7 @@ module MOM_tidal_forcing !! (their Equation I.71), which are based on Schureman, 1958. !! For simplicity, the time associated with time_ref should !! be at midnight. These formulas also only make sense if -!! the calendar is gregorian. +!! the calendar is Gregorian. subroutine astro_longitudes_init(time_ref, longitudes) type(time_type), intent(in) :: time_ref !> Time to calculate longitudes for. type(astro_longitudes), intent(out) :: longitudes !> Lunar and solar longitudes at time_ref. @@ -128,7 +129,7 @@ end subroutine astro_longitudes_init function eq_phase(constit, longitudes) character (len=2), intent(in) :: constit !> Name of constituent (e.g., M2). type(astro_longitudes), intent(in) :: longitudes !> Mean longitudes calculated using astro_longitudes_init - real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... + real, parameter :: PI = 4.0 * atan(1.0) !> 3.14159... [nondim] real :: eq_phase !> The equilibrium phase argument for the constituent [rad]. select case (constit) @@ -248,13 +249,13 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. - type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control struct + type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure ! Local variables real, dimension(SZI_(G), SZJ_(G)) :: & - phase, & ! The phase of some tidal constituent. - lat_rad, lon_rad ! Latitudes and longitudes of h-points in radians. - real :: deg_to_rad + phase, & ! The phase of some tidal constituent [radians]. + lat_rad, lon_rad ! Latitudes and longitudes of h-points [radians]. + real :: deg_to_rad ! A conversion factor from degrees to radians [radian degree-1] real, dimension(MAX_CONSTITUENTS) :: freq_def ! Default frequency for each tidal constituent [s-1] real, dimension(MAX_CONSTITUENTS) :: phase0_def ! Default reference phase for each tidal constituent [rad] real, dimension(MAX_CONSTITUENTS) :: amp_def ! Default amplitude for each tidal constituent [m] @@ -581,8 +582,8 @@ subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] ! Local variables - real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames - real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] integer :: n_tot ! Size of the stored Love numbers integer :: n, m, l @@ -615,8 +616,9 @@ subroutine find_in_files(filenames, varname, array, G, scale) character(len=*), dimension(:), intent(in) :: filenames !< The names of the files to search for the named variable character(len=*), intent(in) :: varname !< The name of the variable to read type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array !< The array to fill with the data - real, optional, intent(in) :: scale !< A factor by which to rescale the array. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: array !< The array to fill with the data [arbitrary] + real, optional, intent(in) :: scale !< A factor by which to rescale the array to translate it + !! into its desired units [arbitrary] ! Local variables integer :: nf @@ -667,7 +669,7 @@ end subroutine tidal_forcing_sensitivity !! column mass anomalies. subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< The time for the caluculation. + type(time_type), intent(in) :: Time !< The time for the calculation. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from !! a time-mean geoid [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height @@ -681,7 +683,7 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) real :: now ! The relative time compared with the tidal reference [T ~> s] real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] real :: cosomegat, sinomegat ! The components of the phase [nondim] - real :: eta_prop ! The nondimenional constant of proportionality beteen eta and eta_tidal [nondim] + real :: eta_prop ! The nondimenional constant of proportionality between eta and eta_tidal [nondim] integer :: i, j, c, m, 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 @@ -754,7 +756,7 @@ subroutine calc_SAL_sht(eta, eta_sal, G, CS) !! a time-mean geoid [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from !! self-attraction and loading [Z ~> m]. - type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control struct + type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure ! Local variables integer :: n, m, l From a139bc4e2fecd24a0d61b93fee92e968308e722c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Jan 2023 18:14:01 -0500 Subject: [PATCH 199/629] Better terminology in thickness_diffuse module Changed the terminology in the thickness_diffuse module to be more accurate, specifically changing phrases like "thickness diffusion" to "isopycnal height diffusion". The two are only the same in the limit of a uniform bottom depth, and isopycnal coordinate and a vertically uniform diffusivity, and the new phrases reflect what is actually being done. In addition, the "Brunt-Vaisala frequency" is now being described as the "buoyancy frequency" for greater clarity of language and less use of jargon. Some units were also added to the descriptions using the standard syntax used elsewhere in the code. For now, these changes are restricted to the internal comments, so that there are no changes in the MOM_parameter_doc or output files. All answers are bitwise identical. --- .../lateral/MOM_thickness_diffuse.F90 | 134 +++++++++--------- 1 file changed, 69 insertions(+), 65 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index b4092d3d43..4e12aeeaad 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1,4 +1,4 @@ -!> Thickness diffusion (or Gent McWilliams) +!> Isopycnal height diffusion (or Gent McWilliams diffusion) module MOM_thickness_diffuse ! This file is part of MOM6. See LICENSE.md for the license. @@ -33,17 +33,17 @@ module MOM_thickness_diffuse ! 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. -!> Control structure for thickness diffusion +!> Control structure for thickness_diffuse type, public :: thickness_diffuse_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. real :: Khth !< Background isopycnal depth diffusivity [L2 T-1 ~> m2 s-1] real :: Khth_Slope_Cff !< Slope dependence coefficient of Khth [nondim] - real :: max_Khth_CFL !< Maximum value of the diffusive CFL for thickness diffusion [nondim] + real :: max_Khth_CFL !< Maximum value of the diffusive CFL for isopycnal height diffusion [nondim] real :: Khth_Min !< Minimum value of Khth [L2 T-1 ~> m2 s-1] real :: Khth_Max !< Maximum value of Khth [L2 T-1 ~> m2 s-1], or 0 for no max - real :: Kh_eta_bg !< Background interface height diffusivity [L2 T-1 ~> m2 s-1] + real :: Kh_eta_bg !< Background isopycnal height diffusivity [L2 T-1 ~> m2 s-1] real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give - !! the interface height diffusivity [L T-1 ~> m s-1] + !! the isopycnal height diffusivity [L T-1 ~> m s-1] real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. real :: kappa_smooth !< Vertical diffusivity used to interpolate more !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. @@ -70,14 +70,14 @@ module MOM_thickness_diffuse logical :: MEKE_GEOMETRIC !< If true, uses the GM coefficient formulation from the GEOMETRIC !! framework (Marshall et al., 2012) real :: MEKE_GEOMETRIC_alpha!< The nondimensional coefficient governing the efficiency of - !! the GEOMETRIC thickness diffusion [nondim] + !! the GEOMETRIC isopycnal height diffusion [nondim] real :: MEKE_GEOMETRIC_epsilon !< Minimum Eady growth rate for the GEOMETRIC thickness !! diffusivity [T-1 ~> s-1]. integer :: MEKE_GEOM_answer_date !< The vintage of the expressions in the MEKE_GEOMETRIC !! calculation. Values below 20190101 recover the answers from the !! original implementation, while higher values use expressions that !! satisfy rotational symmetry. - logical :: Use_KH_in_MEKE !< If true, uses the thickness diffusivity calculated here to diffuse MEKE. + logical :: Use_KH_in_MEKE !< If true, uses the isopycnal height diffusivity calculated here to diffuse MEKE. real :: MEKE_min_depth_diff !< The minimum total depth over which to average the diffusivity !! used for MEKE [H ~> m or kg m-2]. When the total depth is less !! than this, the diffusivity is scaled away. @@ -89,16 +89,16 @@ module MOM_thickness_diffuse !! temperature gradient in the deterministic part of the Stanley parameterization. !! Negative values disable the scheme. [nondim] logical :: read_khth !< If true, read a file containing the spatially varying horizontal - !! thickness diffusivity + !! isopycnal height diffusivity logical :: use_stanley_gm !< If true, also use the Stanley parameterization in MOM_thickness_diffuse type(diag_ctrl), pointer :: diag => NULL() !< structure used to regulate timing of diagnostics - real, allocatable :: GMwork(:,:) !< Work by thickness diffusivity [R Z L2 T-3 ~> W m-2] + real, allocatable :: GMwork(:,:) !< Work by isopycnal height diffusion [R Z L2 T-3 ~> W m-2] real, allocatable :: diagSlopeX(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] real, allocatable :: diagSlopeY(:,:,:) !< Diagnostic: zonal neutral slope [Z L-1 ~> nondim] - real, allocatable :: Kh_eta_u(:,:) !< Interface height diffusivities at u points [L2 T-1 ~> m2 s-1] - real, allocatable :: Kh_eta_v(:,:) !< Interface height diffusivities in v points [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_u(:,:) !< Isopycnal height diffusivities at u points [L2 T-1 ~> m2 s-1] + real, allocatable :: Kh_eta_v(:,:) !< Isopycnal height diffusivities in v points [L2 T-1 ~> m2 s-1] real, allocatable :: KH_u_GME(:,:,:) !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] real, allocatable :: KH_v_GME(:,:,:) !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] @@ -116,8 +116,8 @@ module MOM_thickness_diffuse contains -!> Calculates thickness diffusion coefficients and applies thickness diffusion to layer -!! thicknesses, h. Diffusivities are limited to ensure stability. +!> Calculates isopycnal height diffusion coefficients and applies isopycnal height diffusion +!! by modifying to the layer thicknesses, h. Diffusivities are limited to ensure stability. !! Also returns along-layer mass fluxes used in the continuity equation. subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp, CS) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -133,7 +133,7 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp type(MEKE_type), intent(inout) :: MEKE !< MEKE fields type(VarMix_CS), target, intent(in) :: VarMix !< Variable mixing coefficients type(cont_diag_ptrs), intent(inout) :: CDp !< Diagnostics for the continuity equation - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse ! Local variables real :: e(SZI_(G),SZJ_(G),SZK_(GV)+1) ! heights of interfaces, relative to mean ! sea level [Z ~> m], positive up. @@ -141,13 +141,13 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp real :: vhD(SZI_(G),SZJB_(G),SZK_(GV)) ! Diffusive v*h fluxes [L2 H T-1 ~> m3 s-1 or kg s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & - KH_u, & ! interface height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + KH_u, & ! Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] int_slope_u ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at u points. The physically correct ! slopes occur at 0, while 1 is used for numerical closures [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & - KH_v, & ! interface height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + KH_v, & ! Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] int_slope_v ! A nondimensional ratio from 0 to 1 that gives the relative ! weighting of the interface slopes to that calculated also ! using density gradients at v points. The physically correct @@ -156,23 +156,25 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp KH_t ! diagnosed diffusivity at tracer points [L2 T-1 ~> m2 s-1] real, dimension(SZIB_(G),SZJ_(G)) :: & - KH_u_CFL ! The maximum stable interface height diffusivity at u grid points [L2 T-1 ~> m2 s-1] + KH_u_CFL ! The maximum stable isopycnal height diffusivity at u grid points [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - KH_v_CFL ! The maximum stable interface height diffusivity at v grid points [L2 T-1 ~> m2 s-1] + KH_v_CFL ! The maximum stable isopycnal height diffusivity at v grid points [L2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & htot ! The sum of the total layer thicknesses [H ~> m or kg m-2] - real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) - real :: Khth_Loc_v(SZI_(G),SZJB_(G)) + real :: Khth_Loc_u(SZIB_(G),SZJ_(G)) ! The isopycnal height diffusivity at u points [L2 T-1 ~> m2 s-1] + real :: Khth_Loc_v(SZI_(G),SZJB_(G)) ! The isopycnal height diffusivity at v points [L2 T-1 ~> m2 s-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real, dimension(:,:), pointer :: cg1 => null() !< Wave speed [L T-1 ~> m s-1] + real :: hu(SZI_(G),SZJ_(G)) ! A thickness-based mask at u points, used for diagnostics [nondim] + real :: hv(SZI_(G),SZJ_(G)) ! A thickness-based mask at v points, used for diagnostics [nondim] + real :: KH_u_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at u-points averaged + ! to layer centers [L2 T-1 ~> m2 s-1] + real :: KH_v_lay(SZI_(G),SZJ_(G)) ! Diagnostic of isopycnal height diffusivities at v-points averaged + ! to layer centers [L2 T-1 ~> m2 s-1] logical :: use_VarMix, Resoln_scaled, Depth_scaled, use_stored_slopes, khth_use_ebt_struct, use_Visbeck logical :: use_QG_Leith integer :: i, j, k, is, ie, js, je, nz - real :: hu(SZI_(G),SZJ_(G)) ! u-thickness [H ~> m or kg m-2] - real :: hv(SZI_(G),SZJ_(G)) ! v-thickness [H ~> m or kg m-2] - real :: KH_u_lay(SZI_(G),SZJ_(G)) ! Thickness diffusivities [L2 T-1 ~> m2 s-1] - real :: KH_v_lay(SZI_(G),SZJ_(G)) ! layer ave thickness diffusivities [L2 T-1 ~> m2 s-1] if (.not. CS%initialized) call MOM_error(FATAL, "MOM_thickness_diffuse: "//& "Module must be initialized before it is used.") @@ -592,9 +594,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV 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] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Kh_u !< Thickness diffusivity on interfaces + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Kh_u !< Isopycnal height diffusivity !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Kh_v !< Thickness diffusivity on interfaces + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Kh_v !< Isopycnal height diffusivity !! at v points [L2 T-1 ~> m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(out) :: uhD !< Zonal mass fluxes @@ -604,7 +606,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real, dimension(:,:), pointer :: cg1 !< Wave speed [L T-1 ~> m s-1] real, intent(in) :: dt !< Time increment [T ~> s] type(MEKE_type), intent(inout) :: MEKE !< MEKE fields - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration of @@ -663,8 +665,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV T_hr, & ! Temperature on the interface at the h (+1) point [C ~> degC]. S_hr, & ! Salinity on the interface at the h (+1) point [S ~> ppt]. pres_hr ! Pressure on the interface at the h (+1) point [R L2 T-2 ~> Pa]. - real :: Work_u(SZIB_(G),SZJ_(G)) ! The work being done by the thickness - real :: Work_v(SZI_(G),SZJB_(G)) ! diffusion integrated over a cell [R Z L4 T-3 ~> W ] + real :: Work_u(SZIB_(G),SZJ_(G)) ! The work done by the isopycnal height diffusion + ! integrated over u-point water columns [R Z L4 T-3 ~> W] + real :: Work_v(SZI_(G),SZJB_(G)) ! The work done by the isopycnal height diffusion + ! integrated over v-point water columns [R Z L4 T-3 ~> W] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] ! The calculation is equal to h * S^2 * N^2 * kappa_GM. @@ -1436,7 +1440,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (find_work) then ; do j=js,je ; do i=is,ie - ! Note that the units of Work_v and Work_u are W, while Work_h is W m-2. + ! Note that the units of Work_v and Work_u are [R Z L4 T-3 ~> W], while Work_h is in [R Z L2 T-3 ~> W m-2]. Work_h = 0.5 * G%IareaT(i,j) * & ((Work_u(I-1,j) + Work_u(I,j)) + (Work_v(i,J-1) + Work_v(i,J))) if (allocated(CS%GMwork)) CS%GMwork(i,j) = Work_h @@ -1499,28 +1503,28 @@ subroutine streamfn_solver(nk, c2_h, hN2, sfn) end subroutine streamfn_solver -!> Add a diffusivity that acts on the interface heights, regardless of the densities +!> Add a diffusivity that acts on the isopycnal heights, regardless of the densities subroutine add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, Kh_u_CFL, Kh_v_CFL, int_slope_u, int_slope_v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness diffusion - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness_diffuse + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Isopycnal height diffusivity !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces - !! at v points [L2 T-1 ~> m2 s-1] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity - !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Isopycnal height diffusivity !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable isopycnal height + !! diffusivity at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable isopycnal height + !! diffusivity at v points [L2 T-1 ~> m2 s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. ! Local variables integer :: i, j, k, is, ie, js, je, nz @@ -1541,7 +1545,7 @@ subroutine add_interface_Kh(G, GV, US, CS, Kh_u, Kh_v, Kh_u_CFL, Kh_v_CFL, int_s end subroutine add_interface_Kh -!> Modifies thickness diffusivities to untangle layer structures +!> Modifies isopycnal height diffusivities to untangle layer structures subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV, US, CS, & int_slope_u, int_slope_v) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -1549,17 +1553,17 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV 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] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface positions [Z ~> m] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Thickness diffusivity on interfaces - !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Thickness diffusivity on interfaces - !! at v points [L2 T-1 ~> m2 s-1] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable thickness diffusivity + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kh_u !< Isopycnal height diffusivity !! at u points [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable thickness diffusivity + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: Kh_v !< Isopycnal height diffusivity !! at v points [L2 T-1 ~> m2 s-1] + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Kh_u_CFL !< Maximum stable isopycnal height + !! diffusivity at u points [L2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Kh_v_CFL !< Maximum stable isopycnal height + !! diffusivity at v points [L2 T-1 ~> m2 s-1] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure real, intent(in) :: dt !< Time increment [T ~> s] - type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for thickness_diffuse real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration @@ -1573,10 +1577,10 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV de_top ! The distances between the top of a layer and the top of the ! region where the detangling is applied [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & - Kh_lay_u ! The tentative interface height diffusivity for each layer at + Kh_lay_u ! The tentative isopycnal height diffusivity for each layer at ! u points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & - Kh_lay_v ! The tentative interface height diffusivity for each layer at + Kh_lay_v ! The tentative isopycnal height diffusivity for each layer at ! v points [L2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & de_bot ! The distances from the bottom of the region where the @@ -1958,7 +1962,7 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV end subroutine add_detangling_Kh -!> Initialize the thickness diffusion module/structure +!> Initialize the isopycnal height diffusion module and its control structure subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(time_type), intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure @@ -1967,7 +1971,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity equation diagnostics - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse ! Local variables character(len=40) :: mdl = "MOM_thickness_diffuse" ! This module's name. @@ -2026,9 +2030,8 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call pass_var(CS%khth2d, G%domain) endif call get_param(param_file, mdl, "KHTH_SLOPE_CFF", CS%KHTH_Slope_Cff, & - "The nondimensional coefficient in the Visbeck formula "//& - "for the interface depth diffusivity", units="nondim", & - default=0.0) + "The nondimensional coefficient in the Visbeck formula for "//& + "the interface depth diffusivity", units="nondim", default=0.0) call get_param(param_file, mdl, "KHTH_MIN", CS%KHTH_Min, & "The minimum horizontal thickness diffusivity.", & default=0.0, units="m2 s-1", scale=US%m_to_L**2*US%T_to_s) @@ -2246,14 +2249,14 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) end subroutine thickness_diffuse_init -!> Copies ubtav and vbtav from private type into arrays +!> Copies KH_u_GME and KH_v_GME from private type into arrays provided as arguments subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) type(thickness_diffuse_CS), intent(in) :: CS !< Control structure for this module type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: KH_u_GME !< interface height + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: KH_u_GME !< Isopycnal height !! diffusivities at u-faces [L2 T-1 ~> m2 s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: KH_v_GME !< interface height + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: KH_v_GME !< Isopycnal height !! diffusivities at v-faces [L2 T-1 ~> m2 s-1] ! Local variables integer :: i,j,k @@ -2268,9 +2271,9 @@ subroutine thickness_diffuse_get_KH(CS, KH_u_GME, KH_v_GME, G, GV) end subroutine thickness_diffuse_get_KH -!> Deallocate the thickness diffusion control structure +!> Deallocate the thickness_diffus3 control structure subroutine thickness_diffuse_end(CS, CDp) - type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness diffusion + type(thickness_diffuse_CS), intent(inout) :: CS !< Control structure for thickness_diffuse type(cont_diag_ptrs), intent(inout) :: CDp !< Continuity diagnostic control structure if (CS%id_slope_x > 0) deallocate(CS%diagSlopeX) @@ -2292,9 +2295,9 @@ end subroutine thickness_diffuse_end !> \namespace mom_thickness_diffuse !! -!! \section section_gm Thickness diffusion (aka Gent-McWilliams) +!! \section section_gm Isopycnal height diffusion (aka Gent-McWilliams) !! -!! Thickness diffusion is implemented via along-layer mass fluxes +!! Isopycnal height diffusion is implemented via along-layer mass fluxes !! \f[ !! h^\dagger \leftarrow h^n - \Delta t \nabla \cdot ( \vec{uh}^* ) !! \f] @@ -2304,7 +2307,8 @@ end subroutine thickness_diffuse_end !! \vec{uh}^* = \delta_k \vec{\psi} . !! \f] !! -!! The GM implementation of thickness diffusion made the streamfunction proportional to the potential density slope +!! The GM implementation of isopycnal height diffusion made the streamfunction proportional +!! to the potential density slope !! \f[ !! \vec{\psi} = - \kappa_h \frac{\nabla_z \rho}{\partial_z \rho} !! = \frac{g\kappa_h}{\rho_o} \frac{\nabla \rho}{N^2} = \kappa_h \frac{M^2}{N^2} @@ -2324,12 +2328,12 @@ end subroutine thickness_diffuse_end !! which recovers the previous streamfunction relation in the limit that \f$ c \rightarrow 0 \f$. !! Here, \f$c=\max(c_{min},c_g)\f$ is the maximum of either \f$c_{min}\f$ and either the first baroclinic mode !! wave-speed or the equivalent barotropic mode wave-speed. -!! \f$N_*^2 = \max(N^2,0)\f$ is a non-negative form of the square of the Brunt-Vaisala frequency. +!! \f$N_*^2 = \max(N^2,0)\f$ is a non-negative form of the square of the buoyancy frequency. !! The parameter \f$\gamma_F\f$ is used to reduce the vertical smoothing length scale. !! \f[ !! \kappa_h = \left( \kappa_o + \alpha_{s} L_{s}^2 < S N > + \alpha_{M} \kappa_{M} \right) r(\Delta x,L_d) !! \f] -!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the Brunt-Vaisala frequency, +!! where \f$ S \f$ is the isoneutral slope magnitude, \f$ N \f$ is the buoyancy frequency, !! \f$\kappa_{M}\f$ is the diffusivity calculated by the MEKE parameterization (mom_meke module) and !! \f$ r(\Delta x,L_d) \f$ is a function of the local resolution (ratio of grid-spacing, \f$\Delta x\f$, !! to deformation radius, \f$L_d\f$). The length \f$L_s\f$ is provided by the mom_lateral_mixing_coeffs module From f6b4a7d8c52ffa58b10d37b0fdc5bce07039619b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 23 Jan 2023 15:14:08 -0500 Subject: [PATCH 200/629] (*)Fix MEKE scaling issues with SmartRedis options This commit fixed a number of dimensional rescaling issues that were introduced to the MOM_MEKE code switch the SmartRedis related options. Specifically, it adds a missing scale factor for the time_interp_external call for the offline data Eddy kinetic energy used in MEKE when EKE_SOURCE=file. It also corrects the documented units and conversion factors for 4 diagnostics related to machine learning within MEKE. This commit also adds or amends comments to document the units of 27 internal variables in MOM_MEKE.F90, and corrected a few spelling errors in comments. All answers and output are bitwise identical in the existing MOM6-examples test suite, but there may be other examples where the units or rescaling of diagnostics are corrected or (in cases using EKE_SOURCE=file) where dimensional consistency testing issues are corrected for the solutions themselves. --- src/parameterizations/lateral/MOM_MEKE.F90 | 104 +++++++++++---------- 1 file changed, 55 insertions(+), 49 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 013cfd386a..8d6eda728d 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -45,7 +45,7 @@ module MOM_MEKE integer, parameter :: RV_IDX = 3 !< Index of surface relative vorticity in the feature array integer, parameter :: RD_DX_Z_IDX = 4 !< Index of the radius of deformation over the grid size in the feature array -integer, parameter :: EKE_PROG = 1 !< Use prognostic equation to calcualte EKE +integer, parameter :: EKE_PROG = 1 !< Use prognostic equation to calculate EKE integer, parameter :: EKE_FILE = 2 !< Read in EKE from a file integer, parameter :: EKE_DBCLIENT = 3 !< Infer EKE using a neural network @@ -141,7 +141,7 @@ module MOM_MEKE logical :: online_analysis !< If true, post the EKE used in MOM6 at every timestep character(len=5) :: model_key = 'mleke' !< Key where the ML-model is stored character(len=7) :: key_suffix !< Suffix appended to every key sent to Redis - real :: eke_max !< The maximum value of EKE considered physically reasonable + real :: eke_max !< The maximum value of EKE considered physically reasonable [L2 T-2 ~> m2 s-2] ! Clock ids integer :: id_client_init !< Clock id to time initialization of the client @@ -173,22 +173,22 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h type(vertvisc_type), intent(in) :: visc !< The vertical viscosity type. real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: hu !< Accumlated zonal mass flux [H L2 ~> m3 or kg]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: hv !< Accumlated meridional mass flux [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: hu !< Accumulated zonal mass flux [H L2 ~> m3 or kg]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: hv !< Accumulated meridional mass flux [H L2 ~> m3 or kg] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] type(thermo_var_ptrs), intent(in) :: tv !< Type containing thermodynamic variables type(time_type), intent(in) :: Time !< The time used for interpolating EKE ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & - data_eke, & ! EKE from file + data_eke, & ! EKE from file [L2 T-2 ~> m2 s-2] mass, & ! The total mass of the water column [R Z ~> kg m-2]. I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. depth_tot, & ! The depth of the water column [Z ~> m]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. - drag_rate_visc, & ! Near-bottom velocity contribution to bottom dratg [L T-1 ~> m s-1] + drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [L T-1 ~> m s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. @@ -196,7 +196,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h barotrFac2, & ! Ratio of EKE_barotropic / EKE [nondim] bottomFac2, & ! Ratio of EKE_bottom / EKE [nondim] tmp, & ! Temporary variable for computation of diagnostic velocities [L T-1 ~> m s-1] - equilibrium_value ! The equilbrium value of MEKE to be calculated at each + equilibrium_value ! The equilibrium value of MEKE to be calculated at each ! time step [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -225,7 +225,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). logical :: use_drag_rate ! Flag to indicate drag_rate is finite integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array + real(kind=real32), dimension(size(MEKE%MEKE),NUM_FEATURES) :: features_array ! The array of features + ! needed for the machine learning inference, with different + ! units for the various subarrays [various] 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 @@ -625,7 +627,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) + call time_interp_external(CS%id_eke, 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 @@ -755,7 +757,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. ! Local variables - real :: beta ! Combined topograpic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] + real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: bottomFac2, barotrFac2 ! Vertical structure factors [nondim] real :: LmixScale, LRhines, LEady ! Various mixing length scales [L ~> m] @@ -955,7 +957,7 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: LRhines, LEady ! Possible mixing length scales [L ~> m] - real :: beta ! Combined topograpic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] + real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: FatH ! Coriolis parameter at h points [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] @@ -1094,7 +1096,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields - type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control struct + type(MOM_restart_CS), intent(in) :: restart_CS !< MOM restart control structure logical, intent( out) :: meke_in_dynamics !< If true, MEKE is stepped forward in dynamics !! otherwise in tracer dynamics @@ -1230,7 +1232,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, case default call MOM_error(FATAL, "Invalid method selected for calculating EKE") end select - ! GMM, make sure all params used to calculated MEKE are within the above if + ! GMM, make sure all parameters used to calculated MEKE are within the above if call get_param(param_file, mdl, "MEKE_KHCOEFF", CS%MEKE_KhCoeff, & "A scaling factor in the expression for eddy diffusivity "//& @@ -1560,13 +1562,13 @@ subroutine ML_MEKE_init(diag, G, US, Time, param_file, dbcomms_CS, CS) CS%id_mke = register_diag_field('ocean_model', 'MEKE_MKE', diag%axesT1, Time, & 'Surface mean (resolved) kinetic energy used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) CS%id_slope_z= register_diag_field('ocean_model', 'MEKE_slope_z', diag%axesT1, Time, & - 'Vertically averaged isopyncal slope magnitude used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) + 'Vertically averaged isopyncal slope magnitude used in MEKE', 'nondim', conversion=US%Z_to_L) CS%id_slope_x= register_diag_field('ocean_model', 'MEKE_slope_x', diag%axesCui, Time, & - 'Isopycnal slope in the x-direction used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) + 'Isopycnal slope in the x-direction used in MEKE', 'nondim', conversion=US%Z_to_L) CS%id_slope_y= register_diag_field('ocean_model', 'MEKE_slope_y', diag%axesCvi, Time, & - 'Isopycnal slope in the y-direction used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) - CS%id_rv= register_diag_field('ocean_model', 'MEKE_RV', diag%axesT1, Time, & - 'Surface relative vorticity used in MEKE', 'm2 s-2', conversion=US%L_T_to_m_s**2) + 'Isopycnal slope in the y-direction used in MEKE', 'nondim', conversion=US%Z_to_L) + CS%id_rv = register_diag_field('ocean_model', 'MEKE_RV', diag%axesT1, Time, & + 'Surface relative vorticity used in MEKE', 's-1', conversion=US%s_to_T) end subroutine ML_MEKE_init @@ -1574,35 +1576,38 @@ end subroutine ML_MEKE_init subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, features_array) type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(MEKE_CS), intent(in) :: CS !< Control structure for MEKE - real, dimension(SZI_(G),SZJ_(G)), intent(in ) :: Rd_dx_h !< Rossby radius of deformation over - !! the grid length scale [nondim] - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(in ) :: Rd_dx_h !< Rossby radius of deformation over + !! the grid length scale [nondim] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] type(thermo_var_ptrs), intent(in) :: tv !< Type containing thermodynamic variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. + real, intent(in) :: dt !< Model(baroclinic) time-step [T ~> s]. real(kind=real32), dimension(SIZE(h),num_features), intent( out) :: features_array - !< The array of features needed for machine - !! learning inference - - real, dimension(SZI_(G),SZJ_(G)) :: mke - real, dimension(SZI_(G),SZJ_(G)) :: slope_z - real, dimension(SZIB_(G),SZJB_(G)) :: rv_z - real, dimension(SZIB_(G),SZJB_(G)) :: rv_z_t - real, dimension(SZI_(G),SZJ_(G)) :: rd_dx_z - - real, dimension(SZIB_(G),SZJ_(G), SZK_(G)) :: h_u ! Thickness at u point - real, dimension(SZI_(G),SZJB_(G), SZK_(G)) :: h_v ! Thickness at v point - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1) :: slope_x ! Isoneutral slope at U point - real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1) :: slope_y ! Isoneutral slope at V point - real, dimension(SZIB_(G),SZJ_(G)) :: slope_x_vert_avg ! Isoneutral slope at U point - real, dimension(SZI_(G),SZJB_(G)) :: slope_y_vert_avg ! Isoneutral slope at V point + !< The array of features needed for machine + !! learning inference, with different units + !! for the various subarrays [various] + + real, dimension(SZI_(G),SZJ_(G)) :: mke ! Surface kinetic energy per unit mass [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G)) :: slope_z ! Vertically averaged isoneutral slopes [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJB_(G)) :: rv_z ! Surface relative vorticity [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)) :: rv_z_t ! Surface relative vorticity interpolated to tracer points [T-1 ~> s-1] + + real, dimension(SZIB_(G),SZJ_(G), SZK_(G)) :: h_u ! Thickness at u point [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G), SZK_(G)) :: h_v ! Thickness at v point [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)+1) :: slope_x ! Isoneutral slope at U point [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)+1) :: slope_y ! Isoneutral slope at V point [Z L-1 ~> nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: slope_x_vert_avg ! Isoneutral slope at U point [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G)) :: slope_y_vert_avg ! Isoneutral slope at V point [Z L-1 ~> nondim] real, dimension(SZI_(G), SZJ_(G), SZK_(G)+1) :: e ! The interface heights relative to mean sea level [Z ~> m]. - real :: slope_t, u_t, v_t ! u and v interpolated to thickness point - real :: dvdx, dudy - real :: a_e, a_w, a_n, a_s, Idenom, sum_area + real :: slope_t ! Slope interpolated to thickness points [Z L-1 ~> nondim] + real :: u_t, v_t ! u and v interpolated to thickness points [L T-1 ~> m s-1] + real :: dvdx, dudy ! Components of relative vorticity [T-1 ~> s-1] + real :: a_e, a_w, a_n, a_s ! Fractional areas of neighboring cells for interpolating velocities [nondim] + real :: Idenom ! A normalizing factor in calculating weighted averages of areas [L-2 ~> m-2] + real :: sum_area ! A sum of adjacent cell areas [L2 ~> m2] integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -1735,11 +1740,12 @@ end subroutine predict_MEKE !> Compute average of interface quantities weighted by the thickness of the surrounding layers real function vertical_average_interface(h, w, h_min) - real, dimension(:), intent(in) :: h !< Layer Thicknesses - real, dimension(:), intent(in) :: w !< Quantity to average - real, intent(in) :: h_min !< The vanishingly small layer thickness + real, dimension(:), intent(in) :: h !< Layer Thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(in) :: w !< Quantity to average [arbitrary] + real, intent(in) :: h_min !< The vanishingly small layer thickness [H ~> m or kg m-2] - real :: htot, inv_htot + real :: htot ! Twice the sum of the layer thicknesses interpolated to interior interfaces [H ~> m or kg m-2] + real :: inv_htot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1] integer :: k, nk nk = size(h) @@ -1902,7 +1908,7 @@ end subroutine MEKE_end !! The local dissipation of \f$ E \f$ is parameterized through a linear !! damping, \f$\lambda\f$, and bottom drag, \f$ C_d | U_d | \gamma_b^2 \f$. !! The \f$ \gamma_b \f$ accounts for the weak projection of the column-mean -!! eddy velocty to the bottom. In other words, the bottom velocity is +!! eddy velocity to the bottom. In other words, the bottom velocity is !! estimated as \f$ \gamma_b U_e \f$. !! The bottom drag coefficient, \f$ C_d \f$ is the same as that used in the bottom !! friction in the mean model equations. From 454c5c61fa3696d1195a8f7c7a58446ee9658cf1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Jan 2023 08:53:07 -0500 Subject: [PATCH 201/629] Document units of 75 scattered variables Added or amended comments to document the units of 75 variables in 23 files in the src/core, src/initialization, src/ice_shelf and src/user directories that had been overlooked when the other variables in these files had their units documented. Only comments are changed, and all answers are bitwise identical. --- src/core/MOM_CoriolisAdv.F90 | 12 ++++----- src/core/MOM_checksum_packages.F90 | 6 ++--- src/core/MOM_density_integrals.F90 | 6 ++--- src/core/MOM_porous_barriers.F90 | 2 +- src/ice_shelf/MOM_marine_ice.F90 | 2 +- src/ice_shelf/user_shelf_init.F90 | 4 ++- src/initialization/MOM_grid_initialize.F90 | 16 +++++------ .../MOM_state_initialization.F90 | 6 ++--- src/user/MOM_controlled_forcing.F90 | 6 ++--- src/user/MOM_wave_interface.F90 | 15 ++++++----- src/user/Phillips_initialization.F90 | 27 +++++++++++-------- src/user/SCM_CVMix_tests.F90 | 4 +-- src/user/benchmark_initialization.F90 | 8 +++--- src/user/circle_obcs_initialization.F90 | 7 ++++- src/user/dense_water_initialization.F90 | 4 +-- src/user/dumbbell_surface_forcing.F90 | 2 +- src/user/dyed_channel_initialization.F90 | 4 +-- src/user/dyed_obcs_initialization.F90 | 2 +- src/user/external_gwave_initialization.F90 | 3 ++- src/user/lock_exchange_initialization.F90 | 4 +-- src/user/shelfwave_initialization.F90 | 2 +- src/user/user_change_diffusivity.F90 | 4 +-- src/user/user_revise_forcing.F90 | 2 +- 23 files changed, 82 insertions(+), 66 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 3ee203210c..056b171ba8 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -189,12 +189,12 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & PV, & ! A diagnostic array of the potential vorticities [H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]. RV ! A diagnostic array of the relative vorticities [T-1 ~> s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: CAuS ! - real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: CAvS ! - real :: fv1, fv2, fv3, fv4 ! (f+rv)*v [L T-2 ~> m s-2]. - real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u [L T-2 ~> m s-2]. - real :: max_fv, max_fu ! The maximum or minimum of the neighboring Coriolis - real :: min_fv, min_fu ! accelerations [L T-2 ~> m s-2], i.e. max(min)_fu(v)q. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)) :: CAuS ! Stokes contribution to CAu [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(G)) :: CAvS ! Stokes contribution to CAv [L T-2 ~> m s-2] + real :: fv1, fv2, fv3, fv4 ! (f+rv)*v at the 4 points surrounding a u points[L T-2 ~> m s-2] + real :: fu1, fu2, fu3, fu4 ! -(f+rv)*u at the 4 points surrounding a v point [L T-2 ~> m s-2] + real :: max_fv, max_fu ! The maximum of the neighboring Coriolis accelerations [L T-2 ~> m s-2] + real :: min_fv, min_fu ! The minimum of the neighboring Coriolis accelerations [L T-2 ~> m s-2] real, parameter :: C1_12 = 1.0 / 12.0 ! C1_12 = 1/12 [nondim] real, parameter :: C1_24 = 1.0 / 24.0 ! C1_24 = 1/24 [nondim] diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 871de51632..80630084b9 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -29,9 +29,9 @@ module MOM_checksum_packages !> A type for storing statistica about a variable type :: stats ; private - real :: minimum = 1.E34 !< The minimum value - real :: maximum = -1.E34 !< The maximum value - real :: average = 0. !< The average value + real :: minimum = 1.E34 !< The minimum value [degC] or [ppt] or other units + real :: maximum = -1.E34 !< The maximum value [degC] or [ppt] or other units + real :: average = 0. !< The average value [degC] or [ppt] or other units end type stats contains diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 6cffea5c75..e1fb3d3278 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -143,7 +143,7 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] - real, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] real :: dz ! The layer thickness [Z ~> m] @@ -784,7 +784,7 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: w_left, w_right ! Left and right weights [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, parameter :: C1_90 = 1.0/90.0 ! Rational constants. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] real :: dz ! Layer thicknesses at tracer points [Z ~> m] @@ -1175,7 +1175,7 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_90 = 1.0/90.0 ! A rational constant. + real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index c1eb749467..4e812b65d7 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -29,7 +29,7 @@ module MOM_porous_barriers type(diag_ctrl), pointer :: & diag => Null() !< A structure to regulate diagnostic output timing logical :: debug !< If true, write verbose checksums for debugging purposes. - real :: mask_depth !< The depth shallower than which porous barrier is not applied. + real :: mask_depth !< The depth shallower than which porous barrier is not applied [Z ~> m] integer :: eta_interp !< An integer indicating how the interface heights at the velocity !! points are calculated. Valid values are given by the parameters !! defined below: MAX, MIN, ARITHMETIC and HARMONIC. diff --git a/src/ice_shelf/MOM_marine_ice.F90 b/src/ice_shelf/MOM_marine_ice.F90 index 2a1b6d799b..8635eb71b5 100644 --- a/src/ice_shelf/MOM_marine_ice.F90 +++ b/src/ice_shelf/MOM_marine_ice.F90 @@ -28,7 +28,7 @@ module MOM_marine_ice type, public :: marine_ice_CS ; private real :: kv_iceberg !< The viscosity of the icebergs [L4 Z-2 T-1 ~> m2 s-1] (for ice rigidity) real :: berg_area_threshold !< Fraction of grid cell which iceberg must occupy - !! so that fluxes below are set to zero. (0.5 is a + !! so that fluxes below are set to zero [nondim]. (0.5 is a !! good value to use.) Not applied for negative values. real :: latent_heat_fusion !< Latent heat of fusion [Q ~> J kg-1] real :: density_iceberg !< A typical density of icebergs [R ~> kg m-3] (for ice rigidity) diff --git a/src/ice_shelf/user_shelf_init.F90 b/src/ice_shelf/user_shelf_init.F90 index c384ef7cee..4d1f263ca8 100644 --- a/src/ice_shelf/user_shelf_init.F90 +++ b/src/ice_shelf/user_shelf_init.F90 @@ -131,7 +131,9 @@ subroutine USER_update_shelf_mass(mass_shelf, area_shelf_h, h_shelf, hmask, G, C logical, intent(in) :: new_sim !< If true, this the start of a new run. - real :: c1, edge_pos, slope_pos + real :: c1 ! The inverse of the range over which the shelf slopes [km-1] + real :: edge_pos ! The time-evolving position the ice shelf edge [km] + real :: slope_pos ! The time-evolving position of the start of the ice shelf slope [km] integer :: i, j edge_pos = CS%pos_shelf_edge_0 + CS%shelf_speed*(time_type_to_real(Time) / 86400.0) diff --git a/src/initialization/MOM_grid_initialize.F90 b/src/initialization/MOM_grid_initialize.F90 index e622b11805..8bea8fe6e9 100644 --- a/src/initialization/MOM_grid_initialize.F90 +++ b/src/initialization/MOM_grid_initialize.F90 @@ -365,7 +365,7 @@ subroutine set_grid_metrics_cartesian(G, param_file, US) real :: grid_lonT(G%isd:G%ied), grid_lonB(G%IsdB:G%IedB) ! Axis labels [degrees_E] or [km] or [m] real :: dx_everywhere, dy_everywhere ! Grid spacings [L ~> m]. real :: I_dx, I_dy ! Inverse grid spacings [L-1 ~> m-1]. - real :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] character(len=80) :: units_temp character(len=48) :: mdl = "MOM_grid_init set_grid_metrics_cartesian" @@ -922,7 +922,7 @@ end function dL !! function fn takes the value fnval, also returning in ittmax the number of iterations of !! Newton's method that were used to polish the root. function find_root( fn, dy_df, GP, fnval, y1, ymin, ymax, ittmax) - real :: find_root !< The value of y where fn(y) = fnval that will be returned + real :: find_root !< The value of y where fn(y) = fnval that will be returned [radians] real, external :: fn !< The external function whose root is being sought [gridpoints] real, external :: dy_df !< The inverse of the derivative of that function [radian gridpoint-1] type(GPS), intent(in) :: GP !< A structure of grid parameters @@ -1128,12 +1128,12 @@ end function Int_dj_dy !> Extrapolates missing metric data into all the halo regions. subroutine extrapolate_metric(var, jh, missing) - real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos [A] + real, dimension(:,:), intent(inout) :: var !< The array in which to fill in halos [abitrary] integer, intent(in) :: jh !< The size of the halos to be filled - real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [A] + real, optional, intent(in) :: missing !< The missing data fill value, 0 by default [abitrary] ! Local variables - real :: badval - integer :: i,j + real :: badval ! A bad data value [abitrary] + integer :: i, j badval = 0.0 ; if (present(missing)) badval = missing @@ -1162,8 +1162,8 @@ end subroutine extrapolate_metric !> This function implements Adcroft's rule for reciprocals, namely that !! Adcroft_Inv(x) = 1/x for |x|>0 or 0 for x=0. function Adcroft_reciprocal(val) result(I_val) - real, intent(in) :: val !< The value being inverted. - real :: I_val !< The Adcroft reciprocal of val. + real, intent(in) :: val !< The value being inverted [abitrary] + real :: I_val !< The Adcroft reciprocal of val [abitrary-1] I_val = 0.0 if (val /= 0.0) I_val = 1.0/val diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 1eec90f568..0e50ebb67f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -885,10 +885,10 @@ subroutine initialize_thickness_uniform(h, depth_tot, G, GV, param_file, just_re !! parameters without changing h. ! Local variables character(len=40) :: mdl = "initialize_thickness_uniform" ! This subroutine's name. - real :: e0(SZK_(GV)+1) ! The resting interface heights, in depth units, usually + real :: e0(SZK_(GV)+1) ! The resting interface heights [Z ~> m], usually ! negative because it is positive upward. - real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface - ! positive upward, in depth units. + real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface, + ! positive upward [Z ~> m]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index 24d370e920..5be01bece4 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -397,7 +397,7 @@ end subroutine apply_ctrl_forcing !> This function maps rval into an integer in the range from 1 to num_period. function periodic_int(rval, num_period) result (m) - real, intent(in) :: rval !< Input for mapping. + real, intent(in) :: rval !< Input for mapping [nondim] integer, intent(in) :: num_period !< Maximum output. integer :: m !< Return value. @@ -412,9 +412,9 @@ function periodic_int(rval, num_period) result (m) !> This function shifts rval by an integer multiple of num_period so that !! 0 <= val_out < num_period. function periodic_real(rval, num_period) result(val_out) - real, intent(in) :: rval !< Input to be shifted into valid range. + real, intent(in) :: rval !< Input to be shifted into valid range [nondim] integer, intent(in) :: num_period !< Maximum valid value. - real :: val_out !< Return value. + real :: val_out !< Return value [nondim] integer :: nshft if (rval < 0) then ; nshft = floor(abs(rval) / num_period) + 1 diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index f99ca27994..723c8a0595 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -1676,8 +1676,10 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) pointer :: CS !< Surface wave related control structure. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: P_deltaStokes_L ! The stokes induced Pressure anomaly, layer averaged - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: P_deltaStokes_i ! The stokes induced Pressure anomaly at interfaces + real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: P_deltaStokes_L ! The Stokes induced pressure anomaly, + ! layer averaged [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: P_deltaStokes_i ! The Stokes induced pressure anomaly + ! at interfaces [L2 T-2 ~> m2 s-2] real :: P_Stokes_l, P_Stokes_r ! Stokes-induced pressure anomaly over layer (left/right of point) [L2 T-2 ~> m2 s-2] real :: P_Stokes_l0, P_Stokes_r0 ! Stokes-induced pressure anomaly at interface ! (left/right of point) [L2 T-2 ~> m2 s-2] @@ -1690,11 +1692,12 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) real :: zi_l(SZK_(G)+1), zi_r(SZK_(G)+1) ! The height of the edges of the cells (left/right of point) [Z ~> m]. real :: idz_l(SZK_(G)), idz_r(SZK_(G)) ! The inverse thickness of the cells (left/right of point) [Z-1 ~> m-1] real :: h_l, h_r ! The thickness of the cell (left/right of point) [Z ~> m]. - real :: dexp2kzL,dexp4kzL,dexp2kzR,dexp4kzR ! Analytical evaluation of multi-exponential decay contribution - ! to Stokes pressure anomalies. - real :: TwoK, FourK, iTwoK, iFourK ! Wavenumber multipliers/inverses + real :: dexp2kzL, dexp4kzL, dexp2kzR, dexp4kzR ! Analytical evaluation of multi-exponential decay + ! contribution to Stokes pressure anomalies [nondim]. + real :: TwoK, FourK ! Wavenumbers multiplied by a factor [Z-1 ~> m-1] + real :: iTwoK, iFourK ! Inverses of wavenumbers [Z ~> m] - integer :: i,j,k,l + integer :: i, j, k, l !--------------------------------------------------------------- ! Compute the Stokes contribution to the pressure gradient force diff --git a/src/user/Phillips_initialization.F90 b/src/user/Phillips_initialization.F90 index 06b3ed43d6..62b55bb0a1 100644 --- a/src/user/Phillips_initialization.F90 +++ b/src/user/Phillips_initialization.F90 @@ -233,16 +233,16 @@ subroutine Phillips_initialize_sponges(G, GV, US, tv, param_file, CSp, h) real, intent(in), dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h !< Thickness field [H ~> m or kg m-2]. ! Local variables - real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces. + real :: eta0(SZK_(GV)+1) ! The 1-d nominal positions of the interfaces [Z ~> m] real :: eta(SZI_(G),SZJ_(G),SZK_(GV)+1) ! A temporary array for interface heights [Z ~> m]. - real :: temp(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for other variables. + real :: temp(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for other variables [various] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate [T-1 ~> s-1] real :: eta_im(SZJ_(G),SZK_(GV)+1) ! A temporary array for zonal-mean eta [Z ~> m]. real :: Idamp_im(SZJ_(G)) ! The inverse zonal-mean damping rate [T-1 ~> s-1]. real :: damp_rate ! The inverse zonal-mean damping rate [T-1 ~> s-1]. - real :: jet_width ! The width of the zonal mean jet, in km. + real :: jet_width ! The width of the zonal mean jet [km]. real :: jet_height ! The interface height scale associated with the zonal-mean jet [Z ~> m]. - real :: y_2 ! The y-position relative to the channel center, in km. + real :: y_2 ! The y-position relative to the channel center [km]. real :: half_strat ! The fractional depth where the straficiation is centered [nondim]. real :: half_depth ! The depth where the stratification is centered [Z ~> m]. real :: pi ! The ratio of the circumference of a circle to its diameter [nondim] @@ -309,8 +309,8 @@ end subroutine Phillips_initialize_sponges !> sech calculates the hyperbolic secant. function sech(x) - real, intent(in) :: x !< Input value. - real :: sech !< Result. + real, intent(in) :: x !< Input value [nondim]. + real :: sech !< Result [nondim]. ! This is here to prevent overflows or underflows. if (abs(x) > 228.) then @@ -330,9 +330,14 @@ subroutine Phillips_initialize_topography(D, G, param_file, max_depth, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - real :: PI, Htop, Wtop, Ltop, offset, dist - real :: x1, x2, x3, x4, y1, y2 - integer :: i,j,is,ie,js,je + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: Htop ! The maximum height of the topography above max_depth [Z ~> m] + real :: Wtop ! meridional width of topographic features [km] + real :: Ltop ! zonal width of topographic features [km] + real :: offset ! meridional offset from the center of topographic features [km] + real :: dist ! zonal width of topographic features [km] + real :: x1, x2, x3, x4, y1, y2 ! Various positions in the domain [km] + integer :: i, j, is, ie, js, je character(len=40) :: mdl = "Phillips_initialize_topography" ! This subroutine's name. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -349,8 +354,8 @@ subroutine Phillips_initialize_topography(D, G, param_file, max_depth, US) dist = 0.333*G%len_lon ! distance between drake and mount ! should be longer than Ltop/2 - y1=G%south_lat+0.5*G%len_lat+offset-0.5*Wtop; y2=y1+Wtop - x1=G%west_lon+0.1*G%len_lon; x2=x1+Ltop; x3=x1+dist; x4=x3+3.0/2.0*Ltop + y1 = G%south_lat+0.5*G%len_lat+offset-0.5*Wtop ; y2 = y1+Wtop + x1 = G%west_lon+0.1*G%len_lon ; x2 = x1+Ltop ; x3 = x1+dist ; x4 = x3+3.0/2.0*Ltop do j=js,je ; do i=is,ie D(i,j)=0.0 diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index f681231694..8df8f90e3d 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -197,7 +197,7 @@ subroutine SCM_CVMix_tests_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 :: mag_tau + real :: mag_tau ! The magnitude of the wind stress [R L Z T-2 ~> Pa] ! Bounds for loops and memory allocation is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -231,7 +231,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, 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 :: PI + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] PI = 4.0*atan(1.0) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index a9344a6a30..3920b52729 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -41,7 +41,7 @@ subroutine benchmark_initialize_topography(D, G, param_file, max_depth, US) ! Local variables real :: min_depth ! The minimum basin depth [Z ~> m] - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: D0 ! A constant to make the maximum basin depth MAXIMUM_DEPTH [Z ~> m] real :: x ! Longitude relative to the domain edge, normalized by its extent [nondim] real :: y ! Latitude relative to the domain edge, normalized by its extent [nondim] @@ -113,7 +113,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e drho_dT, & ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1]. drho_dS ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. real :: pres(SZK_(GV)) ! Reference pressure [R L2 T-2 ~> Pa]. - real :: a_exp ! The fraction of the overall stratification that is exponential. + real :: a_exp ! The fraction of the overall stratification that is exponential [nondim] real :: I_ts, I_md ! Inverse lengthscales [Z-1 ~> m-1]. real :: T_frac ! A ratio of the interface temperature to the range ! between SST and the bottom temperature [nondim]. @@ -121,7 +121,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e ! interface temperature for a given z [nondim] real :: derr_dz ! The derivative of the normalized error between the profile's ! temperature and the interface temperature with z [Z-1 ~> m-1] - real :: pi ! 3.1415926... calculated as 4*atan(1) + real :: pi ! 3.1415926... calculated as 4*atan(1) [nondim] real :: z ! A work variable for the interface position [Z ~> m] ! This include declares and sets the variable "version". # include "version_variable.h" @@ -246,7 +246,7 @@ subroutine benchmark_init_temperature_salinity(T, S, G, GV, US, param_file, & real :: drho_dT(SZK_(GV)) ! Derivative of density with temperature [R C-1 ~> kg m-3 degC-1] real :: drho_dS(SZK_(GV)) ! Derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real :: rho_guess(SZK_(GV)) ! Potential density at T0 & S0 [R ~> kg m-3] - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: SST ! The initial sea surface temperature [C ~> degC] character(len=40) :: mdl = "benchmark_init_temperature_salinity" ! This subroutine's name. integer :: i, j, k, k1, is, ie, js, je, nz, itt diff --git a/src/user/circle_obcs_initialization.F90 b/src/user/circle_obcs_initialization.F90 index 07fc539979..63c5c8a0d4 100644 --- a/src/user/circle_obcs_initialization.F90 +++ b/src/user/circle_obcs_initialization.F90 @@ -44,7 +44,12 @@ subroutine circle_obcs_initialize_thickness(h, depth_tot, G, GV, param_file, jus 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 :: diskrad, rad, lonC, latC, xOffset + 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] + real :: latC ! The y-position of a point [km] or [degrees] or [m] + real :: xOffset ! The x-offset of the elevated disc center relative to the domain + ! center [km] or [degrees] or [m] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "circle_obcs_initialization" ! This module's name. diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 5e0cb65007..81aa4c2b3b 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -35,9 +35,9 @@ module dense_water_initialization subroutine dense_water_initialize_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth [Z ~> m] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth [Z ~> m] ! Local variables real, dimension(5) :: domain_params ! nondimensional widths of all domain sections [nondim] diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 0b8f59a6e8..4ac5ab3bf9 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -34,7 +34,7 @@ module dumbbell_surface_forcing !! to the reservoirs real :: slp_period !< Period of sinusoidal pressure wave [days] real, dimension(:,:), allocatable :: & - forcing_mask !< A mask regulating where forcing occurs + forcing_mask !< A mask regulating where forcing occurs [nondim] real, dimension(:,:), allocatable :: & S_restore !< The surface salinity field toward which to restore [S ~> ppt]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index 411ab6ef98..aed7142fad 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -94,7 +94,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname integer :: m, n - real :: dye + real :: dye ! Inflow dye concentrations [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() if (.not.associated(OBC)) call MOM_error(FATAL, 'dyed_channel_initialization.F90: '// & @@ -142,7 +142,7 @@ subroutine dyed_channel_update_flow(OBC, CS, G, GV, US, Time) type(time_type), intent(in) :: Time !< model time. ! Local variables real :: flow ! The OBC velocity [L T-1 ~> m s-1] - real :: PI ! 3.1415926535... + real :: PI ! 3.1415926535... [nondim] real :: time_sec ! The elapsed time since the start of the calendar [T ~> s] integer :: i, j, k, l, isd, ied, jsd, jed integer :: IsdB, IedB, JsdB, JedB diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index c5efef4905..6248efab2f 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -41,7 +41,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) character(len=80) :: name, longname integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz integer :: IsdB, IedB, JsdB, JedB - real :: dye + real :: dye ! Inflow dye concentration [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/external_gwave_initialization.F90 b/src/user/external_gwave_initialization.F90 index 554440dbcb..63cc89342a 100644 --- a/src/user/external_gwave_initialization.F90 +++ b/src/user/external_gwave_initialization.F90 @@ -44,7 +44,8 @@ subroutine external_gwave_initialize_thickness(h, G, GV, US, param_file, just_re ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j, k, is, ie, js, je, nz - real :: PI, Xnondim + real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] + real :: Xnondim ! A normalized x position [nondim] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/user/lock_exchange_initialization.F90 b/src/user/lock_exchange_initialization.F90 index a3418e6482..3b41237c36 100644 --- a/src/user/lock_exchange_initialization.F90 +++ b/src/user/lock_exchange_initialization.F90 @@ -36,8 +36,8 @@ subroutine lock_exchange_initialize_thickness(h, G, GV, US, param_file, just_rea real :: eta1D(SZK_(GV)+1)! Interface height relative to the sea surface ! positive upward [Z ~> m]. - real :: front_displacement ! Vertical displacement acrodd front - real :: thermocline_thickness ! Thickness of stratified region + real :: front_displacement ! Vertical displacement across front [Z ~> m] + real :: thermocline_thickness ! Thickness of stratified region [Z ~> m] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "lock_exchange_initialize_thickness" ! This subroutine's name. diff --git a/src/user/shelfwave_initialization.F90 b/src/user/shelfwave_initialization.F90 index 5d7f1b7e97..df46a142f1 100644 --- a/src/user/shelfwave_initialization.F90 +++ b/src/user/shelfwave_initialization.F90 @@ -138,7 +138,7 @@ subroutine shelfwave_set_OBC_data(OBC, CS, G, GV, US, h, Time) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< layer thickness [H ~> m or kg m-2] type(time_type), intent(in) :: Time !< model time. ! The following variables are used to set up the transport in the shelfwave example. diff --git a/src/user/user_change_diffusivity.F90 b/src/user/user_change_diffusivity.F90 index f125da0a25..c12d34a721 100644 --- a/src/user/user_change_diffusivity.F90 +++ b/src/user/user_change_diffusivity.F90 @@ -151,7 +151,7 @@ end subroutine user_change_diff !> This subroutine checks whether the 4 values of range are in ascending order. function range_OK(range) result(OK) - real, dimension(4), intent(in) :: range !< Four values to check. + real, dimension(4), intent(in) :: range !< Four values to check [arbitrary] logical :: OK !< Return value. OK = ((range(1) <= range(2)) .and. (range(2) <= range(3)) .and. & @@ -169,7 +169,7 @@ function val_weights(val, range) result(ans) real, dimension(4), intent(in) :: range !< Range over which the answer is non-zero [arbitrary units]. real :: ans !< Return value [nondim]. ! Local variables - real :: x ! A nondimensional number between 0 and 1. + real :: x ! A nondimensional number between 0 and 1 [nondim]. ans = 0.0 if ((val > range(1)) .and. (val < range(4))) then diff --git a/src/user/user_revise_forcing.F90 b/src/user/user_revise_forcing.F90 index eb9694a091..ce767d7479 100644 --- a/src/user/user_revise_forcing.F90 +++ b/src/user/user_revise_forcing.F90 @@ -21,7 +21,7 @@ module user_revise_forcing !> Control structure for user_revise_forcing type, public :: user_revise_forcing_CS ; private - real :: cdrag !< The quadratic bottom drag coefficient. + real :: cdrag !< The quadratic bottom drag coefficient [nondim] end type user_revise_forcing_CS contains From cab1e848a99289cbd5e860c5d6406f3442a2b38b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 29 Jan 2023 13:42:50 -0500 Subject: [PATCH 202/629] Document units of about 250 EOS variables Added or amended comments to document the units of about 250 variables in 6 files in the src/equation_of_state directories. Also revised comments to make it clear that the MOM6 code for the UNESCO equation of state is based on the Jackett and MacDougall (1995) refit to the UNESCO equation of state (which uses potential temperature as a state variable) as opposed to the original UNESCO equation of state, as documented in an appendix to Gill (1982) (which uses in-situ temperature as a state variable). Also corrected a handful of spelling errors in comments. Only comments are changed, and all answers are bitwise identical. --- src/equation_of_state/MOM_EOS.F90 | 8 +- src/equation_of_state/MOM_EOS_NEMO.F90 | 29 ++-- src/equation_of_state/MOM_EOS_TEOS10.F90 | 118 +++++++++------ src/equation_of_state/MOM_EOS_UNESCO.F90 | 184 +++++++++++++++-------- src/equation_of_state/MOM_EOS_Wright.F90 | 173 ++++++++++++++------- src/equation_of_state/MOM_EOS_linear.F90 | 22 +-- src/equation_of_state/MOM_TFreeze.F90 | 44 +++--- 7 files changed, 370 insertions(+), 208 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 27484aa536..12b87ebc64 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -428,7 +428,7 @@ subroutine calculate_stanley_density_1d(T, S, pressure, Tvar, TScov, Svar, rho, 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 temperture-salinity covariance to units of + 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] @@ -1023,7 +1023,7 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d end subroutine calculate_density_second_derivs_1d -!> Calls the appropriate subroutine to calculate density second derivatives for scalar nputs. +!> Calls the appropriate subroutine to calculate density second derivatives for scalar inputs. subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT, & drho_dS_dP, drho_dT_dP, EOS, scale) real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] @@ -1266,7 +1266,7 @@ subroutine calculate_compress_scalar(T, S, pressure, rho, drho_dp, EOS) type(EOS_type), intent(in) :: EOS !< Equation of state structure ! Local variables - ! These arrays use the same units as their counterparts in calcluate_compress_1d. + ! These arrays use the same units as their counterparts in calculate_compress_1d. real, dimension(1) :: pa ! Pressure in a size-1 1d array [R L2 T-2 ~> Pa] real, dimension(1) :: Ta ! Temperature in a size-1 1d array [C ~> degC] real, dimension(1) :: Sa ! Salinity in a size-1 1d array [S ~> ppt] @@ -1734,7 +1734,7 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) ! Local variables real, dimension(size(S)) :: Sa ! Salinity converted to [ppt] - real :: S_scale ! A factor to convert practical salnity from ppt to the desired units [S ppt-1 ~> 1] + real :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S ppt-1 ~> 1] integer :: i, is, ie if (present(dom)) then diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index 476fda6b70..de4a715489 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -35,7 +35,7 @@ module MOM_EOS_NEMO module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo end interface calculate_density_derivs_nemo -real, parameter :: Pa2db = 1.e-4 !< Conversion factor between Pa and dbar +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. real, parameter :: r1_S0 = 0.875/35.16504 @@ -184,8 +184,10 @@ subroutine calculate_density_scalar_nemo(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]. - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 + 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) :: rho0 ! A 1-d array with a copy of the density [kg m-3] T0(1) = T S0(1) = S @@ -345,8 +347,13 @@ subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds real, intent(out) :: drho_dS !< The partial derivative of density with salinity, !! in [kg m-3 ppt-1]. ! Local variables - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: drdt0, drds0 + 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] + real, dimension(1) :: drds0 ! A 1-d array with a copy of the derivative of density + ! with salinity [kg m-3 ppt-1] T0(1) = T S0(1) = S @@ -358,12 +365,12 @@ subroutine calculate_density_derivs_scalar_nemo(T, S, pressure, drho_dt, drho_ds 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 in g/kg), conservative temperature (T [degC]), and pressure [Pa], using the expressions +!! (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. 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]. + 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 @@ -373,7 +380,9 @@ 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,zt,zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j call calculate_density_array_nemo(T, S, pressure, rho, start, npts) @@ -384,7 +393,7 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) enddo diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index bbe9982b6f..4c7483c068 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -48,14 +48,13 @@ module MOM_EOS_TEOS10 module procedure calculate_density_second_derivs_scalar_teos10, calculate_density_second_derivs_array_teos10 end interface calculate_density_second_derivs_teos10 -real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar. +real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar [dbar Pa-1] 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 expression from the -!! TEOS10 website. +!> 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 expression from the TEOS10 website. subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) real, intent(in) :: T !< Conservative temperature [degC]. real, intent(in) :: S !< Absolute salinity [g kg-1]. @@ -64,8 +63,10 @@ subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 + 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) :: rho0 ! A 1-d array with a copy of the density [kg m-3] T0(1) = T S0(1) = S @@ -76,9 +77,9 @@ subroutine calculate_density_scalar_teos10(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_teos10 -!> 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 expression from the +!> 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 expression from the !! TEOS10 website. subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts, rho_ref) real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. @@ -90,13 +91,15 @@ subroutine calculate_density_array_teos10(T, S, pressure, rho, start, npts, rho_ real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? @@ -120,7 +123,10 @@ subroutine calculate_spec_vol_scalar_teos10(T, S, pressure, specvol, spv_ref) real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! Local variables - real, dimension(1) :: T0, S0, pressure0, spv0 + 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) :: spv0 ! A 1-d array with a copy of the specific volume [m3 kg-1] T0(1) = T ; S0(1) = S ; pressure0(1) = pressure @@ -134,8 +140,7 @@ end subroutine calculate_spec_vol_scalar_teos10 !! and pressure [Pa], using the TEOS10 equation of state. !! If spv_ref is present, specvol is an anomaly from spv_ref. subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature relative to the surface - !! [degC]. + real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. real, dimension(:), intent(in) :: S !< salinity [g kg-1]. real, dimension(:), intent(in) :: pressure !< pressure [Pa]. real, dimension(:), intent(out) :: specvol !< in situ specific volume [m3 kg-1]. @@ -144,13 +149,15 @@ subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar if (S(j) < -1.0e-10) then @@ -177,15 +184,17 @@ subroutine calculate_density_derivs_array_teos10(T, S, pressure, drho_dT, drho_d integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + 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 else call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS(j), drho_dct=drho_dT(j)) @@ -206,10 +215,13 @@ subroutine calculate_density_derivs_scalar_teos10(T, S, pressure, drho_dT, drho_ !! [kg m-3 (g/kg)-1]. ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] + !Conversions zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) @@ -229,15 +241,17 @@ subroutine calculate_specvol_derivs_teos10(T, S, pressure, dSV_dT, dSV_dS, start integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? dSV_dT(j) = 0.0 ; dSV_dS(j) = 0.0 else call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS(j), v_ct=dSV_dT(j)) @@ -252,18 +266,25 @@ subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, 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_dS_dS !< Partial derivative of beta with respect to S - real, intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T - real, intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - real, intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - real, intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect + !! to S [kg m-3 (g/kg)-2] + real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect + !! to T [kg m-3 (g/kg)-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 (g/kg)-1 Pa-1] = [s2 m-2 (g/kg)-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 :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] !Conversions zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar if (S < -1.0e-10) return !Can we assume safely that this is a missing value? call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & @@ -277,24 +298,31 @@ subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, drho_dS_ 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) :: drho_dS_dS !< Partial derivative of beta with respect to S - real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with resepct to T - real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect to T - real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect to pressure - real, dimension(:), intent(out) :: drho_dT_dP !< Partial derivative of alpha with respect to pressure + real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect + !! to S [kg m-3 (g/kg)-2] + real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with respect + !! to T [kg m-3 (g/kg)-1 degC-1] + real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect + !! to pressure [kg m-3 (g/kg)-1 Pa-1] = [s2 m-2 (g/kg)-1] + real, dimension(:), 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] integer, intent(in) :: start !< The starting point in the arrays. integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zs, zt, zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S,T) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? drho_dS_dS(j) = 0.0 ; drho_dS_dT(j) = 0.0 ; drho_dT_dT(j) = 0.0 drho_dS_dP(j) = 0.0 ; drho_dT_dP(j) = 0.0 else @@ -307,7 +335,7 @@ end subroutine calculate_density_second_derivs_array_teos10 !> 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 absolute salinity (sal in g/kg), +!! (drho_dp [s2 m-2]) from absolute salinity (sal [g kg-1]), !! conservative temperature (T [degC]), and pressure [Pa]. It uses the !! subroutines from TEOS10 website subroutine calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) @@ -322,15 +350,17 @@ subroutine calculate_compress_teos10(T, S, pressure, rho, drho_dp, start, npts) integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zs,zt,zp + real :: zs ! Absolute salinity [g kg-1] + real :: zt ! Conservative temperature [degC] + real :: zp ! Pressure converted to decibars [dbar] integer :: j do j=start,start+npts-1 !Conversions zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp + zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then ; !Can we assume safely that this is a missing value? + 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 else rho(j) = gsw_rho(zs,zt,zp) diff --git a/src/equation_of_state/MOM_EOS_UNESCO.F90 b/src/equation_of_state/MOM_EOS_UNESCO.F90 index a296cfc382..59ebb92c7a 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -17,45 +17,80 @@ module MOM_EOS_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_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], -!! using the UNESCO (1981) equation of state. +!! a reference density, from salinity [PSU], potential temperature [degC] and pressure [Pa], +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). interface calculate_density_UNESCO module procedure calculate_density_scalar_UNESCO, calculate_density_array_UNESCO end interface calculate_density_UNESCO !> 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 [PSU], potential temperature [degC], and -!! pressure [Pa], using the UNESCO (1981) equation of state. +!! pressure [Pa], using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). interface calculate_spec_vol_UNESCO module procedure calculate_spec_vol_scalar_UNESCO, calculate_spec_vol_array_UNESCO end interface calculate_spec_vol_UNESCO -!>@{ Parameters in the UNESCO equation of state -! The following constants are used to calculate rho0. The notation -! is Rab for the contribution to rho0 from T^aS^b. -real, parameter :: R00 = 999.842594, R10 = 6.793952e-2, R20 = -9.095290e-3, & - R30 = 1.001685e-4, R40 = -1.120083e-6, R50 = 6.536332e-9, R01 = 0.824493, & - R11 = -4.0899e-3, R21 = 7.6438e-5, R31 = -8.2467e-7, R41 = 5.3875e-9, & - R032 = -5.72466e-3, R132 = 1.0227e-4, R232 = -1.6546e-6, R02 = 4.8314e-4 - -! The following constants are used to calculate the secant bulk mod- -! ulus. The notation here is Sab for terms proportional to T^a*S^b, -! Spab for terms proportional to p*T^a*S^b, and SPab for terms +!>@{ 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. +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 :: 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 PSU-3/2] +real, parameter :: R232 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 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. -real, parameter :: S00 = 1.965933e4, S10 = 1.444304e2, S20 = -1.706103, & - S30 = 9.648704e-3, S40 = -4.190253e-5, S01 = 52.84855, S11 = -3.101089e-1, & - S21 = 6.283263e-3, S31 = -5.084188e-5, S032 = 3.886640e-1, S132 = 9.085835e-3, & - S232 = -4.619924e-4, Sp00 = 3.186519, Sp10 = 2.212276e-2, Sp20 = -2.984642e-4, & - Sp30 = 1.956415e-6, Sp01 = 6.704388e-3, Sp11 = -1.847318e-4, Sp21 = 2.059331e-7, & - Sp032 = 1.480266e-4, SP000 = 2.102898e-4, SP010 = -1.202016e-5, SP020 = 1.394680e-7, & - SP001 = -2.040237e-6, SP011 = 6.128773e-8, SP021 = 6.207323e-10 +! Note that these values differ from those in Appendix A 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 :: 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] !>@} 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], using the UNESCO (1981) equation of state. +!> 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], +!! 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]. @@ -64,8 +99,10 @@ subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real, dimension(1) :: T0, S0, pressure0 - real, dimension(1) :: rho0 + 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 in situ density [kg m-3] T0(1) = T S0(1) = S @@ -76,9 +113,10 @@ subroutine calculate_density_scalar_UNESCO(T, S, pressure, rho, rho_ref) end subroutine calculate_density_scalar_UNESCO -!> 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], using the UNESCO (1981) equation of state. +!> 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], +!! 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]. @@ -89,8 +127,12 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. + 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]. @@ -103,9 +145,9 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ 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 ; 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) - (same as rho(s,t_insitu,p=0) ). @@ -130,9 +172,9 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ enddo end subroutine calculate_density_array_UNESCO -!> 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], using the UNESCO (1981) equation of state. +!> 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], +!! 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 @@ -143,7 +185,10 @@ subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! Local variables - real, dimension(1) :: T0, S0, pressure0, spv0 + 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 @@ -151,9 +196,9 @@ subroutine calculate_spec_vol_scalar_UNESCO(T, S, pressure, specvol, spv_ref) specvol = spv0(1) end subroutine calculate_spec_vol_scalar_UNESCO -!> 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], using the UNESCO (1981) equation of state. +!> 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], +!! 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 @@ -166,8 +211,12 @@ subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. + 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]. @@ -180,9 +229,9 @@ subroutine calculate_spec_vol_array_UNESCO(T, S, pressure, specvol, start, npts, 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 ; 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) - (same as rho(s,t_insitu,p=0) ). @@ -222,8 +271,13 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s12, s_local, s32, s2 ! Salinity to the 1/2 - 2nd powers [PSU^n]. + 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]. @@ -240,9 +294,9 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta 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 + 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) ) @@ -293,14 +347,20 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: t_local, t2, t3, t4, t5 ! Temperature to the 1st - 5th power [degC^n]. - real :: s_local, s32, s2 ! Salinity to the 1st, 3/2, & 2nd power [PSU^n]. - 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, ks_1, ks_2 - real :: dks_dp ! The derivative of the secant bulk modulus - ! with pressure, nondimensional. + 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 :: 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] integer :: j do j=start,start+npts-1 @@ -309,9 +369,9 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) 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 ; 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) - (same as rho(s,t_insitu,p=0) ). diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index c2e50287b2..77e0d17ff3 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -27,15 +27,17 @@ module MOM_EOS_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 psu), potential temperature (in deg C), and pressure [Pa], -!! using the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! 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 module procedure calculate_density_scalar_wright, calculate_density_array_wright end interface calculate_density_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 psu), potential temperature (in deg C), and -!! pressure [Pa], using the expressions from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!! 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 module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright end interface calculate_spec_vol_wright @@ -64,11 +66,25 @@ module MOM_EOS_Wright ! Following are the values for the reduced range formula. -real, parameter :: a0 = 7.057924e-4, a1 = 3.480336e-7, a2 = -1.112733e-7 ! a0/a1 ~= 2028 ; a0/a2 ~= -6343 -real, parameter :: b0 = 5.790749e8, b1 = 3.516535e6, b2 = -4.002714e4 ! b0/b1 ~= 165 ; b0/b4 ~= 974 -real, parameter :: b3 = 2.084372e2, b4 = 5.944068e5, b5 = -9.643486e3 -real, parameter :: c0 = 1.704853e5, c1 = 7.904722e2, c2 = -7.984422 ! c0/c1 ~= 216 ; c0/c4 ~= -740 -real, parameter :: c3 = 5.140652e-2, c4 = -2.302158e2, c5 = -3.079464 + ! 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] +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 @@ -86,13 +102,16 @@ subroutine calculate_density_scalar_wright(T, S, pressure, rho, rho_ref) ! *====================================================================* ! * 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 * +! * [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, S0, pressure0, rho0 + 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 @@ -118,8 +137,13 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ ! Original coded by R. Hallberg, 7/00, anomaly coded in 3/18. ! Local variables - real :: al0, p0, lambda - real :: al_TS, p_TSp, lam_TS, pa_000 + 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) @@ -155,7 +179,10 @@ subroutine calculate_spec_vol_scalar_wright(T, S, pressure, specvol, spv_ref) real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! Local variables - real, dimension(1) :: T0, S0, pressure0, spv0 + 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 @@ -170,7 +197,7 @@ end subroutine calculate_spec_vol_scalar_wright !! 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]. + !! 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]. @@ -179,7 +206,9 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! Local variables - real :: al0, p0, lambda + 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 @@ -209,7 +238,10 @@ subroutine calculate_density_derivs_array_wright(T, S, pressure, drho_dT, drho_d integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: al0, p0, lambda, I_denom2 + 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 @@ -241,8 +273,11 @@ subroutine calculate_density_derivs_scalar_wright(T, S, pressure, drho_dT, drho_ !! in [kg m-3 PSU-1]. ! Local variables needed to promote the input/output scalars to 1-element arrays - real, dimension(1) :: T0, S0, P0 - real, dimension(1) :: drdt0, drds0 + 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 @@ -261,19 +296,28 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh 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 respcct + 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] + !! 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] + !! 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, z2, z3, z4, z5, z6 ,z7, z8, z9, z10, z11, z2_2, z2_3 + 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 @@ -313,17 +357,26 @@ subroutine calculate_density_second_derivs_scalar_wright(T, S, P, drho_ds_ds, dr 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 respcct + 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] + !! 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] + !! to pressure [kg m-3 degC-1 Pa-1] = [s2 m-2 degC-1] ! Local variables - real, dimension(1) :: T0, S0, P0 - real, dimension(1) :: drdsds, drdsdt, drdtdt, drdsdp, drdtdp + 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 @@ -346,12 +399,14 @@ subroutine calculate_specvol_derivs_wright(T, S, pressure, dSV_dT, dSV_dS, start 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 / Pa]. + !! 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, lambda, I_denom + 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 @@ -370,11 +425,10 @@ 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 in psu), potential -!! temperature (T [degC]), and pressure [Pa]. It uses the expressions -!! from Wright, 1997, J. Atmos. Ocean. Tech., 14, 735-740. +!> 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(T, S, pressure, rho, drho_dp, start, npts) real, intent(in), dimension(:) :: T !< Potential temperature relative to the surface [degC]. @@ -389,7 +443,10 @@ subroutine calculate_compress_wright(T, S, pressure, rho, drho_dp, start, npts) ! Coded by R. Hallberg, 1/01 ! Local variables - real :: al0, p0, lambda, I_denom + 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 @@ -421,7 +478,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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 calucated as p~=-z*rho_0*G_e.) + !! (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. @@ -454,7 +511,7 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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 ppt [ppt S-1 ~> 1]. + !! into PSU [PSU S-1 ~> 1]. real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables @@ -488,20 +545,20 @@ subroutine int_density_dz_wright(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & ! 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 ppt-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 ppt-1] - real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 ppt-1] + 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 ppt-1] - real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 ppt-1] + 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. - real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. + 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 @@ -716,7 +773,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & 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 ppt [ppt S-1 ~> 1]. + !! 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] @@ -743,27 +800,27 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & 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 ppt-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 ppt-1] - real :: b5s ! Partly rescaled version of b5 [Pa C-1 S-1 ~> Pa degC-1 ppt-1] + 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 ppt-1] - real :: c5s ! Partly rescaled version of c5 [m2 s-2 C-1 S-1 ~> m2 s-2 degC-1 ppt-1] + 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. - real, parameter :: C1_9 = 1.0/9.0, C1_90 = 1.0/90.0 ! Rational constants. + 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 + 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 @@ -842,7 +899,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & 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 wekghted. + ! 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) @@ -883,7 +940,7 @@ subroutine int_spec_vol_dp_wright(T, S, p_t, p_b, spv_ref, HI, dza, & 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 wekghted. + ! 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) diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 2b4f99adf0..07464861cb 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -21,16 +21,16 @@ module MOM_EOS_linear ! 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 density of sea water (in kg/m^3), or its anomaly from a reference density, -!! using a simple linear equation of state from salinity (in psu), potential temperature (in deg C) -!! and pressure [Pa]. +!> Compute the density of sea water (in [kg m-3]), or its anomaly from a reference density, +!! using a simple linear equation of state from salinity in practical salinity units ([PSU]), +!! potential temperature in degrees Celsius ([degC]) and pressure [Pa]. interface calculate_density_linear module procedure calculate_density_scalar_linear, calculate_density_array_linear end interface calculate_density_linear -!> Compute the specific volume of sea water (in m^3/kg), or its anomaly from a reference value, -!! using a simple linear equation of state from salinity (in psu), potential temperature (in deg C) -!! and pressure [Pa]. +!> Compute the specific volume of sea water (in [m3 kg-1]), or its anomaly from a reference value, +!! using a simple linear equation of state from salinity in practical salinity units ([PSU]), +!! potential temperature in degrees Celsius ([degC]) and pressure [Pa]. interface calculate_spec_vol_linear module procedure calculate_spec_vol_scalar_linear, calculate_spec_vol_array_linear end interface calculate_spec_vol_linear @@ -75,7 +75,7 @@ subroutine calculate_density_scalar_linear(T, S, pressure, rho, & end subroutine calculate_density_scalar_linear !> This subroutine computes the density of sea water with a trivial -!! linear equation of state (in kg/m^3) from salinity (sal in psu), +!! linear equation of state (in [kg m-3]) from salinity (sal [PSU]), !! potential temperature (T [degC]), and pressure [Pa]. subroutine calculate_density_array_linear(T, S, pressure, rho, start, npts, & Rho_T0_S0, dRho_dT, dRho_dS, rho_ref) @@ -561,8 +561,8 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & 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 + 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 do_massWeight = .false. if (present(useMassWghtInterp)) then ; if (useMassWghtInterp) then @@ -612,7 +612,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & 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 wekghted. + ! is linear, but for T and S it may be thickness weighted. dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i+1,j)) + & @@ -657,7 +657,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & 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 wekghted. + ! is linear, but for T and S it may be thickness weighted. dp = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) dRho_TS = dRho_dT*(wtT_L*T(i,j) + wtT_R*T(i,j+1)) + & diff --git a/src/equation_of_state/MOM_TFreeze.F90 b/src/equation_of_state/MOM_TFreeze.F90 index f0b22c8f4e..16a64c89ed 100644 --- a/src/equation_of_state/MOM_TFreeze.F90 +++ b/src/equation_of_state/MOM_TFreeze.F90 @@ -28,7 +28,7 @@ module MOM_TFreeze module procedure calculate_TFreeze_Millero_scalar, calculate_TFreeze_Millero_array end interface calculate_TFreeze_Millero -!> Compute the freezing point conservative temperature [degC] from absolute salinity [g/kg] +!> Compute the freezing point conservative temperature [degC] from absolute salinity [g kg-1] !! and pressure [Pa] using the TEOS10 package. interface calculate_TFreeze_teos10 module procedure calculate_TFreeze_teos10_scalar, calculate_TFreeze_teos10_array @@ -84,13 +84,15 @@ end subroutine calculate_TFreeze_linear_array !! 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). subroutine calculate_TFreeze_Millero_scalar(S, pres, T_Fr) - real, intent(in) :: S !< Salinity in PSU. - real, intent(in) :: pres !< Pressure [Pa]. - real, intent(out) :: T_Fr !< Freezing point potential temperature [degC]. + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pres !< Pressure [Pa] + real, intent(out) :: T_Fr !< Freezing point potential temperature [degC] ! Local variables - real, parameter :: cS1 = -0.0575, cS3_2 = 1.710523e-3, cS2 = -2.154996e-4 - real, parameter :: dTFr_dp = -7.75e-8 + real, parameter :: cS1 = -0.0575 ! A term in the freezing point fit [degC PSU-1] + real, parameter :: cS3_2 = 1.710523e-3 ! A term in the freezing point fit [degC PSU-3/2] + 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 @@ -110,8 +112,10 @@ subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real, parameter :: cS1 = -0.0575, cS3_2 = 1.710523e-3, cS2 = -2.154996e-4 - real, parameter :: dTFr_dp = -7.75e-8 + real, parameter :: cS1 = -0.0575 ! A term in the freezing point fit [degC PSU-1] + real, parameter :: cS3_2 = 1.710523e-3 ! A term in the freezing point fit [degC PSU-3/2] + 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] integer :: j do j=start,start+npts-1 @@ -121,17 +125,18 @@ subroutine calculate_TFreeze_Millero_array(S, pres, T_Fr, start, npts) end subroutine calculate_TFreeze_Millero_array -!> This subroutine computes the freezing point conservative temperature -!! [degC] from absolute salinity [g/kg], and pressure [Pa] using the +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using the !! TEOS10 package. subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) - real, intent(in) :: S !< Absolute salinity [g/kg]. + 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, pres0 - real, dimension(1) :: tfr0 + 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 @@ -141,22 +146,23 @@ subroutine calculate_TFreeze_teos10_scalar(S, pres, T_Fr) end subroutine calculate_TFreeze_teos10_scalar -!> This subroutine computes the freezing point conservative temperature -!! [degC] from absolute salinity [g/kg], and pressure [Pa] using the +!> This subroutine computes the freezing point conservative temperature [degC] +!! from absolute salinity [g kg-1], and pressure [Pa] using the !! TEOS10 package. subroutine calculate_TFreeze_teos10_array(S, pres, T_Fr, start, npts) - real, dimension(:), intent(in) :: S !< absolute salinity [g/kg]. + 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, parameter :: Pa2db = 1.e-4 ! The conversion factor from Pa to dbar. - real :: zs,zp + 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. - real, parameter :: saturation_fraction = 0.0 + real, parameter :: saturation_fraction = 0.0 ! Air saturation fraction in seawater [nondim] do j=start,start+npts-1 !Conversions From 9412c9a89b469e4f43e9fbb29d81893a3b8be330 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Feb 2023 13:50:56 -0500 Subject: [PATCH 203/629] Fixes build failure in gitlab pipeline - After a recent update to how the build environment is defined within MOM6-examples, the "no libraries" build test (unique to MOM6) is failing because the Makefile now no longer contains the environment. This commit overrides a CPP macro that points to the bash script that is needed. --- .gitlab/pipeline-ci-tool.sh | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh index 8334bd3950..641e9f6053 100755 --- a/.gitlab/pipeline-ci-tool.sh +++ b/.gitlab/pipeline-ci-tool.sh @@ -135,7 +135,7 @@ nolibs-ocean-only-compile () { cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR mkdir -p build-ocean-only-nolibs-$1 cd build-ocean-only-nolibs-$1 - make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. -s + 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 @@ -153,7 +153,7 @@ nolibs-ocean-ice-compile () { cd $JOB_DIR/$STATS_REPO_DIR/$CONFIGS_DIR mkdir -p build-ocean-ice-nolibs-$1 cd build-ocean-ice-nolibs-$1 - make -f ../tools/MRS/Makefile.build ./$1/env BUILD=. -s + 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 From 6ffbc907506931b8aa0e139498e2af59e7ee26af Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Jan 2023 11:35:41 -0500 Subject: [PATCH 204/629] +Make output reproduce across layout if DEBUG=True This commit makes a set of changes so that the chksums output by the OM4_05 configuration with DEBUG = True reproduce between 252 and 256 PE runs (note that the solutions themselves already reproduced). This is includes adding a new optional omit_corners argument to the MOM_state_chksum and MOM_thermo_chksum routines, and revising the haloshift, omit_corners or symmetric arguments on 6 subroutine calls, to check more appropriate loop ranges. All answers are bitwise identical, but there is a new optional argument to three publicly visible debugging routines. --- src/core/MOM.F90 | 6 +-- src/core/MOM_checksum_packages.F90 | 50 ++++++++++++++-------- src/core/MOM_dynamics_split_RK2.F90 | 6 +-- src/parameterizations/lateral/MOM_MEKE.F90 | 4 +- 4 files changed, 39 insertions(+), 27 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index daa40ba052..00e748bdc1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1529,9 +1529,9 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) if (CS%debug) then - call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US) - call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, scale=US%C_to_degC) - call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, scale=US%S_to_ppt) + call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) + call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) + call hchksum(tv%S,"Pre-ALE S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) call check_redundant("Pre-ALE ", u, v, G, unscale=US%L_T_to_m_s) endif call cpu_clock_begin(id_clock_ALE) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 80630084b9..bc908ee60c 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -39,7 +39,7 @@ module MOM_checksum_packages ! ============================================================================= !> Write out chksums for the model's basic state variables, including transports. -subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, symmetric, vel_scale) +subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, symmetric, omit_corners, vel_scale) character(len=*), & intent(in) :: mesg !< A message that appears on the chksum lines. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -60,6 +60,7 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully symmetric !! computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts real, optional, intent(in) :: vel_scale !< The scaling factor to convert velocities to [m s-1] real :: scale_vel ! The scaling factor to convert velocities to [m s-1] @@ -73,16 +74,17 @@ subroutine MOM_state_chksum_5arg(mesg, u, v, h, uh, vh, G, GV, US, haloshift, sy sym = .false. ; if (present(symmetric)) sym=symmetric scale_vel = US%L_T_to_m_s ; if (present(vel_scale)) scale_vel = vel_scale - call uvchksum(mesg//" [uv]", u, v, G%HI, haloshift=hs, symmetric=sym, scale=scale_vel) - call hchksum(h, mesg//" h", G%HI, haloshift=hs, scale=GV%H_to_m) - call uvchksum(mesg//" [uv]h", uh, vh, G%HI, haloshift=hs, & - symmetric=sym, scale=GV%H_to_m*US%L_to_m**2*US%s_to_T) + 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 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) end subroutine MOM_state_chksum_5arg ! ============================================================================= !> Write out chksums for the model's basic state variables. -subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) +subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric, omit_corners) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -97,6 +99,7 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). logical, optional, intent(in) :: symmetric !< If true, do checksums on the fully !! symmetric computational domain. + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts integer :: hs logical :: sym @@ -106,34 +109,43 @@ subroutine MOM_state_chksum_3arg(mesg, u, v, h, G, GV, US, haloshift, symmetric) ! and js...je as their extent. hs = 1 ; if (present(haloshift)) hs = haloshift sym = .false. ; if (present(symmetric)) sym = symmetric - call uvchksum(mesg//" u", u, v, G%HI, haloshift=hs, symmetric=sym, scale=US%L_T_to_m_s) - call hchksum(h, mesg//" h",G%HI, haloshift=hs, scale=GV%H_to_m) + 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) end subroutine MOM_state_chksum_3arg ! ============================================================================= !> Write out chksums for the model's thermodynamic state variables. -subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift) +subroutine MOM_thermo_chksum(mesg, tv, G, US, haloshift, omit_corners) character(len=*), intent(in) :: mesg !< A message that appears on the chksum lines. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, optional, intent(in) :: haloshift !< The width of halos to check (default 0). + logical, optional, intent(in) :: omit_corners !< If true, avoid checking diagonal shifts integer :: hs hs=1 ; if (present(haloshift)) hs=haloshift - if (associated(tv%T)) call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, scale=US%C_to_degC) - if (associated(tv%S)) call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, scale=US%S_to_ppt) - if (associated(tv%frazil)) call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, & - scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) - if (associated(tv%salt_deficit)) call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, & - scale=US%S_to_ppt*US%RZ_to_kg_m2) - if (associated(tv%varT)) call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, scale=US%C_to_degC**2) - if (associated(tv%varS)) call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, scale=US%S_to_ppt**2) - if (associated(tv%covarTS)) call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, & - scale=US%S_to_ppt*US%C_to_degC) + if (associated(tv%T)) & + call hchksum(tv%T, mesg//" T", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC) + if (associated(tv%S)) & + call hchksum(tv%S, mesg//" S", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt) + if (associated(tv%frazil)) & + call hchksum(tv%frazil, mesg//" frazil", G%HI, haloshift=hs, omit_corners=omit_corners, & + scale=US%Q_to_J_kg*US%R_to_kg_m3*US%Z_to_m) + if (associated(tv%salt_deficit)) & + call hchksum(tv%salt_deficit, mesg//" salt deficit", G%HI, haloshift=hs, omit_corners=omit_corners, & + scale=US%S_to_ppt*US%RZ_to_kg_m2) + if (associated(tv%varT)) & + call hchksum(tv%varT, mesg//" varT", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%C_to_degC**2) + if (associated(tv%varS)) & + call hchksum(tv%varS, mesg//" varS", G%HI, haloshift=hs, omit_corners=omit_corners, scale=US%S_to_ppt**2) + if (associated(tv%covarTS)) & + call hchksum(tv%covarTS, mesg//" covarTS", G%HI, haloshift=hs, omit_corners=omit_corners, & + scale=US%S_to_ppt*US%C_to_degC) end subroutine MOM_thermo_chksum diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 1d7a70a55c..74ab4e1f18 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -647,7 +647,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! 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=2, & + 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) @@ -867,8 +867,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call cpu_clock_end(id_clock_mom_update) 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=2, scale=GV%H_to_m) + 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 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) ! call MOM_state_chksum("Corrector 1", u, v, h, uh, vh, G, GV, US, haloshift=1) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 8d6eda728d..add2d6a984 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -260,7 +260,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h call hchksum(MEKE%MEKE, 'MEKE MEKE', G%HI, scale=US%L_T_to_m_s**2) call uvchksum("MEKE SN_[uv]", SN_u, SN_v, G%HI, scale=US%s_to_T, & scalar_pair=.true.) - call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=1, & + call uvchksum("MEKE h[uv]", hu, hv, G%HI, haloshift=0, symmetric=.true., & scale=GV%H_to_m*(US%L_to_m**2)) endif @@ -293,7 +293,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo ; enddo enddo if (CS%MEKE_advection_bug) then - ! This code obviously incorrect code reproduces a bug in the original implementation of + ! This obviously incorrect code reproduces a bug in the original implementation of ! the MEKE advection. do j=js,je ; do I=is-1,ie baroHu(I,j) = hu(I,j,nz) * GV%H_to_RZ From 8b528fd8957e4802788bce118d056d97c7800aff Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Jan 2023 16:20:16 -0500 Subject: [PATCH 205/629] Document units of 30 driver variables Added or amended comments to document the units of 30 variables in FMS_cap/MOM_surface_forcing_gfdl.F90, FMS_cap/ocean_model_MOM.F90, solo_driver/MOM_surface_forcing and unit_drivers/MOM_sum_driver.F90. Only comments are changed, and all answers are bitwise identical. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 19 ++++++++++------- .../drivers/FMS_cap/ocean_model_MOM.F90 | 21 +++++++++---------- .../solo_driver/MOM_surface_forcing.F90 | 6 +++--- .../drivers/unit_drivers/MOM_sum_driver.F90 | 21 ++++++++++--------- 4 files changed, 35 insertions(+), 32 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 cd0106ec48..9a00f487e4 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -92,7 +92,7 @@ module MOM_surface_forcing_gfdl !! contributes to ustar [R L Z T-1 ~> Pa]. gust is used when read_gust_2d is true. real, pointer, dimension(:,:) :: & ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] - real :: cd_tides !< Drag coefficient that applies to the tides (nondimensional) + real :: cd_tides !< Drag coefficient that applies to the tides [nondim] real :: utide !< Constant tidal velocity to use if read_tideamp is false [Z T-1 ~> m s-1]. logical :: read_tideamp !< If true, spatially varying tidal amplitude read from a file. @@ -127,7 +127,7 @@ module MOM_surface_forcing_gfdl logical :: mask_srestore_marginal_seas !< If true, then mask SSS restoring in marginal seas real :: max_delta_srestore !< Maximum delta salinity used for restoring [S ~> ppt] real :: max_delta_trestore !< Maximum delta sst used for restoring [C ~> degC] - real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin + real, pointer, dimension(:,:) :: basin_mask => NULL() !< Mask for surface salinity restoring by basin [nondim] integer :: answer_date !< The vintage of the order of arithmetic and expressions in the !! gustiness calculations. Values below 20190101 recover the answers !! from the end of 2018, while higher values use a simpler expression @@ -144,14 +144,14 @@ module MOM_surface_forcing_gfdl !! salinity restoring fluxes. The masking file should be !! in inputdir/salt_restore_mask.nc and the field should !! be named 'mask' - real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring + real, pointer, dimension(:,:) :: srestore_mask => NULL() !< mask for SSS restoring [nondim] character(len=200) :: temp_restore_file !< Filename for sst restoring data character(len=30) :: temp_restore_var_name !< Name of surface temperature in temp_restore_file logical :: mask_trestore !< If true, apply a 2-dimensional mask to the surface !! temperature restoring fluxes. The masking file should be !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' - real, pointer, dimension(:,:) :: trestore_mask => NULL() !< Mask for SST restoring + 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. @@ -250,7 +250,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! mass fluxes [R Z s m2 kg-1 T-1 ~> 1] real :: rhoXcp ! Reference density times heat capacity times unit scaling ! factors [Q R C-1 ~> J m-3 degC-1] - real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1. + real :: sign_for_net_FW_bug ! Should be +1. but an old bug can be recovered by using -1 [nondim] call cpu_clock_begin(id_clock_forcing) @@ -1169,7 +1169,10 @@ subroutine apply_force_adjustments(G, US, CS, Time, forces) real, dimension(SZI_(G),SZJ_(G)) :: tempy_at_h ! Delta to meridional wind stress at h points [R Z L T-2 ~> Pa] integer :: isc, iec, jsc, jec, i, j - real :: dLonDx, dLonDy, rDlon, cosA, sinA, zonal_tau, merid_tau + real :: dLonDx, dLonDy ! The change in longitude across the cell in the x- and y-directions [degrees_E] + 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 @@ -1714,8 +1717,8 @@ end subroutine ice_ocn_bnd_type_chksum !> Check the values passed by IOB over land are zero subroutine check_mask_val_consistency(val, mask, i, j, varname, G) - real, intent(in) :: val !< value of flux/variable passed by IOB - real, intent(in) :: mask !< value of ocean mask + real, intent(in) :: val !< value of flux/variable passed by IOB [various] + real, intent(in) :: mask !< value of ocean mask [nondim] integer, intent(in) :: i !< model grid cell indices integer, intent(in) :: j !< model grid cell indices character(len=*), intent(in) :: varname !< variable name diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 049ae3d3df..005e3a6723 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -462,7 +462,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda ! internal modules. type(time_type) :: Time1 ! The value of the ocean model's time at the start of a call to step_MOM. integer :: index_bnds(4) ! The computational domain index bounds in the ice-ocean boundary type. - real :: weight ! Flux accumulation weight of the current fluxes. + real :: weight ! Flux accumulation weight of the current fluxes [nondim]. real :: dt_coupling ! The coupling time step [T ~> s]. real :: dt_therm ! A limited and quantized version of OS%dt_therm [T ~> s]. real :: dt_dyn ! The dynamics time step [T ~> s]. @@ -834,7 +834,6 @@ subroutine convert_state_to_ocean_type(sfc_state, Ocean_sfc, G, US, patm, press_ real, optional, intent(in) :: press_to_z !< A conversion factor between pressure and ocean !! depth, usually 1/(rho_0*g) [Z T2 R-1 L-2 ~> m Pa-1] ! Local variables - real :: IgR0 character(len=48) :: val_str integer :: isc_bnd, iec_bnd, jsc_bnd, jec_bnd integer :: i, j, i0, j0, is, ie, js, je @@ -989,7 +988,7 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) type(ocean_state_type), pointer :: OS !< A structure containing the internal ocean state. !! The data in OS is intent in. integer, intent(in) :: index !< The stock index for the quantity of interest. - real, intent(out) :: value !< Sum returned for the conservation quantity of interest. + real, intent(out) :: value !< Sum returned for the conservation quantity of interest [various] integer, optional, intent(in) :: time_index !< An unused optional argument, present only for !! interfacial compatibility with other models. ! Arguments: OS - A structure containing the internal ocean state. @@ -997,23 +996,23 @@ subroutine Ocean_stock_pe(OS, index, value, time_index) ! (in) value - Sum returned for the conservation quantity of interest. ! (in,opt) time_index - Index for time level to use if this is necessary. - real :: salt + real :: salt ! The total salt in the ocean [kg] value = 0.0 if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return select case (index) - case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in kg. + case (ISTOCK_WATER) ! Return the mass of fresh water in the ocean in [kg]. if (OS%GV%Boussinesq) then call get_ocean_stocks(OS%MOM_CSp, mass=value, on_PE_only=.true.) else ! In non-Boussinesq mode, the mass of salt needs to be subtracted. call get_ocean_stocks(OS%MOM_CSp, mass=value, salt=salt, on_PE_only=.true.) value = value - salt endif - case (ISTOCK_HEAT) ! Return the heat content of the ocean in J. + case (ISTOCK_HEAT) ! Return the heat content of the ocean in [J]. call get_ocean_stocks(OS%MOM_CSp, heat=value, on_PE_only=.true.) - case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in kg. + case (ISTOCK_SALT) ! Return the mass of the salt in the ocean in [kg]. call get_ocean_stocks(OS%MOM_CSp, salt=value, on_PE_only=.true.) case default ; value = 0.0 end select @@ -1032,7 +1031,7 @@ subroutine ocean_model_data2D_get(OS, Ocean, name, array2D, isc, jsc) !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the field to extract real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain + !! cover only the computational domain [various] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D @@ -1092,8 +1091,8 @@ subroutine ocean_model_data1D_get(OS, Ocean, name, value) !! internal ocean state (intent in). type(ocean_public_type), intent(in) :: Ocean !< A structure containing various publicly !! visible ocean surface fields. - character(len=*) , intent(in) :: name !< The name of the field to extract - real , intent(out):: value !< The value of the named field + character(len=*), intent(in) :: name !< The name of the field to extract + real, intent(out):: value !< The value of the named field [various] if (.not.associated(OS)) return if (.not.OS%is_ocean_pe) return @@ -1155,7 +1154,7 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) !! visible ocean surface fields. character(len=*) , intent(in) :: name !< The name of the current (ua or va) to extract real, dimension(isc:,jsc:), intent(out):: array2D !< The values of the named field, it must - !! cover only the computational domain + !! cover only the computational domain [L T-1 ~> m s-1] integer , intent(in) :: isc !< The starting i-index of array2D integer , intent(in) :: jsc !< The starting j-index of array2D diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 8b1c9aaa27..04612b4138 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -73,8 +73,8 @@ module MOM_surface_forcing logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing logical :: variable_winds !< if true, wind stresses vary with time logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. - real :: south_lat !< southern latitude of the domain - real :: len_lat !< domain length in latitude + real :: south_lat !< southern latitude of the domain [degrees_N] or [km] or [m] + real :: len_lat !< domain length in latitude [degrees_N] or [km] or [m] real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] @@ -104,7 +104,7 @@ module MOM_surface_forcing real :: gyres_taux_const !< A constant wind stress [R L Z T-1 ~> Pa]. real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [R L Z T-1 ~> Pa], if WIND_CONFIG=='gyres' real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [R L Z T-1 ~> Pa], if WIND_CONFIG=='gyres' - real :: gyres_taux_n_pis !< The number of sine lobes in the basin if WIND_CONFIG=='gyres' + real :: gyres_taux_n_pis !< The number of sine lobes in the basin if WIND_CONFIG=='gyres' [nondim] integer :: answer_date !< This 8-digit integer gives the approximate date with which the order !! of arithmetic and expressions were added to the code. !! Dates before 20190101 use original answers. diff --git a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 index f962719d93..0a6191b286 100644 --- a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 +++ b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 @@ -51,7 +51,7 @@ program MOM_sum_driver logical :: unit_in_use real, allocatable, dimension(:) :: & - depth_tot_R, depth_tot_std, depth_tot_fastR + depth_tot_R, depth_tot_std, depth_tot_fastR ! Various sums of the depths [m] integer :: reproClock, fastreproClock, stdClock, initClock !----------------------------------------------------------------------- @@ -175,16 +175,17 @@ program MOM_sum_driver subroutine benchmark_init_topog_local(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in m or [Z ~> m] if US is present + intent(out) :: D !< Ocean bottom depth in [m] type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters real, intent(in) :: max_depth !< The maximum ocean depth [m] - real :: min_depth ! The minimum ocean depth in m. - real :: PI ! 3.1415926... calculated as 4*atan(1) - real :: D0 ! A constant to make the maximum ! - ! basin depth MAXIMUM_DEPTH. ! - real :: m_to_Z ! A dimensional rescaling factor. - real :: x, y + real :: min_depth ! The minimum ocean depth in [m]. + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] + real :: D0 ! A constant to make the maximum + ! basin depth MAXIMUM_DEPTH [m] + real :: m_to_Z ! A dimensional rescaling factor [m ~> Z] + real :: x ! A fractional position in the x-direction [nondim] + real :: y ! A fractional position in the y-direction [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "benchmark_init_topog_local" ! This subroutine's name. @@ -203,8 +204,8 @@ subroutine benchmark_init_topog_local(D, G, param_file, max_depth) ! Calculate the depth of the bottom. do i=is,ie ; do j=js,je - x=(G%geoLonT(i,j)-G%west_lon)/G%len_lon - y=(G%geoLatT(i,j)-G%south_lat)/G%len_lat + x = (G%geoLonT(i,j)-G%west_lon)/G%len_lon + y = (G%geoLatT(i,j)-G%south_lat)/G%len_lat ! This sets topography that has a reentrant channel to the south. D(i,j) = -D0 * ( y*(1.0 + 0.6*cos(4.0*PI*x)) & + 0.75*exp(-6.0*y) & From 2b4627501ba3dfd4ea17d2b6e6ff37566f3d827f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 4 Feb 2023 15:57:32 -0500 Subject: [PATCH 206/629] Document units of 172 MOM_EOS_NEMO variables Added or amended comments to document the units of about 172 parameters or variables in MOM_EOS_NEMO.F90. Only comments are changed, and all answers are bitwise identical. --- src/equation_of_state/MOM_EOS_NEMO.F90 | 340 ++++++++++++++----------- 1 file changed, 185 insertions(+), 155 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 index de4a715489..dee2bc48bf 100644 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ b/src/equation_of_state/MOM_EOS_NEMO.F90 @@ -22,8 +22,8 @@ module MOM_EOS_NEMO public calculate_density_derivs_nemo public calculate_density_scalar_nemo, calculate_density_array_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), conservative temperature (in deg C), +!> 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 interface calculate_density_nemo module procedure calculate_density_scalar_nemo, calculate_density_array_nemo @@ -37,138 +37,143 @@ module MOM_EOS_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. -real, parameter :: r1_S0 = 0.875/35.16504 -real, parameter :: r1_T0 = 1./40. -real, parameter :: r1_P0 = 1.e-4 -real, parameter :: R00 = 4.6494977072e+01 -real, parameter :: R01 = -5.2099962525 -real, parameter :: R02 = 2.2601900708e-01 -real, parameter :: R03 = 6.4326772569e-02 -real, parameter :: R04 = 1.5616995503e-02 -real, parameter :: R05 = -1.7243708991e-03 -real, parameter :: EOS000 = 8.0189615746e+02 -real, parameter :: EOS100 = 8.6672408165e+02 -real, parameter :: EOS200 = -1.7864682637e+03 -real, parameter :: EOS300 = 2.0375295546e+03 -real, parameter :: EOS400 = -1.2849161071e+03 -real, parameter :: EOS500 = 4.3227585684e+02 -real, parameter :: EOS600 = -6.0579916612e+01 -real, parameter :: EOS010 = 2.6010145068e+01 -real, parameter :: EOS110 = -6.5281885265e+01 -real, parameter :: EOS210 = 8.1770425108e+01 -real, parameter :: EOS310 = -5.6888046321e+01 -real, parameter :: EOS410 = 1.7681814114e+01 -real, parameter :: EOS510 = -1.9193502195 -real, parameter :: EOS020 = -3.7074170417e+01 -real, parameter :: EOS120 = 6.1548258127e+01 -real, parameter :: EOS220 = -6.0362551501e+01 -real, parameter :: EOS320 = 2.9130021253e+01 -real, parameter :: EOS420 = -5.4723692739 -real, parameter :: EOS030 = 2.1661789529e+01 -real, parameter :: EOS130 = -3.3449108469e+01 -real, parameter :: EOS230 = 1.9717078466e+01 -real, parameter :: EOS330 = -3.1742946532 -real, parameter :: EOS040 = -8.3627885467 -real, parameter :: EOS140 = 1.1311538584e+01 -real, parameter :: EOS240 = -5.3563304045 -real, parameter :: EOS050 = 5.4048723791e-01 -real, parameter :: EOS150 = 4.8169980163e-01 -real, parameter :: EOS060 = -1.9083568888e-01 -real, parameter :: EOS001 = 1.9681925209e+01 -real, parameter :: EOS101 = -4.2549998214e+01 -real, parameter :: EOS201 = 5.0774768218e+01 -real, parameter :: EOS301 = -3.0938076334e+01 -real, parameter :: EOS401 = 6.6051753097 -real, parameter :: EOS011 = -1.3336301113e+01 -real, parameter :: EOS111 = -4.4870114575 -real, parameter :: EOS211 = 5.0042598061 -real, parameter :: EOS311 = -6.5399043664e-01 -real, parameter :: EOS021 = 6.7080479603 -real, parameter :: EOS121 = 3.5063081279 -real, parameter :: EOS221 = -1.8795372996 -real, parameter :: EOS031 = -2.4649669534 -real, parameter :: EOS131 = -5.5077101279e-01 -real, parameter :: EOS041 = 5.5927935970e-01 -real, parameter :: EOS002 = 2.0660924175 -real, parameter :: EOS102 = -4.9527603989 -real, parameter :: EOS202 = 2.5019633244 -real, parameter :: EOS012 = 2.0564311499 -real, parameter :: EOS112 = -2.1311365518e-01 -real, parameter :: EOS022 = -1.2419983026 -real, parameter :: EOS003 = -2.3342758797e-02 -real, parameter :: EOS103 = -1.8507636718e-02 -real, parameter :: EOS013 = 3.7969820455e-01 -real, parameter :: ALP000 = -6.5025362670e-01 -real, parameter :: ALP100 = 1.6320471316 -real, parameter :: ALP200 = -2.0442606277 -real, parameter :: ALP300 = 1.4222011580 -real, parameter :: ALP400 = -4.4204535284e-01 -real, parameter :: ALP500 = 4.7983755487e-02 -real, parameter :: ALP010 = 1.8537085209 -real, parameter :: ALP110 = -3.0774129064 -real, parameter :: ALP210 = 3.0181275751 -real, parameter :: ALP310 = -1.4565010626 -real, parameter :: ALP410 = 2.7361846370e-01 -real, parameter :: ALP020 = -1.6246342147 -real, parameter :: ALP120 = 2.5086831352 -real, parameter :: ALP220 = -1.4787808849 -real, parameter :: ALP320 = 2.3807209899e-01 -real, parameter :: ALP030 = 8.3627885467e-01 -real, parameter :: ALP130 = -1.1311538584 -real, parameter :: ALP230 = 5.3563304045e-01 -real, parameter :: ALP040 = -6.7560904739e-02 -real, parameter :: ALP140 = -6.0212475204e-02 -real, parameter :: ALP050 = 2.8625353333e-02 -real, parameter :: ALP001 = 3.3340752782e-01 -real, parameter :: ALP101 = 1.1217528644e-01 -real, parameter :: ALP201 = -1.2510649515e-01 -real, parameter :: ALP301 = 1.6349760916e-02 -real, parameter :: ALP011 = -3.3540239802e-01 -real, parameter :: ALP111 = -1.7531540640e-01 -real, parameter :: ALP211 = 9.3976864981e-02 -real, parameter :: ALP021 = 1.8487252150e-01 -real, parameter :: ALP121 = 4.1307825959e-02 -real, parameter :: ALP031 = -5.5927935970e-02 -real, parameter :: ALP002 = -5.1410778748e-02 -real, parameter :: ALP102 = 5.3278413794e-03 -real, parameter :: ALP012 = 6.2099915132e-02 -real, parameter :: ALP003 = -9.4924551138e-03 -real, parameter :: BET000 = 1.0783203594e+01 -real, parameter :: BET100 = -4.4452095908e+01 -real, parameter :: BET200 = 7.6048755820e+01 -real, parameter :: BET300 = -6.3944280668e+01 -real, parameter :: BET400 = 2.6890441098e+01 -real, parameter :: BET500 = -4.5221697773 -real, parameter :: BET010 = -8.1219372432e-01 -real, parameter :: BET110 = 2.0346663041 -real, parameter :: BET210 = -2.1232895170 -real, parameter :: BET310 = 8.7994140485e-01 -real, parameter :: BET410 = -1.1939638360e-01 -real, parameter :: BET020 = 7.6574242289e-01 -real, parameter :: BET120 = -1.5019813020 -real, parameter :: BET220 = 1.0872489522 -real, parameter :: BET320 = -2.7233429080e-01 -real, parameter :: BET030 = -4.1615152308e-01 -real, parameter :: BET130 = 4.9061350869e-01 -real, parameter :: BET230 = -1.1847737788e-01 -real, parameter :: BET040 = 1.4073062708e-01 -real, parameter :: BET140 = -1.3327978879e-01 -real, parameter :: BET050 = 5.9929880134e-03 -real, parameter :: BET001 = -5.2937873009e-01 -real, parameter :: BET101 = 1.2634116779 -real, parameter :: BET201 = -1.1547328025 -real, parameter :: BET301 = 3.2870876279e-01 -real, parameter :: BET011 = -5.5824407214e-02 -real, parameter :: BET111 = 1.2451933313e-01 -real, parameter :: BET211 = -2.4409539932e-02 -real, parameter :: BET021 = 4.3623149752e-02 -real, parameter :: BET121 = -4.6767901790e-02 -real, parameter :: BET031 = -6.8523260060e-03 -real, parameter :: BET002 = -6.1618945251e-02 -real, parameter :: BET102 = 6.2255521644e-02 -real, parameter :: BET012 = -2.6514181169e-03 -real, parameter :: BET003 = -2.3025968587e-04 +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] + +! 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 +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 = -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] !>@} contains @@ -212,20 +217,31 @@ subroutine calculate_density_array_nemo(T, S, pressure, rho, start, npts, rho_re real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables - real :: zp, zt, zs, zr0, zn, zn0, zn1, zn2, zn3, zs0 + 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] integer :: j do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar + ! 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 - zt = zt * r1_T0 !temperature - zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root salinity + 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] zn3 = EOS013*zt & & + EOS103*zs+EOS003 @@ -276,20 +292,33 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, integer, intent(in) :: npts !< The number of values to calculate. ! Local variables - real :: zp, zt, zs, zn, zn0, zn1, zn2, zn3 + 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 integer :: j do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potantial temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar + ! 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 (first converted to decibar) - zt = zt * r1_T0 ! temperature - zs = SQRT( ABS( zs + rdeltaS ) * r1_S0 ) ! square root salinity + 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] ! ! alpha zn3 = ALP003 @@ -331,7 +360,8 @@ subroutine calculate_density_derivs_array_nemo(T, S, pressure, drho_dT, drho_dS, & + ((((BET500*zs+BET400)*zs+BET300)*zs+BET200)*zs+BET100)*zs+BET000 ! zn = ( ( zn3 * zp + zn2 ) * zp + zn1 ) * zp + zn0 - ! + + ! 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 enddo @@ -391,10 +421,10 @@ subroutine calculate_compress_nemo(T, S, pressure, rho, drho_dp, start, npts) ! since the corresponding NEMO approximation is not available yet. ! do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar + ! 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)) enddo end subroutine calculate_compress_nemo From f54956edd2fdc0c86de8f7a6529baf4f1dba49cc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Feb 2023 17:45:48 -0500 Subject: [PATCH 207/629] +Add optional unscale argument to log_param_real This commit adds an optional unscale argument to the log_param_real interfaces. All answers and output are bitwise identical. --- src/framework/MOM_file_parser.F90 | 26 ++++++++++++++++++-------- 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 3a25981dc8..fd447f5193 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1411,7 +1411,7 @@ end subroutine log_param_int_array !> Log the name and value of a real model parameter in documentation files. subroutine log_param_real(CS, modulename, varname, value, desc, units, & - default, debuggingParam, like_default) + default, debuggingParam, like_default, unscale) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1425,26 +1425,31 @@ subroutine log_param_real(CS, modulename, varname, value, desc, units, & !! logged in the debugging parameter file logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. + real, optional, intent(in) :: unscale !< A reciprocal scaling factor that the parameter is + !! multiplied by before it is logged + real :: log_val ! The parameter value that is written out character(len=240) :: mesg, myunits + log_val = value ; if (present(unscale)) log_val = unscale * value + write(mesg, '(" ",a," ",a,": ",a)') & - trim(modulename), trim(varname), trim(left_real(value)) + trim(modulename), trim(varname), trim(left_real(log_val)) if (is_root_pe()) then if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) + write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, value, default, & + call doc_param(CS%doc, varname, desc, myunits, log_val, default, & debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real !> Log the name and values of an array of real model parameter in documentation files. subroutine log_param_real_array(CS, modulename, varname, value, desc, & - units, default, debuggingParam, like_default) + units, default, debuggingParam, like_default, unscale) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: modulename !< The name of the calling module @@ -1458,22 +1463,27 @@ subroutine log_param_real_array(CS, modulename, varname, value, desc, & !! logged in the debugging parameter file logical, optional, intent(in) :: like_default !< If present and true, log this parameter as !! though it has the default value, even if there is no default. + real, optional, intent(in) :: unscale !< A reciprocal scaling factor that the parameter is + !! multiplied by before it is logged + real, dimension(size(value)) :: log_val ! The array of parameter values that is written out character(len=:), allocatable :: mesg character(len=240) :: myunits + log_val(:) = value(:) ; if (present(unscale)) log_val(:) = unscale * value(:) + !write(mesg, '(" ",a," ",a,": ",ES19.12,99(",",ES19.12))') & !write(mesg, '(" ",a," ",a,": ",G,99(",",G))') & ! trim(modulename), trim(varname), value - mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(left_reals(value)) + mesg = " " // trim(modulename) // " " // trim(varname) // ": " // trim(left_reals(log_val)) if (is_root_pe()) then if (CS%log_open) write(CS%stdlog,'(a)') trim(mesg) if (CS%log_to_stdout) write(CS%stdout,'(a)') trim(mesg) endif - myunits="not defined"; if (present(units)) write(myunits(1:240),'(A)') trim(units) + write(myunits(1:240),'(A)') trim(units) if (present(desc)) & - call doc_param(CS%doc, varname, desc, myunits, value, default, & + call doc_param(CS%doc, varname, desc, myunits, log_val, default, & debuggingParam=debuggingParam, like_default=like_default) end subroutine log_param_real_array From ad56b29f1e38be507205c96fefbd151b2ff63151 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 6 Feb 2023 17:47:57 -0500 Subject: [PATCH 208/629] Use unscale argument in 10 log_param calls Use the new unscale optional argument in 10 log_param calls for real variables. All answers and output are bitwise identical. --- src/core/MOM_barotropic.F90 | 4 ++-- src/diagnostics/MOM_sum_output.F90 | 3 ++- src/initialization/MOM_fixed_initialization.F90 | 9 +++++---- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 4 ++-- src/parameterizations/vertical/MOM_energetic_PBL.F90 | 5 +++-- src/parameterizations/vertical/MOM_vert_friction.F90 | 8 ++++---- src/tracer/oil_tracer.F90 | 3 ++- 7 files changed, 20 insertions(+), 16 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 105e81732a..bb77a99c4c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4804,8 +4804,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, endif if ((dtbt_tmp > 0.0) .and. (dtbt_input > 0.0)) calc_dtbt = .false. - call log_param(param_file, mdl, "DTBT as used", CS%dtbt*US%T_to_s, units="s") - call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max*US%T_to_s, units="s") + call log_param(param_file, mdl, "DTBT as used", CS%dtbt, units="s", unscale=US%T_to_s) + call log_param(param_file, mdl, "estimated maximum DTBT", CS%dtbt_max, units="s", unscale=US%T_to_s) ! ubtav and vbtav, and perhaps ubt_IC and vbt_IC, are allocated and ! initialized in register_barotropic_restarts. diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 6dbe4997d6..94f34a6c56 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -199,7 +199,8 @@ subroutine MOM_sum_output_init(G, GV, US, param_file, directory, ntrnc, & "The maximum velocity allowed before the velocity "//& "components are truncated.", units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) CS%max_Energy = 10.0 * maxvel**2 - call log_param(param_file, mdl, "MAX_ENERGY as used", US%L_T_to_m_s**2*CS%max_Energy, units="m2 s-2") + call log_param(param_file, mdl, "MAX_ENERGY as used", CS%max_Energy, & + units="m2 s-2", unscale=US%L_T_to_m_s**2) endif call get_param(param_file, mdl, "ENERGYFILE", energyfile, & diff --git a/src/initialization/MOM_fixed_initialization.F90 b/src/initialization/MOM_fixed_initialization.F90 index 0cc3794543..322abc6d5e 100644 --- a/src/initialization/MOM_fixed_initialization.F90 +++ b/src/initialization/MOM_fixed_initialization.F90 @@ -244,12 +244,13 @@ subroutine MOM_initialize_topography(D, max_depth, G, PF, US) "Unrecognized topography setup '"//trim(config)//"'") end select if (max_depth>0.) then - call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth*US%Z_to_m, & - "The maximum depth of the ocean.", units="m") + call log_param(PF, mdl, "MAXIMUM_DEPTH", max_depth, & + "The maximum depth of the ocean.", units="m", unscale=US%Z_to_m) else max_depth = diagnoseMaximumDepth(D,G) - call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth*US%Z_to_m, & - "The (diagnosed) maximum depth of the ocean.", units="m", like_default=.true.) + call log_param(PF, mdl, "!MAXIMUM_DEPTH", max_depth, & + "The (diagnosed) maximum depth of the ocean.", & + units="m", unscale=US%Z_to_m, like_default=.true.) endif if (trim(config) /= "DOME") then call limit_topography(D, G, PF, max_depth, US) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 12a32e7376..01f8303ae2 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -176,11 +176,11 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL if (abs(CS%Kd_tot_ml - CS%Kd) > 1.0e-15*abs(CS%Kd)) & call MOM_error(WARNING, "KDML is a depricated parameter. Use KD_ML_TOT instead.") endif - call log_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml*US%Z2_T_to_m2_s, & + call log_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & "The total diapcynal diffusivity in the surface mixed layer when there is "//& "not a physically based parameterization of mixing in the mixed layer, such "//& "as bulk mixed layer or KPP or ePBL.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s) + units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, unscale=US%Z2_T_to_m2_s) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & "The prescribed depth over which the near-surface "//& diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 01885a0484..641816513c 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2321,9 +2321,10 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Logging parameters ! This gives a minimum decay scale that is typically much less than Angstrom. CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) - call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min*US%Z_to_m*US%s_to_T, & + call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min, & "The (tiny) minimum friction velocity used within the "//& - "ePBL code, derived from OMEGA and ANGSTROM.", units="m s-1", & + "ePBL code, derived from OMEGA and ANGSTROM.", & + units="m s-1", unscale=US%Z_to_m*US%s_to_T, & like_default=.true.) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 819b2ea8b3..ea6c7f112b 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2339,14 +2339,14 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") endif if (CS%Kvml_invZ2 < 0.0) CS%Kvml_invZ2 = 0.0 - call log_param(param_file, mdl, "KV_ML_INVZ2", US%Z2_T_to_m2_s*CS%Kvml_invZ2, & + call log_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& "distance from the surface, to allow for finite wind stresses to be "//& "transmitted through infinitesimally thin surface layers. This is an "//& "older option for numerical convenience without a strong physical basis, "//& "and its use is now discouraged.", & - units="m2 s-1", default=0.0) + units="m2 s-1", default=0.0, unscale=US%Z2_T_to_m2_s) endif if (.not.CS%bottomdraglaw) then @@ -2364,10 +2364,10 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%Kv_extra_bbl = Kv_BBL - CS%Kv endif endif - call log_param(param_file, mdl, "KV_EXTRA_BBL", US%Z2_T_to_m2_s*CS%Kv_extra_bbl, & + call log_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=0.0) + units="m2 s-1", default=0.0, unscale=US%Z2_T_to_m2_s) endif call get_param(param_file, mdl, "HBBL", CS%Hbbl, & "The thickness of a bottom boundary layer with a viscosity increased by "//& diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 544188bb7a..36b157547f 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -165,7 +165,8 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) endif endif enddo - call log_param(param_file, mdl, "OIL_DECAY_RATE", US%s_to_T*CS%oil_decay_rate(1:CS%ntr), units="s-1") + call log_param(param_file, mdl, "OIL_DECAY_RATE", CS%oil_decay_rate(1:CS%ntr), & + units="s-1", unscale=US%s_to_T) ! This needs to be changed if the units of tracer are changed above. if (GV%Boussinesq) then ; flux_units = "kg s-1" From 2fe2631ee9c79357a2898b1efd20bc8cbc228245 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Feb 2023 13:51:41 -0500 Subject: [PATCH 209/629] (*)Fix bug in CVMix_shear_is_used if USE_PP81=True Because get_param is case-sensitive, CVMix_shear_is_used can incorrectly return false if USE_PP81 = True and USE_LMD94 = False. This would cause such cases to fail to reproduce across restarts or use uninitialize or incorrect arrays, but because the Pacanowski and Philader parameterization is very out-dated it appears not to be used in any active test case. Moreover, no one has reported any such issues yet. Therefore, rather than adding a flag to reproduce the old (unreproducing) results, this commit simply corrects this bug. The (case-sensitive) parameter "Use_PP81" was also formally obsoleted. All answers are bitwise identical in all known MOM6 configurations, but this could lead to answer changes in certain unlikely configurations. --- src/diagnostics/MOM_obsolete_params.F90 | 3 ++- src/parameterizations/vertical/MOM_CVMix_shear.F90 | 8 ++++---- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index cea0c82bcf..99e6c386c6 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -89,6 +89,7 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") call obsolete_logical(param_file, "USE_VISBECK_SLOPE_BUG", .false.) + call obsolete_logical(param_file, "Use_PP81", hint="get_param is case sensitive so use USE_PP81.") call obsolete_logical(param_file, "ALLOW_CLOCKS_IN_OMP_LOOPS", .true.) call obsolete_logical(param_file, "LARGE_FILE_SUPPORT", .true.) @@ -114,7 +115,7 @@ subroutine obsolete_logical(param_file, varname, warning_val, hint) logical :: test_logic, fatal_err character(len=128) :: hint_msg - test_logic = .false. ; call read_param(param_file, varname,test_logic) + test_logic = .false. ; call read_param(param_file, varname, test_logic) fatal_err = .true. if (present(warning_val)) fatal_err = (warning_val .neqv. .true.) hint_msg = " " ; if (present(hint)) hint_msg = hint diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 4f13cf5793..7c927b0dfc 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -318,7 +318,7 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) end function CVMix_shear_init -!> Reads the parameters "LMD94" and "PP81" and returns state. +!> Reads the parameters "USE_LMD94" and "USE_PP81" and returns true if either is true. !! This function allows other modules to know whether this parameterization will !! be used without needing to duplicate the log entry. logical function CVMix_shear_is_used(param_file) @@ -326,9 +326,9 @@ logical function CVMix_shear_is_used(param_file) ! Local variables logical :: LMD94, PP81 call get_param(param_file, mdl, "USE_LMD94", LMD94, & - default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "Use_PP81", PP81, & - default=.false., do_not_log=.true.) + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_PP81", PP81, & + default=.false., do_not_log=.true.) CVMix_shear_is_used = (LMD94 .or. PP81) end function CVMix_shear_is_used From 4c3b409c48f78f3d3d5ad359d2a4e451b485b5b8 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 2 Feb 2023 14:04:25 -0500 Subject: [PATCH 210/629] Direct netCDF data reads This patch introduces `read_netCDF_data`, a new method for reading netCDF datasets using the native netCDF I/O interface. It is designed to resemble the existing `MOM_read_data` function. Motivation ---------- Legacy input files may contain content which is not supported by the newest framework I/O (FMS). In order to retain support for these input files, particularly over a wider range of compilers, this patch provides an alternative method for reading these files. Interface --------- As with `MOM_read_data`, the function is provided with a netCDF filepath and a variable name, and returns the values to a provided variable. The `global_file` and `file_may_be_4d` flags have been dropped, since they are related to specific FMS2 compatibility issues. (Global vs domain-decomposed reads is controlled by the presence of a `MOM_domain`) Limited domain-decomposed I/O is supported, providing parallel I/O over a single file, to the extent supported by the filesystem. Parallelization over multiple files, as in FMS I/O, is not supported. Each FMS PE (MPI rank) reads its own segment, as defined by its MOM_domain. Output can be saved to either compute or data domains; as in FMS, the appropriate placement is inferred from the size of the output array. Support is currently limited to time-independent 2D arrays with center-cell indexing. That is, the `position` and `timelevel` arguments are not yet supported. The subroutines raise an error if these are provided, as an indication that they may support them in the future. Implementation -------------- Internally, the function opens a `MOM_netcdf_file`, generates its field/axis manifest, and reads the field contents. As with `MOM_read_data`, an internal rotation may be applied. The file is closed upon completion. (This behavior is designed to emulate the existing `MOM_read_data`; in a future implementation, we may want to use a persistent file handle which reduces the number of I/O operations.) Opening a `MOM_netcdf_file` now supports a `MOM_domain` argument, which is used to determine the index bounds of its local segment of the global domain. This is used to compute appropriate bounds for the native netCDF IO calls. As part of these changes, the `get_file_fields` function has been separated into itself and a new function, `update_file_contents`, which populates the internal axis and field metadata list. Usage ----- The following fields have been moved to the native netCDF IO: * `tideamp` (tidal mixing, FMS surface forcing) * `gustiness` (solo and FMS surface forcing) * `h2` (roughness in tidal mixing) This only comprises the fields which must be handled natively in order for the GFDL regression suite to pass with the PGI compiler; more files could be moved to native I/O in the future. Bugfixes -------- Some bugfixes to the netCDF I/O are also included: * `filename` attribute is now only written in an writeable state * Previously, `get_file_fields` (and now `update_file_contents`) assumed that every axis had an equivalent variable, which could lead to potential errors if an axis had no equvalent field, such as index bounds. We now count the number of variables with matching dimension names, tagged as axes, rather than assuming that every axis has a variable, and exclude them from the field list. * Not a bugfix, but `hor_index_init` was modified so that `param_file` is now an optional input. This function is used in `MOM_netcdf_file`, where `param_file` is not available. The argument is only used to call `log_param`. Previous usage of these functions was restricted to writing output with well-defined content, so were unaffected by these issues. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 12 +- .../solo_driver/MOM_surface_forcing.F90 | 7 +- src/framework/MOM_hor_index.F90 | 7 +- src/framework/MOM_io.F90 | 63 +++++++ src/framework/MOM_io_file.F90 | 155 ++++++++++++++++-- src/framework/MOM_netcdf.F90 | 60 +++++-- .../vertical/MOM_tidal_mixing.F90 | 11 +- 7 files changed, 279 insertions(+), 36 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 9a00f487e4..f732cb9a56 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -28,6 +28,7 @@ module MOM_surface_forcing_gfdl use MOM_interpolate, only : init_external_field, time_interp_external use MOM_interpolate, only : time_interp_external_init 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 use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state @@ -1507,7 +1508,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) if (CS%read_TIDEAMP) then TideAmp_file = trim(CS%inputdir) // trim(TideAmp_file) - call MOM_read_data(TideAmp_file,'tideamp',CS%TKE_tidal,G%domain,timelevel=1, scale=US%m_to_Z*US%T_to_s) + ! 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(TideAmp_file, 'tideamp', CS%TKE_tidal, G%Domain, & + rescale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) @@ -1537,8 +1541,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call safe_alloc_ptr(CS%gust,isd,ied,jsd,jed) gust_file = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & - scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa + ! 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 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/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 04612b4138..74ed5c3023 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -30,6 +30,7 @@ module MOM_surface_forcing use MOM_grid, only : ocean_grid_type use MOM_get_input, only : Get_MOM_Input, directories use MOM_io, only : file_exists, MOM_read_data, MOM_read_vector, slasher +use MOM_io, only : read_netCDF_data use MOM_io, only : EAST_FACE, NORTH_FACE, num_timelevels use MOM_restart, only : register_restart_field, restart_init, MOM_restart_CS use MOM_restart, only : restart_init_end, save_restart, restore_state @@ -1866,8 +1867,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "variable gustiness.", fail_if_missing=.true.) call safe_alloc_ptr(CS%gust,G%isd,G%ied,G%jsd,G%jed) filename = trim(CS%inputdir) // trim(gust_file) - call MOM_read_data(filename,'gustiness',CS%gust,G%domain, timelevel=1, & - scale=Pa_to_RLZ_T2) ! units in file should be Pa + ! 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 endif ! All parameter settings are now known. diff --git a/src/framework/MOM_hor_index.F90 b/src/framework/MOM_hor_index.F90 index 4e8cb2c43b..2ce2808692 100644 --- a/src/framework/MOM_hor_index.F90 +++ b/src/framework/MOM_hor_index.F90 @@ -63,7 +63,7 @@ module MOM_hor_index subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) type(MOM_domain_type), intent(in) :: Domain !< The MOM domain from which to extract information. type(hor_index_type), intent(inout) :: HI !< A horizontal index type to populate with data - type(param_file_type), intent(in) :: param_file !< Parameter file handle + type(param_file_type), optional, intent(in) :: param_file !< Parameter file handle logical, optional, intent(in) :: local_indexing !< If true, all tracer data domains start at 1 integer, optional, intent(in) :: index_offset !< A fixed additional offset to all indices @@ -80,8 +80,9 @@ subroutine hor_index_init(Domain, HI, param_file, local_indexing, index_offset) call get_global_shape(Domain, HI%niglobal, HI%njglobal) ! Read all relevant parameters and write them to the model log. - call log_version(param_file, "MOM_hor_index", version, & - "Sets the horizontal array index types.", all_default=.true.) + if (present(param_file)) & + call log_version(param_file, "MOM_hor_index", version, & + "Sets the horizontal array index types.", all_default=.true.) HI%IscB = HI%isc ; HI%JscB = HI%jsc HI%IsdB = HI%isd ; HI%JsdB = HI%jsd diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 1dc6916c2c..3cc791dcda 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -61,6 +61,7 @@ module MOM_io public :: fieldtype, field_size, get_field_atts public :: axistype, get_axis_data public :: MOM_read_data, MOM_read_vector, read_field_chksum +public :: read_netCDF_data public :: slasher, write_version_number public :: io_infra_init, io_infra_end public :: stdout_if_root @@ -108,6 +109,15 @@ module MOM_io module procedure MOM_read_vector_3d end interface MOM_read_vector +!> Read a field using native netCDF I/O +!! +!! This function is primarily used for unstructured data which may contain +!! content that cannot be parsed by infrastructure I/O. +interface read_netCDF_data + ! NOTE: Only 2D I/O is currently used; this should be expanded as needed. + module procedure read_netCDF_data_2d +end interface read_netCDF_data + !> Write a registered field to an output file, potentially with rotation interface MOM_write_field module procedure MOM_write_field_legacy_4d @@ -2033,6 +2043,59 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & end subroutine MOM_read_data_2d +!> Read a 2d array from file using native netCDF I/O. +subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & + timelevel, position, rescale) + character(len=*), intent(in) :: filename + !< Input filename + character(len=*), intent(in) :: fieldname + !< Field variable name + real, intent(out) :: values(:,:) + !< Field value + type(MOM_domain_type), intent(in) :: MOM_Domain + !< Model domain decomposition + integer, optional, intent(in) :: timelevel + !< Time level to read in file + integer, optional, intent(in) :: position + !< Grid positioning flag + real, optional, intent(in) :: rescale + !< Rescale factor + + integer :: turns + ! Number of quarter-turns from input to model grid + real, allocatable :: values_in(:,:) + ! Field array on the unrotated input grid + type(MOM_netcdf_file) :: handle + ! netCDF file handle + + ! General-purpose IO will require the following arguments, but they are not + ! yet implemented, so we raise an error if they are present. + + ! Fields are currently assumed on cell centers, and position is unsupported + if (present(position)) & + call MOM_error(FATAL, 'read_netCDF_data: position is not yet supported.') + + ! Timelevels are not yet supported + if (present(timelevel)) & + call MOM_error(FATAL, 'read_netCDF_data: timelevel is not yet supported.') + + call handle%open(filename, action=READONLY_FILE, MOM_domain=MOM_domain) + call handle%update() + + turns = MOM_domain%turns + if (turns == 0) then + call handle%read(fieldname, values, rescale=rescale) + else + call allocate_rotated_array(values, [1,1], -turns, values_in) + call handle%read(fieldname, values_in, rescale=rescale) + call rotate_array(values_in, turns, values) + deallocate(values_in) + endif + + call handle%close() +end subroutine read_netCDF_data_2d + + !> Read a 2d region array from file using infrastructure I/O. subroutine MOM_read_data_2d_region(filename, fieldname, data, start, nread, MOM_domain, & no_domain, scale, turns) diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index 68c0f33f07..0e60158093 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -15,6 +15,9 @@ module MOM_io_file use MOM_io_infra, only : get_field_atts use MOM_io_infra, only : read_field_chksum +use MOM_hor_index, only : hor_index_type +use MOM_hor_index, only : hor_index_init + use MOM_netcdf, only : netcdf_file_type use MOM_netcdf, only : netcdf_axis use MOM_netcdf, only : netcdf_field @@ -28,6 +31,7 @@ module MOM_io_file use MOM_netcdf, only : write_netcdf_attribute use MOM_netcdf, only : get_netcdf_size use MOM_netcdf, only : get_netcdf_fields +use MOM_netcdf, only : read_netcdf_field use MOM_error_handler, only : MOM_error, FATAL use MOM_error_handler, only : is_root_PE @@ -43,9 +47,9 @@ module MOM_io_file ! Internal types -! NOTE: MOM_axis and MOM_field do not represent the actual axes and -! fields stored in the file. They are only very thin wrappers to the keys (as -! strings) used to reference the associated object inside the MOM_file. +! NOTE: MOM_axis and MOM_field do not contain the actual axes and fields stored +! in the file. They are very thin wrappers to the keys (as strings) used to +! reference the associated object inside of the MOM_file. !> Handle for axis in MOM file type :: MOM_axis @@ -316,6 +320,10 @@ module MOM_io_file type(field_list_nc) :: fields !> True if the file has been opened logical :: is_open = .false. + !> True if I/O content is domain-decomposed + logical :: domain_decomposed = .false. + !> True if I/O content is domain-decomposed + type(hor_index_type) :: HI contains @@ -356,6 +364,12 @@ module MOM_io_file procedure :: get_field_atts => get_field_atts_nc !> Get checksum from a netCDF field procedure :: read_field_chksum => read_field_chksum_nc + + ! NOTE: These are currently exclusive to netCDF I/O but could be generalized + !> Read the values of a netCDF field + procedure :: read => get_field_nc + !> Update the axes and fields descriptors of a MOM netCDF file + procedure :: update => update_file_contents_nc end type MOM_netcdf_file @@ -1281,11 +1295,16 @@ subroutine open_file_nc(handle, filename, action, MOM_domain, threading, fileset integer, intent(in), optional :: threading integer, intent(in), optional :: fileset - if (.not. is_root_PE()) return + if (.not. present(MOM_domain) .and. .not. is_root_PE()) return call open_netcdf_file(handle%handle_nc, filename, action) - handle%is_open = .true. + + if (present(MOM_domain)) then + handle%domain_decomposed = .true. + call hor_index_init(MOM_domain, handle%HI) + endif + call handle%axes%init() call handle%fields%init() end subroutine open_file_nc @@ -1295,7 +1314,7 @@ end subroutine open_file_nc subroutine close_file_nc(handle) class(MOM_netcdf_file), intent(inout) :: handle - if (.not. is_root_PE()) return + if (.not. handle%domain_decomposed .and. .not. is_root_PE()) return handle%is_open = .false. call close_netcdf_file(handle%handle_nc) @@ -1575,31 +1594,56 @@ subroutine get_file_info_nc(handle, ndim, nvar, ntime) end subroutine get_file_info_nc -!> Return the field metadata associated with a MOM netCDF file -subroutine get_file_fields_nc(handle, fields) +!> Update the axes and fields descriptors of a MOM netCDF file +subroutine update_file_contents_nc(handle) class(MOM_netcdf_file), intent(inout) :: handle !< Handle for a file that is open for I/O - type(MOM_field), intent(inout) :: fields(:) - !< Field-type descriptions of all of the variables in a file. type(netcdf_axis), allocatable :: axes_nc(:) + ! netCDF axis descriptors type(netcdf_field), allocatable :: fields_nc(:) + ! netCDF field descriptors integer :: i + ! Index counter - if (.not. is_root_PE()) return + if (.not. handle%domain_decomposed .and. .not. is_root_PE()) return call get_netcdf_fields(handle%handle_nc, axes_nc, fields_nc) - if (size(fields) /= size(fields_nc)) & - call MOM_error(FATAL, 'Number of fields in file does not match field(:).') do i = 1, size(axes_nc) call handle%axes%append(axes_nc(i), axes_nc(i)%label) enddo - do i = 1, size(fields) - fields(i)%label = trim(fields_nc(i)%label) + do i = 1, size(fields_nc) call handle%fields%append(fields_nc(i), fields_nc(i)%label) enddo +end subroutine update_file_contents_nc + + +!> Return the field descriptors of a MOM netCDF file +subroutine get_file_fields_nc(handle, fields) + class(MOM_netcdf_file), intent(inout) :: handle + !< Handle for a file that is open for I/O + type(MOM_field), intent(inout) :: fields(:) + !< Field-type descriptions of all of the variables in a file. + + type(field_node_nc), pointer :: node => null() + ! Current field list node + integer :: n + ! Field counter + + if (.not. is_root_PE()) return + + ! Generate the manifest of axes and fields + call handle%update() + + n = 0 + node => handle%fields%head + do while (associated(node%next)) + n = n + 1 + fields(n)%label = trim(node%label) + node => node%next + enddo end subroutine get_file_fields_nc @@ -1637,6 +1681,87 @@ subroutine read_field_chksum_nc(handle, field, chksum, valid_chksum) end subroutine read_field_chksum_nc +!> Read the values of a netCDF field +subroutine get_field_nc(handle, label, values, rescale) + class(MOM_netcdf_file), intent(in) :: handle + ! Handle of netCDF file to be read + character(len=*), intent(in) :: label + ! Field variable name + real, intent(out) :: values(:,:) + ! Field values read from file + real, optional, intent(in) :: rescale + + logical :: data_domain + ! True if values matches the data domain size + logical :: compute_domain + ! True if values matches the compute domain size + type(netcdf_field) :: field_nc + ! netCDF field associated with label + integer :: isc, iec, jsc, jec + ! Index bounds of compute domain + integer :: isd, ied, jsd, jed + ! Index bounds of data domain + integer :: bounds(2,2) + ! Index bounds of domain + real, allocatable :: values_nc(:,:) + ! Local copy of field, used for data-decomposed I/O + + isc = handle%HI%isc + iec = handle%HI%iec + jsc = handle%HI%jsc + jec = handle%HI%jec + + isd = handle%HI%isd + ied = handle%HI%ied + jsd = handle%HI%jsd + jed = handle%HI%jed + + data_domain = all(shape(values) == [ied-isd+1, jed-jsd+1]) + compute_domain = all(shape(values) == [iec-isc+1, jec-jsc+1]) + + ! NOTE: Data on face and vertex points is not yet supported. This is a + ! temporary check to detect such cases, but may be removed in the future. + if (.not. (compute_domain .or. data_domain)) & + call MOM_error(FATAL, 'get_field_nc: Only compute and data domains ' // & + 'are currently supported.') + + field_nc = handle%fields%get(label) + + if (data_domain) then + allocate(values_nc(isc:iec,jsc:jec)) + values(:,:) = 0. + endif + + if (handle%domain_decomposed) then + bounds(1,:) = [isc, jsc] + [handle%HI%idg_offset, handle%HI%jdg_offset] + bounds(2,:) = [iec, jec] + [handle%HI%idg_offset, handle%HI%jdg_offset] + if (data_domain) then + call read_netcdf_field(handle%handle_nc, field_nc, values_nc, bounds=bounds) + else + call read_netcdf_field(handle%handle_nc, field_nc, values, bounds=bounds) + endif + else + if (data_domain) then + call read_netcdf_field(handle%handle_nc, field_nc, values_nc) + else + call read_netcdf_field(handle%handle_nc, field_nc, values) + endif + endif + + if (data_domain) & + values(isc:iec,jsc:jec) = values_nc(:,:) + + ! NOTE: It is more efficient to do the rescale in-place while copying + ! values_nc(:,:) to values(:,:). But since rescale is only present for + ! debugging, we can probably disregard this impact on performance. + if (present(rescale)) then + if (rescale /= 1.0) then + values(isc:iec,jsc:jec) = rescale * values(isc:iec,jsc:jec) + endif + endif +end subroutine get_field_nc + + !> \namespace MOM_IO_file !! !! This file defines the MOM_file classes used to inferface with the internal diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 index d09ae5cf95..54aad20c27 100644 --- a/src/framework/MOM_netcdf.F90 +++ b/src/framework/MOM_netcdf.F90 @@ -39,6 +39,7 @@ module MOM_netcdf public :: write_netcdf_attribute public :: get_netcdf_size public :: get_netcdf_fields +public :: read_netcdf_field !> Internal time value used to indicate an uninitialized time @@ -143,7 +144,8 @@ subroutine open_netcdf_file(handle, filename, mode) handle%filename = filename ! FMS writes the filename as an attribute - call write_netcdf_attribute(handle, 'filename', filename) + if (any(io_mode == [WRITEONLY_FILE, OVERWRITE_FILE])) & + call write_netcdf_attribute(handle, 'filename', filename) end subroutine open_netcdf_file @@ -606,13 +608,18 @@ end subroutine get_netcdf_size !> Get the metadata of the registered fields in a netCDF file subroutine get_netcdf_fields(handle, axes, fields) type(netcdf_file_type), intent(inout) :: handle + !< netCDF file handle type(netcdf_axis), intent(inout), allocatable :: axes(:) + !< netCDF file axes type(netcdf_field), intent(inout), allocatable :: fields(:) + !< netCDF file fields integer :: ndims ! Number of netCDF dimensions integer :: nvars ! Number of netCDF dimensions + type(netcdf_field), allocatable :: vars(:) + ! netCDF variables in handle integer :: nfields ! Number of fields in the file (i.e. non-axis variables) integer, allocatable :: dimids(:) @@ -656,13 +663,13 @@ subroutine get_netcdf_fields(handle, axes, fields) allocate(varids(nvars)) rc = nf90_inq_varids(handle%ncid, grp_nvars, varids) call check_netcdf_call(rc, 'get_netcdf_fields', & - 'File "' // handle%filename // '"') + 'File "' // trim(handle%filename) // '"') allocate(axes(ndims)) do i = 1, ndims rc = nf90_inquire_dimension(handle%ncid, dimids(i), name=label, len=len) call check_netcdf_call(rc, 'get_netcdf_fields', & - 'File "' // handle%filename // '"') + 'File "' // trim(handle%filename) // '"') ! Check for the unlimited axis if (dimids(i) == unlim_dimid) unlim_index = i @@ -672,14 +679,15 @@ subroutine get_netcdf_fields(handle, axes, fields) allocate(axes(i)%points(len)) enddo - nfields = nvars - ndims - allocate(fields(nfields)) + ! We cannot know if every axis also has a variable representation, so we + ! over-allocate vars(:) and fill as fields are identified. + allocate(vars(nvars)) - n = 0 + nfields = 0 do i = 1, nvars rc = nf90_inquire_variable(handle%ncid, varids(i), name=label) call check_netcdf_call(rc, 'get_netcdf_fields', & - 'File "' // handle%filename // '"') + 'File "' // trim(handle%filename) // '"') ! Check if variable is an axis is_axis = .false. @@ -687,7 +695,7 @@ subroutine get_netcdf_fields(handle, axes, fields) if (label == axes(j)%label) then rc = nf90_get_var(handle%ncid, varids(i), axes(j)%points) call check_netcdf_call(rc, 'get_netcdf_fields', & - 'File "' // handle%filename // '"') + 'File "' // trim(handle%filename) // '"') axes(j)%varid = varids(i) if (j == unlim_index) then @@ -702,13 +710,43 @@ subroutine get_netcdf_fields(handle, axes, fields) enddo if (is_axis) cycle - n = n + 1 - fields(n)%label = trim(label) - fields(n)%varid = varids(i) + nfields = nfields + 1 + vars(nfields)%label = trim(label) + vars(nfields)%varid = varids(i) enddo + + allocate(fields(nfields)) + fields(:) = vars(:nfields) end subroutine get_netcdf_fields +!> Read the values of a field from a netCDF file +subroutine read_netcdf_field(handle, field, values, bounds) + type(netcdf_file_type), intent(in) :: handle + type(netcdf_field), intent(in) :: field + real, intent(out) :: values(:,:) + integer, optional, intent(in) :: bounds(2,2) + + integer :: rc + ! netCDF return code + integer :: istart(2) + ! Axis start index + integer :: icount(2) + ! Axis index count + + if (present(bounds)) then + istart(:) = bounds(1,:) + icount(:) = bounds(2,:) - bounds(1,:) + 1 + rc = nf90_get_var(handle%ncid, field%varid, values, start=istart, count=icount) + else + rc = nf90_get_var(handle%ncid, field%varid, values) + endif + call check_netcdf_call(rc, 'read_netcdf_field', & + 'File "' // trim(handle%filename) // '", Field "' // trim(field%label) // '"') +end subroutine read_netcdf_field + + +!> Set the current timestep of an open netCDF file subroutine update_netcdf_timestep(handle, time) type(netcdf_file_type), intent(inout) :: handle !< netCDF file handle diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 23b37bd26d..430a9225b5 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -11,6 +11,7 @@ module MOM_tidal_mixing use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, MOM_read_data, field_size +use MOM_io, only : read_netCDF_data use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_string_functions, only : uppercase, lowercase @@ -504,7 +505,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & "The name of the tidal amplitude variable in the input file.", & default="tideamp") - call MOM_read_data(filename, tideamp_var, CS%tideamp, G%domain, scale=US%m_to_Z*US%T_to_s) + ! 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, tideamp_var, CS%tideamp, G%domain, & + rescale=US%m_to_Z*US%T_to_s) endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -516,7 +520,10 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "ROUGHNESS_VARNAME", rough_var, & "The name in the input file of the squared sub-grid-scale "//& "topographic roughness amplitude variable.", default="h2") - call MOM_read_data(filename, rough_var, CS%h2, G%domain, scale=US%m_to_Z**2) + ! 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, rough_var, CS%h2, G%domain, & + rescale=US%m_to_Z**2) call get_param(param_file, mdl, "FRACTIONAL_ROUGHNESS_MAX", max_frac_rough, & "The maximum topographic roughness amplitude as a fraction of the mean depth, "//& From 37b030a1800ced538cf6edacbb5cc15074f94f3e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 16 Feb 2023 07:55:02 -0500 Subject: [PATCH 211/629] Autoconf configuration of Python The introduction of makedep means that Python is now a dependency of the MOM6 compilation. On some systems, we cannot assume that `python` is the name of the interpreter, and strictly should not even assume that it exists. This is notably an issue on the recent MacOS M1 systems, which use `python3` as its interpreter, and do not provide one named `python`. This patch adds macros to the MOM6 and FMS autoconf builds to detect if Python is on the system, and makes a few attempts to determine the name of the interpreter (python, python3, python2). Perhaps more can be done here, but this is probably sufficient in nearly all cases. --- ac/Makefile.in | 3 ++- ac/configure.ac | 7 +++++++ ac/deps/Makefile.fms.in | 3 ++- ac/deps/configure.fms.ac | 9 ++++++++- 4 files changed, 19 insertions(+), 3 deletions(-) diff --git a/ac/Makefile.in b/ac/Makefile.in index 930816bc8c..43262027e6 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -6,6 +6,7 @@ FC = @FC@ LD = @FC@ +PYTHON = @PYTHON@ MAKEDEP = @MAKEDEP@ DEFS = @DEFS@ @@ -32,7 +33,7 @@ rwildcard=$(foreach d,$(wildcard $(1:=/*)),$(call rwildcard,$d,$2) $(filter $(su .PHONY: depend depend: Makefile.dep Makefile.dep: $(MAKEDEP) $(call rwildcard,$(SRC_DIRS),*.h *.c *.inc *.F90) - $(MAKEDEP) -o Makefile.dep -e $(SRC_DIRS) + $(PYTHON) $(MAKEDEP) -o Makefile.dep -e $(SRC_DIRS) # Delete any files associated with configuration (including the Makefile). diff --git a/ac/configure.ac b/ac/configure.ac index 049325a891..dead0579a6 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -221,6 +221,13 @@ AC_COMPILE_IFELSE( ) +# 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]) + + # Verify that makedep is available AC_PATH_PROG([MAKEDEP], [makedep], [${srcdir}/ac/makedep]) AC_SUBST([MAKEDEP]) diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in index e2581cf817..caf4abb9c7 100644 --- a/ac/deps/Makefile.fms.in +++ b/ac/deps/Makefile.fms.in @@ -8,6 +8,7 @@ CC = @CC@ FC = @FC@ LD = @FC@ AR = @AR@ +PYTHON = @PYTHON@ MAKEDEP = @MAKEDEP@ DEFS = @DEFS@ @@ -22,4 +23,4 @@ ARFLAGS = @ARFLAGS@ .PHONY: depend depend: Makefile.dep Makefile.dep: - $(MAKEDEP) -o Makefile.dep -e -x libFMS.a @srcdir@ + $(PYTHON) $(MAKEDEP) -o Makefile.dep -e -x libFMS.a @srcdir@ diff --git a/ac/deps/configure.fms.ac b/ac/deps/configure.fms.ac index 4e0c0f1390..a52533970b 100644 --- a/ac/deps/configure.fms.ac +++ b/ac/deps/configure.fms.ac @@ -158,7 +158,14 @@ AX_FC_ALLOW_ARG_MISMATCH FCFLAGS="$FCFLAGS $ALLOW_ARG_MISMATCH_FCFLAGS" -# Verify makedep +# 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]) + + +# Verify that makedep is available AC_PATH_PROGS([MAKEDEP], [makedep], [], ["${PATH}:${srcdir}/../../.."]) AS_IF([test -n "${MAKEDEP}"], [ AC_SUBST([MAKEDEP]) From 5f628582069cb6feee3b068dacbd5d2d0405a000 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 23 Feb 2023 10:16:16 -0500 Subject: [PATCH 212/629] reopen_MOM_file explicitly runs on root PE reopen_MOM_file includes an inquire test to determine whether we are attempting to reopen an existing file. If missing, it will attempt to create the missing file. The switch from FMS to netCDF I/O exposed a race condition here, where one rank may create the file, and another delayed rank may incorrectly identify this new file as already existing. This resulted in a segmentation fault. Unsure why this was not detected before; it could be that FMS was more resilient to the possibility of missing files. Regardless, the `exists` value was volatile and could lead to potential error. This patch introduces a temporary fix to the issue by checking the root PE and threading value. When threading is single-file, only the root PE participates in the existence test and file creation. This accounts for the case where either the root PE or any larger subset containing the root PE calls the function. It does not account for the more exotic case where a non-root PE many wish to create a file. If threading is set to MULTIPLE (i.e. IO domains) then an error is raised, since there's currently no safe way to implement an equivalent `inquire()` test. We can revisit this function when stronger controls around threaded IO are introduced. But for now, I believe that this is the best that we can do. --- src/framework/MOM_io.F90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 3cc791dcda..3e90ecd9b1 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -668,6 +668,20 @@ subroutine reopen_MOM_file(IO_handle, filename, vars, novars, fields, & thread = SINGLE_FILE if (PRESENT(threading)) thread = threading + ! For single-file IO, only the root PE is required to set up the fields. + ! This permits calls by either the root PE or all PEs + if (.not. is_root_PE() .and. thread == SINGLE_FILE) return + + ! For multiple IO domains, we would need additional functionality: + ! * Identify ranks as IO PEs + ! * Determine the filename of + ! Neither of these tasks should be handed by MOM6, so we cannot safely use + ! this function. A framework-specific `inquire()` function is needed. + ! Until it exists, we will disable this function. + if (thread == MULTIPLE) & + call MOM_error(FATAL, 'reopen_MOM_file does not yet support files with ' & + // 'multiple I/O domains.') + check_name = filename length = len(trim(check_name)) if (check_name(length-2:length) /= ".nc") check_name = trim(check_name)//".nc" From 6dc4de68611b9b3c4881b0c1f9ecd9ba5f254af1 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 28 Feb 2023 13:05:29 -0500 Subject: [PATCH 213/629] GitLab: Extend run test timeouts Erratic slowdowns in our Lustre filesystem mean that test runtimes are largely unpredictable. This patch increases the runtimes from 20min to 1hr, to better cope with this issue. --- .gitlab-ci.yml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0462e3aa7a..653734097b 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -134,7 +134,7 @@ run:pgi: tags: - ncrc4 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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=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 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-pgi-SNL || ( echo Batch job did not complete ; exit 911 ) run:intel: @@ -143,7 +143,7 @@ run:intel: tags: - ncrc4 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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=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 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-intel-SNL || ( echo Batch job did not complete ; exit 911 ) run:gnu: @@ -152,7 +152,7 @@ run:gnu: tags: - ncrc4 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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=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 ) - test -f $JOB_DIR/CI-BATCH-SUCCESS-gnu-SNLDT || ( echo Batch job did not complete ; exit 911 ) run:gnu-restarts: @@ -161,7 +161,7 @@ run:gnu-restarts: tags: - ncrc4 script: - - sbatch --clusters=c3,c4 --nodes=30 --time=0:20: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=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 ) - 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) From 00854d054b229c0740c4c7606cc46a63cb5c012a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 17 Feb 2023 14:18:12 -0500 Subject: [PATCH 214/629] +Correct units in 1 get_param call and 64 comments Corrected the units in the get_param call for WAVE_HEIGHT_SCALE_FACTOR, and corrected the units descriptions in comments of 22 wind stress related variables in 6 driver routines, from [R L Z T-1 ~> Pa] to [R L Z T-2 ~> Pa], but the actual conversion factors in the code are correct. Also fixed 42 other inconsistent units in comments in 28 files scattered throughout the MOM6 code. WAVE_HEIGHT_SCALE_FACTOR was added in December 2022 as a part of PR #289 to dev/gfdl. These inconsistent units were detected because they do not match the patterns of other valid units; most are recent additions. Apart from a single unit in a get_param call, only comments are changed, and all answers are bitwise identical. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 4 +-- .../mct_cap/mom_surface_forcing_mct.F90 | 4 +-- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 4 +-- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 26 +++++++++---------- .../solo_driver/user_surface_forcing.F90 | 6 ++--- .../drivers/unit_drivers/MOM_sum_driver.F90 | 2 +- src/ALE/MOM_hybgen_remap.F90 | 4 +-- src/core/MOM.F90 | 2 +- src/core/MOM_continuity_PPM.F90 | 2 +- src/core/MOM_forcing_type.F90 | 8 +++--- src/core/MOM_porous_barriers.F90 | 2 +- src/core/MOM_variables.F90 | 2 +- src/equation_of_state/MOM_EOS.F90 | 4 +-- src/equation_of_state/MOM_EOS_linear.F90 | 2 +- src/framework/MOM_unit_scaling.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 26 +++++++++---------- .../MOM_state_initialization.F90 | 2 +- .../lateral/MOM_mixed_layer_restrat.F90 | 2 +- .../lateral/MOM_thickness_diffuse.F90 | 2 +- .../vertical/MOM_bulk_mixed_layer.F90 | 4 +-- .../vertical/MOM_kappa_shear.F90 | 2 +- .../vertical/MOM_opacity.F90 | 2 +- .../vertical/MOM_set_diffusivity.F90 | 2 +- .../vertical/MOM_set_viscosity.F90 | 2 +- src/tracer/MOM_offline_aux.F90 | 4 +-- src/tracer/MOM_tracer_Z_init.F90 | 2 +- src/tracer/dye_example.F90 | 2 +- src/tracer/oil_tracer.F90 | 2 +- src/user/MOM_controlled_forcing.F90 | 4 +-- src/user/MOM_wave_interface.F90 | 4 +-- src/user/Rossby_front_2d_initialization.F90 | 2 +- src/user/tidal_bay_initialization.F90 | 2 +- 33 files changed, 70 insertions(+), 72 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 f732cb9a56..88d2cb3f42 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -83,14 +83,14 @@ module MOM_surface_forcing_gfdl !! type without any further adjustments to drive the ocean dynamics. !! The actual net mass source may differ due to corrections. - real :: gust_const !< Constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + real :: gust_const !< Constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL() !< Turbulent kinetic energy introduced to the bottom boundary layer !! by drag on the tidal flows [R Z3 T-3 ~> W m-2]. real, pointer, dimension(:,:) :: & gust => NULL() !< A spatially varying unresolved background gustiness that - !! contributes to ustar [R L Z T-1 ~> Pa]. gust is used when read_gust_2d is true. + !! contributes to ustar [R L Z T-2 ~> Pa]. gust is used when read_gust_2d is true. real, pointer, dimension(:,:) :: & ustar_tidal => NULL() !< Tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< Drag coefficient that applies to the tides [nondim] 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 b34f1a3b35..0364d46ddc 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -76,14 +76,14 @@ module MOM_surface_forcing_mct !! the correction for the atmospheric (and sea-ice) !! pressure limited by max_p_surf instead of the !! full atmospheric pressure. The default is true. - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. + !! gustiness that contributes to ustar [R L Z T-2 ~> Pa]. !! gust is used when read_gust_2d is true. ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) 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 e2710bd18c..921d43d9b8 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -81,14 +81,14 @@ module MOM_surface_forcing_nuopc logical :: use_CFC !< enables the MOM_CFC_cap tracer package. logical :: enthalpy_cpl !< Controls if enthalpy terms are provided by the coupler or computed !! internally. - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> Pa] + real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-2 ~> Pa] logical :: read_gust_2d !< If true, use a 2-dimensional gustiness supplied !! from an input file. real, pointer, dimension(:,:) :: & TKE_tidal => NULL(), & !< turbulent kinetic energy introduced to the !! bottom boundary layer by drag on the tidal flows [R Z3 T-3 ~> W m-2] gust => NULL(), & !< spatially varying unresolved background - !! gustiness that contributes to ustar [R L Z T-1 ~> Pa]. + !! gustiness that contributes to ustar [R L Z T-2 ~> Pa]. !! gust is used when read_gust_2d is true. ustar_tidal => NULL() !< tidal contribution to the bottom friction velocity [Z T-1 ~> m s-1] real :: cd_tides !< drag coefficient that applies to the tides (nondimensional) diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index 18c3c33fdb..12f1b6b78d 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -31,7 +31,7 @@ module MESO_surface_forcing real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [R L Z T-1 ~> Pa] + !! that contributes to ustar [R L Z T-2 ~> Pa] real, dimension(:,:), pointer :: & T_Restore(:,:) => NULL(), & !< The temperature to restore the SST toward [C ~> degC]. S_Restore(:,:) => NULL(), & !< The salinity to restore the sea surface salnity toward [S ~> ppt] diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 74ed5c3023..092bc9e513 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -85,13 +85,13 @@ module MOM_surface_forcing real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" - !! forcing [R L Z T-1 ~> Pa] + !! 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-1 ~> Pa] + !! forcing [R L Z T-2 ~> Pa] - real :: gust_const !< constant unresolved background gustiness for ustar [R L Z T-1 ~> 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 - real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-1 ~> Pa] + real, pointer :: gust(:,:) => NULL() !< spatially varying unresolved background gustiness [R L Z T-2 ~> Pa] !! gust is used when read_gust_2d is true. real, pointer :: T_Restore(:,:) => NULL() !< temperature to damp (restore) the SST to [C ~> degC] @@ -102,9 +102,9 @@ module MOM_surface_forcing ! if WIND_CONFIG=='gyres' then use the following as = A, B, C and n respectively for ! taux = A + B*sin(n*pi*y/L) + C*cos(n*pi*y/L) - real :: gyres_taux_const !< A constant wind stress [R L Z T-1 ~> Pa]. - real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [R L Z T-1 ~> Pa], if WIND_CONFIG=='gyres' - real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [R L Z T-1 ~> Pa], if WIND_CONFIG=='gyres' + real :: gyres_taux_const !< A constant wind stress [R L Z T-2 ~> Pa]. + real :: gyres_taux_sin_amp !< The amplitude of cosine wind stress gyres [R L Z T-2 ~> Pa], if WIND_CONFIG=='gyres' + real :: gyres_taux_cos_amp !< The amplitude of cosine wind stress gyres [R L Z T-2 ~> Pa], if WIND_CONFIG=='gyres' real :: gyres_taux_n_pis !< The number of sine lobes in the basin if WIND_CONFIG=='gyres' [nondim] integer :: answer_date !< This 8-digit integer gives the approximate date with which the order !! of arithmetic and expressions were added to the code. @@ -115,7 +115,7 @@ module MOM_surface_forcing !! gustless wind friction velocity. ! if WIND_CONFIG=='scurves' then use the following to define a piecewise scurve profile real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] - real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-1 ~> Pa] + real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-2 ~> Pa] real :: T_north !< Target temperatures at north used in buoyancy_forcing_linear [C ~> degC] real :: T_south !< Target temperatures at south used in buoyancy_forcing_linear [C ~> degC] @@ -392,7 +392,7 @@ subroutine wind_forcing_const(sfc_state, forces, tau_x0, tau_y0, day, G, US, CS) mag_tau = sqrt( tau_x0**2 + tau_y0**2) - ! Set the steady surface wind stresses, in units of [R L Z T-1 ~> Pa]. + ! 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) = tau_x0 enddo ; enddo @@ -438,7 +438,7 @@ subroutine wind_forcing_2gyre(sfc_state, forces, day, G, US, CS) 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-1 ~> Pa]. + ! 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)) @@ -513,7 +513,7 @@ subroutine wind_forcing_gyres(sfc_state, forces, day, G, US, CS) PI = 4.0*atan(1.0) - ! steady surface wind stresses [R L Z T-1 ~> Pa] + ! steady surface wind stresses [R L Z T-2 ~> Pa] do j=js-1,je+1 ; do I=is-1,Ieq y = (G%geoLatCu(I,j)-CS%South_lat) / CS%len_lat forces%taux(I,j) = CS%gyres_taux_const + & @@ -670,8 +670,8 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) !! a previous surface_forcing_init call ! Local variables 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-1 ~> Pa] - real :: temp_y(SZI_(G),SZJ_(G)) ! Pseudo-meridional wind stresses at h-points [R L Z T-1 ~> Pa] + 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 diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index ae3f854335..fc803c27e6 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -33,10 +33,10 @@ module user_surface_forcing logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. - real :: G_Earth !< The gravitational acceleration [L2 Z-1 s-2 ~> m s-2]. + real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. real :: gust_const !< A constant unresolved background gustiness - !! that contributes to ustar [R L Z T-1 ~> Pa]. + !! that contributes to ustar [R L Z T-2 ~> Pa]. type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -71,7 +71,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) ! Allocate the forcing arrays, if necessary. call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) - ! Set the surface wind stresses, in units of [R L Z T-1 ~> Pa]. A positive taux + ! Set the surface wind stresses, in units of [R L Z T-2 ~> Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. ! The i-loop extends to is-1 so that taux can be used later in the diff --git a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 index 0a6191b286..7a1ba82843 100644 --- a/config_src/drivers/unit_drivers/MOM_sum_driver.F90 +++ b/config_src/drivers/unit_drivers/MOM_sum_driver.F90 @@ -183,7 +183,7 @@ subroutine benchmark_init_topog_local(D, G, param_file, max_depth) real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: D0 ! A constant to make the maximum ! basin depth MAXIMUM_DEPTH [m] - real :: m_to_Z ! A dimensional rescaling factor [m ~> Z] + real :: m_to_Z ! A dimensional rescaling factor [Z m-1 ~> 1] real :: x ! A fractional position in the x-direction [nondim] real :: y ! A fractional position in the y-direction [nondim] ! This include declares and sets the variable "version". diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 index 213c6c677e..5ab3e162db 100644 --- a/src/ALE/MOM_hybgen_remap.F90 +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -263,7 +263,7 @@ subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) ! real, parameter :: dsmll=1.0e-8 ! This has units of [A2], and hence can not be a parameter. ! real :: curv_cell ! An estimate of the tracer curvature centered on a cell times the grid - ! spacing [A H-1 ~> A m-1 or A kg m-2] + ! spacing [A H-1 ~> A m-1 or A m2 kg-1] real :: seh1, seh2 ! Tracer slopes at the cell edges times the cell grid spacing [A] real :: q01, q02 ! Various tracer differences between a cell average and the edge values [A] real :: q001, q002 ! Tracer slopes at the cell edges times the cell grid spacing [A] @@ -277,7 +277,7 @@ subroutine hybgen_weno_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) ! concentrations and the left and right edges [A2] real :: min_ratio ! The minimum ratio of the values of zw used to interpolate the edge values [nondim] real :: wt1 ! The weight of the upper layer in the interpolated shared edge value [nondim] - real :: slope_edge(nk+1) ! Tracer slopes at the edges [A H-1 ~> A m-1 or A kg m-2] + real :: slope_edge(nk+1) ! Tracer slopes at the edges [A H-1 ~> A m-1 or A m2 kg-1] real :: val_edge(nk+1) ! A weighted average edge concentration [A] integer :: i, k diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 00e748bdc1..84eb5fc90a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1976,7 +1976,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & real :: salin_underflow ! A tiny value of salinity below which the it is set to 0 [S ~> ppt] real :: temp_underflow ! A tiny magnitude of temperatures below which they are set to 0 [C ~> degC] real :: conv2watt ! A conversion factor from temperature fluxes to heat - ! fluxes [J m-2 H-1 degC-1 ~> J m-3 degC-1 or J kg-1 degC-1] + ! 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 diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 54eecd20c3..090d1ee0fb 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -1044,7 +1044,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vh !< Volume flux through meridional - !! faces = v*h*dx [H L2 s-1 ~> m3 s-1 or kg s-1] + !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index f005ac1a0e..9a5e1f48f5 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -969,7 +969,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: netHeat ! net temp flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R C-1 ~> kg m-3 degC-1] real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R S-1 ~> kg m-3 ppt-1] @@ -996,7 +996,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: ! netH = water added/removed via surface fluxes [H T-1 ~> m s-1 or kg m-2 s-1] - ! netHeat = heat via surface fluxes [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! netHeat = heat via surface fluxes [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] ! netSalt = salt via surface fluxes [S H T-1 ~> ppt m s-1 or gSalt m-2 s-1] ! Note that unlike other calls to extractFLuxes1d() that return the time-integrated flux ! this call returns the rate because dt=1 (in arbitrary time units) @@ -1015,12 +1015,12 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt tv%eqn_of_state, EOS_domain(G%HI)) ! Adjust netSalt to reflect dilution effect of FW flux - ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] + ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) ! Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. - ! [degC H T-1 ~> degC m s-1 or degC kg m-2 s-1] + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] !netHeat(:) = netHeatMinusSW(:) + sum( penSWbnd, dim=1 ) netHeat(G%isc:G%iec) = netHeatMinusSW(G%isc:G%iec) + netPen(G%isc:G%iec,1) diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index 4e812b65d7..ebe3907469 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -285,7 +285,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(out) :: eta_v !< Layer interface heights at v points [Z ~> m] ! local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m or 1/eta_to_m]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m]. real :: h_neglect ! Negligible thicknesses [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 35cdf3038a..6aa94f584f 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -101,7 +101,7 @@ module MOM_variables real, dimension(:,:), pointer :: salt_deficit => NULL() !< The salt needed to maintain the ocean column !! at a minimum salinity of MIN_SALINITY since the last time - !! that calculate_surface_state was called, [ppt R Z ~> gSalt m-2]. + !! that calculate_surface_state was called, [S R Z ~> gSalt m-2]. real, dimension(:,:), pointer :: TempxPmE => NULL() !< The net inflow of water into the ocean times the !! temperature at which this inflow occurs since the diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 12b87ebc64..4ddedf85a8 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -632,11 +632,11 @@ end subroutine calc_spec_vol_1d !> Calls the appropriate subroutine to calculate the freezing point for scalar inputs. subroutine calculate_TFreeze_scalar(S, pressure, T_fr, EOS, pres_scale, scale_from_EOS) - real, intent(in) :: S !< Salinity, [ppt] or [Z ~> ppt] depending on scale_from_EOS + real, intent(in) :: S !< Salinity, [ppt] or [S ~> ppt] depending on scale_from_EOS real, intent(in) :: pressure !< Pressure, in [Pa] or [R L2 T-2 ~> Pa] depending on !! pres_scale or scale_from_EOS real, intent(out) :: T_fr !< Freezing point potential temperature referenced to the - !! surface [degC] or [degC ~> C] depending on scale_from_EOS + !! surface [degC] or [C ~> degC] depending on scale_from_EOS type(EOS_type), intent(in) :: EOS !< Equation of state structure real, optional, intent(in) :: pres_scale !< A multiplicative factor to convert pressure !! into Pa [Pa T2 R-1 L-2 ~> 1]. diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index 07464861cb..dd45e6cd81 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -331,7 +331,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & 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]. + 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), & diff --git a/src/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index caf73ae8e1..bfc2189188 100644 --- a/src/framework/MOM_unit_scaling.F90 +++ b/src/framework/MOM_unit_scaling.F90 @@ -41,7 +41,7 @@ module MOM_unit_scaling real :: L_T_to_m_s !< Convert lateral velocities from L T-1 to m s-1 [T m L-1 s-1 ~> 1] real :: m_s_to_L_T !< Convert lateral velocities from m s-1 to L T-1 [L s T-1 m-1 ~> 1] real :: L_T2_to_m_s2 !< Convert lateral accelerations from L T-2 to m s-2 [L s2 T-2 m-1 ~> 1] - real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1 [T1 m2 Z-2 s-1 ~> 1] + real :: Z2_T_to_m2_s !< Convert vertical diffusivities from Z2 T-1 to m2 s-1 [T m2 Z-2 s-1 ~> 1] real :: m2_s_to_Z2_T !< Convert vertical diffusivities from m2 s-1 to Z2 T-1 [Z2 s T-1 m-2 ~> 1] real :: W_m2_to_QRZ_T !< Convert heat fluxes from W m-2 to Q R Z T-1 [Q R Z m2 T-1 W-1 ~> 1] real :: QRZ_T_to_W_m2 !< Convert heat fluxes from Q R Z T-1 to W m-2 [W T Q-1 R-1 Z-1 m-2 ~> 1] diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 6691095b08..3049cae00c 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -46,9 +46,9 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: v_shelf => NULL() !< the meridional velocity of the ice shelf/sheet !! on q-points (B grid) [L T-1 ~> m s-1] real, pointer, dimension(:,:) :: taudx_shelf => NULL() !< the driving stress of the ice shelf/sheet - !! on q-points (C grid) [Pa ~> Pa] + !! on q-points (C grid) [R L2 T-2 ~> Pa] real, pointer, dimension(:,:) :: taudy_shelf => NULL() !< the meridional stress of the ice shelf/sheet - !! on q-points (C grid) [Pa ~> Pa] + !! on q-points (C grid) [R L2 T-2 ~> Pa] real, pointer, dimension(:,:) :: u_face_mask => NULL() !< mask for velocity boundary conditions on the C-grid !! u-face - this is because the FEM cares about FACES THAT GET INTEGRATED OVER, !! not vertices. Will represent boundary conditions on computational boundary @@ -147,7 +147,7 @@ module MOM_ice_shelf_dynamics logical :: moving_shelf_front !< Specify whether to advance shelf front (and calve). logical :: calve_to_mask !< If true, calve off the ice shelf when it passes the edge of a mask. real :: min_thickness_simple_calve !< min. ice shelf thickness criteria for calving [Z ~> m]. - real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [degC ~> C] + real :: T_shelf_missing !< An ice shelf temperature to use where there is no ice shelf [C ~> degC] real :: cg_tolerance !< The tolerance in the CG solver, relative to initial residual, that !! determines when to stop the conjugate gradient iterations [nondim]. real :: nonlinear_tolerance !< The fractional nonlinear tolerance, relative to the initial error, @@ -235,7 +235,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control struct ! Local variables - real :: T_shelf_missing ! An ice shelf temperature to use where there is no ice shelf [degC ~> C] + real :: T_shelf_missing ! An ice shelf temperature to use where there is no ice shelf [C ~> degC] logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics character(len=40) :: mdl = "MOM_ice_shelf_dyn" ! This module's name. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -696,10 +696,10 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled logical, optional, intent(in) :: coupled_grounding !< If true, the grounding line is !! determined by coupled ice-ocean dynamics logical, optional, intent(in) :: must_update_vel !< Always update the ice velocities if true. - real, dimension(SZDIB_(G),SZDJB_(G)) ::taud_x,taud_y ! Pa] - real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc ! Pa s-1 m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr ! Pa] + real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity + !! [R L2 Z T-1 ~> Pa s m] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged basal traction [R L2 T-2 ~> Pa] integer :: iters logical :: update_ice_vel, coupled_GL @@ -1806,10 +1806,10 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: OD !< ocean floor depth at tracer points [Z ~> m]. real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taudx !< X-direction driving stress at q-points [kg L s-2 ~> kg m s-2] + intent(inout) :: taudx !< X-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: taudy !< Y-direction driving stress at q-points [kg L s-2 ~> kg m s-2] - ! This will become [R L3 Z T-2 ~> kg m s-2] + intent(inout) :: taudy !< Y-direction driving stress at q-points [R L3 Z T-2 ~> kg m s-2] + ! driving stress! @@ -1827,7 +1827,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. - real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim] real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] @@ -3200,8 +3199,7 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) real, dimension(SZDI_(G),SZDJ_(G)) :: th_after_uflux, th_after_vflux, TH ! Integrated temperatures [C Z ~> degC m] integer :: isd, ied, jsd, jed, i, j, isc, iec, jsc, jec real :: Tsurf ! Surface air temperature [C ~> degC]. This is hard coded but should be an input argument. - real :: adot ! A surface heat exchange coefficient divided by the heat capacity of - ! ice [R Z T-1 degC-1 ~> kg m-2 s-1 degC-1]. + real :: adot ! A surface heat exchange coefficient [R Z T-1 ~> kg m-2 s-1]. ! For now adot and Tsurf are defined here adot=surf acc 0.1m/yr, Tsurf=-20oC, vary them later diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0e50ebb67f..bd0931c694 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1192,7 +1192,7 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: S_t, S_b ! Top and bottom edge values for reconstructions ! of salinity within each layer [S ~> ppt] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: T_t, T_b ! Top and bottom edge values for reconstructions - ! of temperature within each layer [T ~> degC] + ! 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]. diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 94f4468433..ffdf236152 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -813,7 +813,7 @@ real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coe ! Local variables real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] - real :: Kv_eff ! An effective overall viscosity [Z1 T-1 ~> m2 s-1] + real :: Kv_eff ! An effective overall viscosity [Z2 T-1 ~> m2 s-1] real :: pi2 ! A scaling constant that is approximately pi^2 [nondim] ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + Kv_water diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 4e12aeeaad..a7ff2f1c0a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -722,7 +722,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver - ! times unit conversion factors [T-2 L2 Z-2 ~> s-2] + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] real :: Tl(5) ! copy of T in local stencil [C ~> degC] real :: mn_T ! mean of T in local stencil [C ~> degC] real :: mn_T2 ! mean of T**2 in local stencil [C2 ~> degC2] diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 5e530bea3d..66e2dfa6b2 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -912,7 +912,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: T !< Layer temperatures [C ~> degC]. real, dimension(SZI_(G),SZK0_(GV)), & - intent(in) :: S !< Layer salinities [C ~> ppt]. + intent(in) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. @@ -1890,7 +1890,7 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! Local variables real :: h_move ! The thickness of water being moved between layers [H ~> m or kg m-2] real :: h_tgt_old ! The previous thickness of the recipient layer [H ~> m or kg m-2] - real :: I_hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m3 kg-1] + real :: I_hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] real :: dT_dS_wt2 ! The square of the relative weighting of temperature and salinity changes ! when extrapolating to match a target density [C2 S-2 ~> degC2 ppt-2] real :: dT_dR ! The ratio of temperature changes to density changes when diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 4e07b1d8ed..78ec0d9391 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -653,7 +653,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! 1/dz_Int, as they have different uses. S2, & ! The squared shear at an interface [T-2 ~> s-2]. a1, & ! a1 is the coupling between adjacent interfaces in the TKE, - ! velocity, and density equations [Z s-1 ~> m s-1] or [Z ~> m] + ! velocity, and density equations [Z ~> m] c1, & ! c1 is used in the tridiagonal (and similar) solvers [nondim]. k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 43462131ca..77de5d13cd 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -38,7 +38,7 @@ module MOM_opacity !< The maximum wavelength in each band of penetrating shortwave radiation [nm] real :: PenSW_flux_absorb !< A heat flux that is small enough to be completely absorbed in the next - !! sufficiently thick layer [H degC T-1 ~> degC m s-1 or degC kg m-2 s-1]. + !! sufficiently thick layer [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. real :: PenSW_absorb_Invlen !< The inverse of the thickness that is used to absorb the remaining !! shortwave heat flux when it drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2]. integer :: answer_date !< The vintage of the order of arithmetic and expressions in the optics diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index bb159b2199..0dec7a40c0 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -900,7 +900,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real, dimension(SZI_(G)) :: & pres, & ! pressure at each interface [R L2 T-2 ~> Pa] - Temp_int, & ! temperature at each interface [C ~>degC] + Temp_int, & ! temperature at each interface [C ~> degC] Salin_int, & ! salinity at each interface [S ~> ppt] drho_bot, & ! A density difference [R ~> kg m-3] h_amp, & ! The topographic roughness amplitude [Z ~> m]. diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 2a9e7deeba..1e3bf258d8 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -287,7 +287,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: tmp ! A temporary variable, sometimes in [Z ~> m] real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] real :: curv_tol ! Numerator of curvature cubed, used to estimate - ! accuracy of a single L(:) Newton iteration [H5 ~> m3 or kg5 m-10] + ! accuracy of a single L(:) Newton iteration [H5 ~> m5 or kg5 m-10] logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index d42355f245..7619cac2bd 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -777,9 +777,9 @@ subroutine update_offline_from_arrays(G, GV, nk_input, ridx_sum, mean_file, sum_ real, dimension(:,:,:,:), allocatable, intent(inout) :: hend_all !< End of timestep layer thickness !! [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: temp !< Temperature array [C ~> degC] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: salt !< Salinity array [ppt ~> S] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: salt !< Salinity array [S ~> ppt] real, dimension(:,:,:,:), allocatable, intent(inout) :: temp_all !< Temperature array [C ~> degC] - real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array [ppt ~> S] + real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array [S ~> ppt] integer :: i, j, k, is, ie, js, je, nz real, parameter :: fill_value = 0. diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index d887f5f3be..c089181c16 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -279,7 +279,7 @@ subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, n intent(in) :: tr_in !< The z-space array of tracer concentrations !! that is read in [A] real, dimension(nk_data+1), intent(in) :: z_edges !< The depths of the cell edges in the input z* data - !! [Z ~> m or m] + !! [Z ~> m] or [m] integer, intent(in) :: nlay !< The number of vertical layers in the target grid real, dimension(SZI_(G),SZJ_(G),nlay+1), & intent(in) :: e !< The depths of the target layer interfaces [Z ~> m] or [m] diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index 2244993447..fbc2b28a95 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -272,7 +272,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US !! fluxes can be applied [H ~> m or kg m-2] ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] integer :: i, j, k, is, ie, js, je, nz, m diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 36b157547f..20685d9711 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -363,7 +363,7 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*CS%oil_decay_rate(m),0.)*CS%tr(i,j,k,m) ! Safest elseif (CS%oil_decay_rate(m)<0.) then decay_timescale = (12.0 * (3.0**(-(tv%T(i,j,k)-20.0*US%degC_to_C)/10.0*US%degC_to_C))) * & - (86400.0*US%s_to_T) ! Timescale [s ~> T] + (86400.0*US%s_to_T) ! Timescale [T ~> s] ldecay = 1. / decay_timescale ! Rate [T-1 ~> s-1] CS%tr(i,j,k,m) = G%mask2dT(i,j)*max(1. - dt*ldecay,0.)*CS%tr(i,j,k,m) endif diff --git a/src/user/MOM_controlled_forcing.F90 b/src/user/MOM_controlled_forcing.F90 index 5be01bece4..d218b4ea80 100644 --- a/src/user/MOM_controlled_forcing.F90 +++ b/src/user/MOM_controlled_forcing.F90 @@ -270,8 +270,8 @@ subroutine apply_ctrl_forcing(SST_anom, SSS_anom, SSS_mean, virt_heat, virt_prec ! Accumulate the average anomalies for this period. dt_wt = wt_per1 * dt CS%avg_time(m_mid) = CS%avg_time(m_mid) + dt_wt - ! These loops temporarily change the units of the CS%avg_ variables to [degC T ~> degC s] - ! or [ppt T ~> ppt s]. + ! These loops temporarily change the units of the CS%avg_ variables to [C T ~> degC s] + ! or [S T ~> ppt s]. do j=js,je ; do i=is,ie CS%avg_SST_anom(i,j,m_mid) = CS%avg_SST_anom(i,j,m_mid) + & dt_wt * G%mask2dT(i,j) * SST_anom(i,j) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 723c8a0595..a548436329 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -198,7 +198,7 @@ module MOM_wave_interface real :: rho_air !< A typical density of air at sea level, as used in wave calculations [R ~> kg m-3] real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the - !! significant wave height [Z T2 L-2 ~> s m-2] + !! significant wave height [Z T2 L-2 ~> s2 m-1] real :: Charnock_min !< The minimum value of the Charnock coefficient, which relates the square of !! the air friction velocity divided by the gravitational acceleration to the !! wave roughness length [nondim] @@ -598,7 +598,7 @@ subroutine set_LF17_wave_params(param_file, mdl, US, CS) call get_param(param_file, mdl, "WAVE_HEIGHT_SCALE_FACTOR", CS%SWH_from_u10sq, & "A factor relating the square of the 10 m wind speed to the significant "//& "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & - units="s m-2", default=0.0246, scale=US%m_to_Z*US%L_T_to_m_s**2) + units="s2 m-1", default=0.0246, scale=US%m_to_Z*US%L_T_to_m_s**2) call get_param(param_file, mdl, "CHARNOCK_MIN", CS%Charnock_min, & "The minimum value of the Charnock coefficient, which relates the square of "//& "the air friction velocity divided by the gravitational acceleration to the "//& diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index da18a7341c..9ff99b583f 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -122,7 +122,7 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & integer :: i, j, k, is, ie, js, je, nz real :: T_ref ! Reference temperature within the surface layer [C ~> degC] - real :: S_ref ! Reference salinity within the surface layer [S ~> [ppt] + 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] diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 60ce7b4a56..4a20f0e9b3 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -26,7 +26,7 @@ module tidal_bay_initialization !> Control structure for tidal bay open boundaries. type, public :: tidal_bay_OBC_CS ; private real :: tide_flow = 3.0e6 !< Maximum tidal flux with the tidal bay configuration [L2 Z T-1 ~> m3 s-1] - real :: tide_period !< The period associated with the tidal bay configuration [T ~> s-1] + real :: tide_period !< The period associated with the tidal bay configuration [T ~> s] real :: tide_ssh_amp !< The magnitude of the sea surface height anomalies at the inflow !! with the tidal bay configuration [Z ~> m] end type tidal_bay_OBC_CS From db06a54943e2fa0c3595b2725f7d569aa923070b Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Wed, 1 Mar 2023 14:25:36 -0700 Subject: [PATCH 215/629] add CFC_BC_year_offset, converts model time to time in CFC_BC_file add desc argument to log_param calls in MOM_CFC_cap --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 19 ++++++++++---- src/tracer/MOM_CFC_cap.F90 | 25 ++++++++++++++----- 2 files changed, 33 insertions(+), 11 deletions(-) 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 8691f564dd..6c2504abc7 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -146,10 +146,11 @@ 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. + integer :: id_srestore = -1 !< id number for time_interp_external. + integer :: id_trestore = -1 !< id number for time_interp_external. + integer :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file + integer :: id_cfc11_atm = -1 !< id number for time_interp_external. + integer :: id_cfc12_atm = -1 !< id number for time_interp_external. ! Diagnostics handles type(forcing_diags), public :: handles @@ -596,7 +597,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%CFC_BC_year_offset, & + CS%id_cfc11_atm, CS%id_cfc11_atm) endif if (associated(IOB%salt_flux)) then @@ -1118,6 +1120,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, character(len=48) :: flnam character(len=240) :: basin_file integer :: i, j, isd, ied, jsd, jed + integer :: CFC_BC_data_year ! specific year in CFC BC data calendar + integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1424,6 +1428,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, CS%CFC_BC_file = trim(CS%inputdir) // trim(CS%CFC_BC_file) endif if (len_trim(CS%CFC_BC_file) > 0) then + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & + "Specific year in CFC_BC_FILE data calendar", default=2000, do_not_log=.true.) + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & + "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000, do_not_log=.true.) + CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year call get_param(param_file, mdl, "CFC11_VARIABLE", CS%cfc11_var_name, & "The name of the variable representing CFC-11 in "//& "CFC_BC_FILE.", default="CFC_11", do_not_log=.true.) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 2a5e3f8854..d136e602ee 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -18,7 +18,7 @@ module MOM_CFC_cap use MOM_open_boundary, only : ocean_OBC_type 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 MOM_time_manager, only : time_type, increment_date use time_interp_external_mod, only : init_external_field, time_interp_external use MOM_tracer_registry, only : register_tracer use MOM_tracer_types, only : tracer_registry_type @@ -86,6 +86,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) # include "version_variable.h" real, dimension(:,:,:), pointer :: tr_ptr => NULL() character(len=200) :: dummy ! Dummy variable to store params that need to be logged here. + integer :: dummy_int ! Dummy variable to store params that need to be logged here. character :: m2char logical :: register_CFC_cap integer :: isd, ied, jsd, jed, nz, m @@ -108,7 +109,8 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file, & + "full path of CFC_IC_FILE") endif call get_param(param_file, mdl, "CFC_IC_FILE_IS_Z", CS%Z_IC_file, & "If true, CFC_IC_FILE is in depth space, not layer space", & @@ -135,9 +137,14 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Add the directory if dummy is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") dummy = trim(slasher(inputdir))//trim(dummy) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", dummy) + call log_param(param_file, mdl, "INPUTDIR/CFC_BC_FILE", dummy, & + "full path of CFC_BC_FILE") endif if (len_trim(dummy) > 0) then + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", dummy_int, & + "Specific year in CFC_BC_FILE data calendar", default=2000) + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", dummy_int, & + "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000) call get_param(param_file, mdl, "CFC11_VARIABLE", dummy, & "The name of the variable representing CFC-11 in "//& "CFC_BC_FILE.", default="CFC_11") @@ -428,7 +435,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, CFC_BC_year_offset, & + id_cfc11_atm, id_cfc12_atm) 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,10 +447,13 @@ 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, intent(in ) :: CFC_BC_year_offset !< offset to add to model time to get + !! time value used in CFC_BC_file 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. ! Local variables + type(time_type) :: Time_external ! time value used in CFC_BC_file real, dimension(SZI_(G),SZJ_(G)) :: & kw_wo_sc_no_term, & ! gas transfer velocity, without the Schmidt number term [Z T-1 ~> m s-1]. kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. @@ -462,9 +473,11 @@ 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 + Time_external = increment_date(Time, years=CFC_BC_year_offset) + ! CFC11 ATM concentration if (present(id_cfc11_atm) .and. (id_cfc11_atm /= -1)) then - call time_interp_external(id_cfc11_atm, Time, cfc11_atm) + call time_interp_external(id_cfc11_atm, Time_external, cfc11_atm) ! convert from ppt (pico mol/mol) to mol/mol cfc11_atm = cfc11_atm * 1.0e-12 else @@ -475,7 +488,7 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, id_cfc11_atm, id ! CFC12 ATM concentration if (present(id_cfc12_atm) .and. (id_cfc12_atm /= -1)) then - call time_interp_external(id_cfc12_atm, Time, cfc12_atm) + call time_interp_external(id_cfc12_atm, Time_external, cfc12_atm) ! convert from ppt (pico mol/mol) to mol/mol cfc12_atm = cfc12_atm * 1.0e-12 else From 348d7b741e124e2d51e5eaff90c30fedaa8628f5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 24 Feb 2023 18:00:14 -0500 Subject: [PATCH 216/629] (*)Fix a bug with BULKMIXEDLAYER & ML_MIX_FIRST>0 Restored an else that was inadvertently deleted as a part of code clean up in MOM-ocean/MOM6 PR #1127 on June 5, 2020. This bug causes bulkmixedlayer to be called twice (with cumulative effects) when 0. < ML_MIX_FIRST < 1., and not to be called at all when ML_MIX_FIRST = 1. This bug only applies to cases where the bulk mixed layer is enabled by setting BULKMIXEDLAYER=True and USE_REGRIDDING=False (i.e., in layered mode configurations with active thermodynamics), however because the default value of ML_MIX_FIRST = 0, this bug does not appear to be used in any active test cases, and it went undetected when it was introduced. All answers in the MOM6-examples test suite are bitwise identical, but this could change answers in some cases. --- src/parameterizations/vertical/MOM_diabatic_driver.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index fa08a8c3af..44eed12295 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1783,6 +1783,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & eaml, ebml, G, GV, US, CS%bulkmixedlayer, CS%optics, & Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) + else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & G, GV, US, CS%bulkmixedlayer, CS%optics, & From ceb4c9286df597a89977973b1f300ba1303765ee Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 28 Feb 2023 14:38:48 -0500 Subject: [PATCH 217/629] Only root_PE makes write_energy netcdf file calls Revised write_energy so that only the root_PE attempts to open, reopen or write to a netcdf file. Although FMS can handle cases where multiple PEs make the same calls with internal logic, this change avoids requiring such internal (hidden) logical tests, and instead is more explicit on what is actually intended. This change is complementary to MOM6 dev/gfdl PR #328, which adds internal logic to handle the case where all PEs are making a call to reopen a single netcdf file. All answers and output are bitwise identical. --- src/diagnostics/MOM_sum_output.F90 | 76 +++++++++++++++--------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index 94f34a6c56..fd957d0a44 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -601,15 +601,15 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci endif endif endif - endif - energypath_nc = trim(CS%energyfile) // ".nc" - if (day > CS%Start_time) then - call reopen_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & - num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) - else - call create_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & - num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + energypath_nc = trim(CS%energyfile) // ".nc" + if (day > CS%Start_time) then + call reopen_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + else + call create_MOM_file(CS%fileenergy_nc, trim(energypath_nc), vars, & + num_nc_fields, CS%fields, SINGLE_FILE, CS%timeunit, G=G, GV=GV) + endif endif endif @@ -795,7 +795,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci date_str = trim(mesg_intro)//trim(day_str) endif - if (is_root_pe()) then + if (is_root_pe()) then ! Only the root PE actually writes anything. if (CS%use_temperature) then write(stdout,'(A," ",A,": En ",ES12.6, ", MaxCFL ", F8.5, ", Mass ", & & ES18.12, ", Salt ", F15.11,", Temp ", F15.11)') & @@ -861,37 +861,37 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci enddo endif - endif - call CS%fileenergy_nc%write_field(CS%fields(1), real(CS%ntrunc), reday) - call CS%fileenergy_nc%write_field(CS%fields(2), toten, reday) - call CS%fileenergy_nc%write_field(CS%fields(3), PE, reday) - call CS%fileenergy_nc%write_field(CS%fields(4), KE, reday) - call CS%fileenergy_nc%write_field(CS%fields(5), H_0APE, reday) - call CS%fileenergy_nc%write_field(CS%fields(6), mass_lay, reday) - - call CS%fileenergy_nc%write_field(CS%fields(7), mass_tot, reday) - call CS%fileenergy_nc%write_field(CS%fields(8), mass_chg, reday) - call CS%fileenergy_nc%write_field(CS%fields(9), mass_anom, reday) - call CS%fileenergy_nc%write_field(CS%fields(10), max_CFL(1), reday) - call CS%fileenergy_nc%write_field(CS%fields(11), max_CFL(2), reday) - if (CS%use_temperature) then - call CS%fileenergy_nc%write_field(CS%fields(12), 0.001*Salt, reday) - call CS%fileenergy_nc%write_field(CS%fields(13), 0.001*salt_chg, reday) - call CS%fileenergy_nc%write_field(CS%fields(14), 0.001*salt_anom, reday) - call CS%fileenergy_nc%write_field(CS%fields(15), Heat, reday) - call CS%fileenergy_nc%write_field(CS%fields(16), heat_chg, reday) - call CS%fileenergy_nc%write_field(CS%fields(17), heat_anom, reday) - do m=1,nTr_stocks - call CS%fileenergy_nc%write_field(CS%fields(17+m), Tr_stocks(m), reday) - enddo - else - do m=1,nTr_stocks - call CS%fileenergy_nc%write_field(CS%fields(11+m), Tr_stocks(m), reday) - enddo - endif + call CS%fileenergy_nc%write_field(CS%fields(1), real(CS%ntrunc), reday) + call CS%fileenergy_nc%write_field(CS%fields(2), toten, reday) + call CS%fileenergy_nc%write_field(CS%fields(3), PE, reday) + call CS%fileenergy_nc%write_field(CS%fields(4), KE, reday) + call CS%fileenergy_nc%write_field(CS%fields(5), H_0APE, reday) + call CS%fileenergy_nc%write_field(CS%fields(6), mass_lay, reday) + + call CS%fileenergy_nc%write_field(CS%fields(7), mass_tot, reday) + call CS%fileenergy_nc%write_field(CS%fields(8), mass_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(9), mass_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(10), max_CFL(1), reday) + call CS%fileenergy_nc%write_field(CS%fields(11), max_CFL(2), reday) + if (CS%use_temperature) then + call CS%fileenergy_nc%write_field(CS%fields(12), 0.001*Salt, reday) + call CS%fileenergy_nc%write_field(CS%fields(13), 0.001*salt_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(14), 0.001*salt_anom, reday) + call CS%fileenergy_nc%write_field(CS%fields(15), Heat, reday) + call CS%fileenergy_nc%write_field(CS%fields(16), heat_chg, reday) + call CS%fileenergy_nc%write_field(CS%fields(17), heat_anom, reday) + do m=1,nTr_stocks + call CS%fileenergy_nc%write_field(CS%fields(17+m), Tr_stocks(m), reday) + enddo + else + do m=1,nTr_stocks + call CS%fileenergy_nc%write_field(CS%fields(11+m), Tr_stocks(m), reday) + enddo + endif - call CS%fileenergy_nc%flush() + call CS%fileenergy_nc%flush() + endif ! Only the root PE actually writes anything. if (is_NaN(En_mass)) then call MOM_error(FATAL, "write_energy : NaNs in total model energy forced model termination.") From 774074ff9db66da5434e910ef30a52fdfc376b31 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 6 Mar 2023 09:51:58 -0700 Subject: [PATCH 218/629] minor styling fixes to address PR #1594 reviews. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 8 +++---- src/tracer/ideal_age_example.F90 | 30 ++++++++++++------------ 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 76d541813e..b7d651bf55 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1687,10 +1687,10 @@ subroutine ModelAdvance(gcomp, rc) close(writeunit) endif else ! not cesm_coupled - write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & - ".MOM.res" - write(stoch_restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & - ".ocn_stoch.res.nc" + write(restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".MOM.res" + write(stoch_restartname,'(i4.4,2(i2.2),A,3(i2.2),A)') year, month, day,".", hour, minute, seconds, & + ".ocn_stoch.res.nc" call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index e2d557ccb2..f0ad7cab99 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -379,7 +379,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, young_val = CS%young_val(m) else young_val = CS%young_val(m) * & - exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) + exp((year-CS%tracer_start_year(m)) * CS%growth_rate(m)) endif if (m == CS%BL_residence_num) then @@ -409,11 +409,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, do k=nk+2,nz - if (G%mask2dT(i,j) > 0.0) then - CS%tr(i,j,k,m) = young_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif enddo enddo ; enddo @@ -428,11 +428,11 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo do k=CS%nkbl+1,nz - if (G%mask2dT(i,j) > 0.0) then - CS%tr(i,j,k,m) = young_val - else - CS%tr(i,j,k,m) = CS%land_val(m) - endif + if (G%mask2dT(i,j) > 0.0) then + CS%tr(i,j,k,m) = young_val + else + CS%tr(i,j,k,m) = CS%land_val(m) + endif enddo enddo ; enddo @@ -479,10 +479,10 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, enddo ; enddo ; enddo if (CS%tracer_ages(m) .and. (year>=CS%tracer_start_year(m))) then - !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) - do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year - enddo ; enddo ; enddo + !$OMP parallel do default(none) shared(is,ie,js,je,CS,nz,G,dt,Isecs_per_year,m) + do k=CS%nkbl+1,nz ; do j=js,je ; do i=is,ie + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt*Isecs_per_year + enddo ; enddo ; enddo endif From ed93a232aa019a818a770e35ea53198abe72d7f5 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Mon, 6 Mar 2023 09:58:37 -0700 Subject: [PATCH 219/629] add SMOOTH_RI to MOM_obsolete_params.F90 --- src/diagnostics/MOM_obsolete_params.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index e686261fdf..c44aebf08d 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -97,6 +97,8 @@ subroutine find_obsolete_params(param_file) ! This parameter is on the to-do list to be obsoleted. ! call obsolete_logical(param_file, "NEW_SPONGES", hint="Use INTERPOLATE_SPONGE_TIME_SPACE instead.") + call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) From b85581ea83223d940797e82e9f41ca412e2ad427 Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Thu, 9 Mar 2023 14:24:43 -0700 Subject: [PATCH 220/629] read atm CFC hemispheric aveages from CFC_BC_FILE, instead of 2D fields CFC_BC_FILE must be specified if USE_CFC_CAP=.true. use hemispheric averages poleward of 10 degrees latitude linearly interpolate between 10S and 10N correct bug that atm cfc12 was used in cfc11 flux computation --- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 61 ++++---- src/tracer/MOM_CFC_cap.F90 | 135 ++++++++++-------- 2 files changed, 113 insertions(+), 83 deletions(-) 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 6c2504abc7..5f0c7c361f 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -143,14 +143,14 @@ module MOM_surface_forcing_nuopc !! temperature restoring fluxes. The masking file should be !! in inputdir/temp_restore_mask.nc and the field should !! be named 'mask' - 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 :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file - integer :: id_cfc11_atm = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm = -1 !< id number for time_interp_external. + integer :: id_cfc11_atm_nh = -1 !< id number for time_interp_external. + integer :: id_cfc11_atm_sh = -1 !< id number for time_interp_external. + integer :: id_cfc12_atm_nh = -1 !< id number for time_interp_external. + integer :: id_cfc12_atm_sh = -1 !< id number for time_interp_external. ! Diagnostics handles type(forcing_diags), public :: handles @@ -246,8 +246,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! local variables real, dimension(SZI_(G),SZJ_(G)) :: & - cfc11_atm, & !< CFC11 concentration in the atmopshere [???????] - cfc12_atm, & !< CFC11 concentration in the atmopshere [???????] data_restore, & !< The surface value toward which to restore [S ~> ppt] or [C ~> degC] PmE_adj, & !< The adjustment to PminusE that will cause the salinity !! to be restored toward its target value [kg/(m^2 * s)] @@ -598,7 +596,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%CFC_BC_year_offset, & - CS%id_cfc11_atm, CS%id_cfc11_atm) + CS%id_cfc11_atm_nh, CS%id_cfc11_atm_sh, & + CS%id_cfc12_atm_nh, CS%id_cfc12_atm_sh) endif if (associated(IOB%salt_flux)) then @@ -1119,6 +1118,10 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, character(len=48) :: stagger character(len=48) :: flnam character(len=240) :: basin_file + character(len=30) :: cfc11_nh_var_name ! name of cfc11 nh in CFC_BC_file + character(len=30) :: cfc11_sh_var_name ! name of cfc11 sh in CFC_BC_file + character(len=30) :: cfc12_nh_var_name ! name of cfc12 nh in CFC_BC_file + character(len=30) :: cfc12_sh_var_name ! name of cfc12 sh in CFC_BC_file integer :: i, j, isd, ied, jsd, jed integer :: CFC_BC_data_year ! specific year in CFC BC data calendar integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year @@ -1421,28 +1424,36 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, if (CS%use_CFC) then call get_param(param_file, mdl, "CFC_BC_FILE", CS%CFC_BC_file, & "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion), or an empty string for "//& - "internal BC generation (TODO).", default=" ", do_not_log=.true.) - if ((len_trim(CS%CFC_BC_file) > 0) .and. (scan(CS%CFC_BC_file,'/') == 0)) then + "found (units must be parts per trillion).", default=" ", do_not_log=.true.) + if (len_trim(CS%CFC_BC_file) == 0) then + call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") + endif + if (scan(CS%CFC_BC_file, '/') == 0) then ! Add the directory if CFC_BC_file is not already a complete path. - CS%CFC_BC_file = trim(CS%inputdir) // trim(CS%CFC_BC_file) + CS%CFC_BC_file = trim(CS%inputdir)//trim(CS%CFC_BC_file) endif - if (len_trim(CS%CFC_BC_file) > 0) then - call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & "Specific year in CFC_BC_FILE data calendar", default=2000, do_not_log=.true.) - call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000, do_not_log=.true.) - CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year - call get_param(param_file, mdl, "CFC11_VARIABLE", CS%cfc11_var_name, & - "The name of the variable representing CFC-11 in "//& - "CFC_BC_FILE.", default="CFC_11", do_not_log=.true.) - call get_param(param_file, mdl, "CFC12_VARIABLE", CS%cfc12_var_name, & - "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) - endif + CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year + call get_param(param_file, mdl, "CFC11_NH_VARIABLE", cfc11_nh_var_name, & + "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_nh", do_not_log=.true.) + call get_param(param_file, mdl, "CFC11_SH_VARIABLE", cfc11_sh_var_name, & + "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_sh", do_not_log=.true.) + call get_param(param_file, mdl, "CFC12_NH_VARIABLE", cfc12_nh_var_name, & + "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_nh", do_not_log=.true.) + call get_param(param_file, mdl, "CFC12_SH_VARIABLE", cfc12_sh_var_name, & + "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_sh", do_not_log=.true.) + + CS%id_cfc11_atm_nh = init_external_field(CS%CFC_BC_file, cfc11_nh_var_name) + CS%id_cfc11_atm_sh = init_external_field(CS%CFC_BC_file, cfc11_sh_var_name) + CS%id_cfc12_atm_nh = init_external_field(CS%CFC_BC_file, cfc12_nh_var_name) + CS%id_cfc12_atm_sh = init_external_field(CS%CFC_BC_file, cfc12_sh_var_name) endif ! Set up any restart fields associated with the forcing. diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index d136e602ee..427ea1ed9a 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -105,7 +105,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) "The file in which the CFC initial values can be "//& "found, or an empty string for internal initialization.", & default=" ") - if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then + if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file, '/') == 0)) then ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) @@ -130,10 +130,12 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! the following params are not used in this module. Instead, they are used in ! the cap but are logged here to keep all the CFC cap params together. call get_param(param_file, mdl, "CFC_BC_FILE", dummy, & - "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion), or an empty string for "//& - "internal BC generation (TODO).", default=" ") - if ((len_trim(dummy) > 0) .and. (scan(dummy,'/') == 0)) then + "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& + "found (units must be parts per trillion).", default=" ") + if (len_trim(dummy) == 0) then + call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") + endif + if (scan(dummy, '/') == 0) then ! Add the directory if dummy is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") dummy = trim(slasher(inputdir))//trim(dummy) @@ -145,12 +147,18 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) "Specific year in CFC_BC_FILE data calendar", default=2000) call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", dummy_int, & "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000) - call get_param(param_file, mdl, "CFC11_VARIABLE", dummy, & - "The name of the variable representing CFC-11 in "//& - "CFC_BC_FILE.", default="CFC_11") - call get_param(param_file, mdl, "CFC12_VARIABLE", dummy, & - "The name of the variable representing CFC-12 in "//& - "CFC_BC_FILE.", default="CFC_12") + call get_param(param_file, mdl, "CFC11_NH_VARIABLE", dummy, & + "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_nh") + call get_param(param_file, mdl, "CFC11_SH_VARIABLE", dummy, & + "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_sh") + call get_param(param_file, mdl, "CFC12_NH_VARIABLE", dummy, & + "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_nh") + call get_param(param_file, mdl, "CFC12_SH_VARIABLE", dummy, & + "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_sh") endif ! The following vardesc types contain a package of metadata about each tracer, @@ -436,66 +444,62 @@ 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, CFC_BC_year_offset, & - id_cfc11_atm, id_cfc12_atm) - 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 - !! that describe the surface state of the ocean. - type(forcing), intent(inout) :: fluxes !< A structure containing pointers - !! to thermodynamic and tracer forcing fields. Unused fields - !! have NULL ptrs. - 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, intent(in ) :: CFC_BC_year_offset !< offset to add to model time to get - !! time value used in CFC_BC_file - 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. + id_cfc11_atm_nh, id_cfc11_atm_sh, id_cfc12_atm_nh, id_cfc12_atm_sh) + 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 + !! that describe the surface state of the ocean. + type(forcing), intent(inout) :: fluxes !< A structure containing pointers + !! to thermodynamic and tracer forcing fields. Unused fields + !! have NULL ptrs. + 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, intent(in ) :: CFC_BC_year_offset !< offset to add to model time to get + !! time value used in CFC_BC_file + integer, intent(inout) :: id_cfc11_atm_nh !< id number for time_interp_external. + integer, intent(inout) :: id_cfc11_atm_sh !< id number for time_interp_external. + integer, intent(inout) :: id_cfc12_atm_nh !< id number for time_interp_external. + integer, intent(inout) :: id_cfc12_atm_sh !< id number for time_interp_external. ! Local variables type(time_type) :: Time_external ! time value used in CFC_BC_file real, dimension(SZI_(G),SZJ_(G)) :: & kw_wo_sc_no_term, & ! gas transfer velocity, without the Schmidt number term [Z T-1 ~> m s-1]. - kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. - cair, & ! The surface gas concentration in equilibrium with the atmosphere (saturation concentration) - ! [mol kg-1]. - cfc11_atm, & !< CFC11 concentration in the atmopshere [pico mol/mol] - cfc12_atm !< CFC11 concentration in the atmopshere [pico mol/mol] - real :: ta ! Absolute sea surface temperature [hectoKelvin] - real :: sal ! Surface salinity [PSU]. - real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. - real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. - real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. - real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] + kw, & ! gas transfer velocity [Z T-1 ~> m s-1]. + cair, & ! The surface gas concentration in equilibrium with the atmosphere + ! (saturation concentration) [mol kg-1]. + cfc11_atm, & ! CFC11 atm mole fraction [pico mol/mol] + cfc12_atm ! CFC12 atm mole fraction [pico mol/mol] + real :: cfc11_atm_nh ! NH value for cfc11_atm + real :: cfc11_atm_sh ! SH value for cfc11_atm + real :: cfc12_atm_nh ! NH value for cfc12_atm + real :: cfc12_atm_sh ! SH value for cfc12_atm + real :: ta ! Absolute sea surface temperature [hectoKelvin] + real :: sal ! Surface salinity [PSU]. + real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. + real :: alpha_12 ! The solubility of CFC 12 [mol kg-1 atm-1]. + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. + real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] real, parameter :: pa_to_atm = 9.8692316931427e-6 ! factor for converting from Pa to atm [atm Pa-1]. - real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] + real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Time_external = increment_date(Time, years=CFC_BC_year_offset) - ! CFC11 ATM concentration - if (present(id_cfc11_atm) .and. (id_cfc11_atm /= -1)) then - call time_interp_external(id_cfc11_atm, Time_external, cfc11_atm) - ! convert from ppt (pico mol/mol) to mol/mol - cfc11_atm = cfc11_atm * 1.0e-12 - else - ! TODO: create cfc11_atm internally - call MOM_error(FATAL, "CFC_cap_fluxes: option to create cfc11_atm internally" //& - "has not been implemented yet.") - endif + ! CFC11 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(id_cfc11_atm_nh, Time_external, cfc11_atm_nh) + cfc11_atm_nh = cfc11_atm_nh * 1.0e-12 + call time_interp_external(id_cfc11_atm_sh, Time_external, cfc11_atm_sh) + cfc11_atm_sh = cfc11_atm_sh * 1.0e-12 - ! CFC12 ATM concentration - if (present(id_cfc12_atm) .and. (id_cfc12_atm /= -1)) then - call time_interp_external(id_cfc12_atm, Time_external, cfc12_atm) - ! convert from ppt (pico mol/mol) to mol/mol - cfc12_atm = cfc12_atm * 1.0e-12 - else - ! TODO: create cfc11_atm internally - call MOM_error(FATAL, "CFC_cap_fluxes: option to create cfc12_atm internally" //& - "has not been implemented yet.") - endif + ! CFC12 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol + call time_interp_external(id_cfc12_atm_nh, Time_external, cfc12_atm_nh) + cfc12_atm_nh = cfc12_atm_nh * 1.0e-12 + call time_interp_external(id_cfc12_atm_sh, Time_external, cfc12_atm_sh) + cfc12_atm_sh = cfc12_atm_sh * 1.0e-12 !--------------------------------------------------------------------- ! Gas exchange/piston velocity parameter @@ -507,6 +511,21 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, CFC_BC_year_offs ! set unit conversion factors press_to_atm = US%R_to_kg_m3*US%L_T_to_m_s**2 * pa_to_atm + do j=js,je ; do i=is,ie + if (G%geoLatT(i,j) < -10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + cfc12_atm(i,j) = cfc12_atm_sh + elseif (G%geoLatT(i,j) <= 10.0) then + cfc11_atm(i,j) = cfc11_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc11_atm_nh - cfc11_atm_sh) + cfc12_atm(i,j) = cfc12_atm_sh + & + (0.05 * G%geoLatT(i,j) + 0.5) * (cfc12_atm_nh - cfc12_atm_sh) + else + cfc11_atm(i,j) = cfc11_atm_nh + cfc12_atm(i,j) = cfc12_atm_nh + endif + enddo ; enddo + do j=js,je ; do i=is,ie ! ta in hectoKelvin ta = max(0.01, (US%C_to_degC*sfc_state%SST(i,j) + 273.15) * 0.01) From d1d53bcb4c7ebf4263d35ef0420c95a5fb82a579 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Thu, 16 Mar 2023 18:31:37 -0600 Subject: [PATCH 221/629] remove inadvertent reassignment of layer_frac --- src/tracer/ideal_age_example.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index f0ad7cab99..dfa5e894db 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -400,7 +400,6 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, if (G%mask2dT(i,j) > 0.0) then layer_frac = BL_layers(i,j)-nk - layer_frac = 0.9 CS%tr(i,j,k,m) = layer_frac * (CS%tr(i,j,k,m) + G%mask2dT(i,j)*dt & *Isecs_per_year) + (1.-layer_frac) * young_val else From eff5036e00d7bbde0209b46ef0c64e1a6fdaade5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 23 Mar 2023 13:22:49 -0600 Subject: [PATCH 222/629] Unit tests and final cleaning * Add subroutine hbd_grid_test, which mimics subroutine hbd_grid but it is only used in the unit tests; * Add unit tests for hbd_grid_test and fix existing tests for fluxes_layer_method; * Delete unused code and fix the format of doxygen throughout the module. --- src/tracer/MOM_hor_bnd_diffusion.F90 | 319 +++++++-------------------- src/tracer/MOM_tracer_registry.F90 | 12 +- 2 files changed, 82 insertions(+), 249 deletions(-) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 4b9bd5ca40..d0920ee117 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -37,7 +37,7 @@ module MOM_hor_bnd_diffusion integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include -!> Sets parameters for lateral boundary mixing module. +!> Sets parameters for horizontal boundary mixing module. type, public :: hbd_CS ; private logical :: debug !< If true, write verbose checksums for debugging. integer :: deg !< Degree of polynomial reconstruction. @@ -55,11 +55,11 @@ module MOM_hor_bnd_diffusion !! If Angstrom is 0 or exceedingly small, this is negligible compared to 1e-17 m. ! HBD dynamic grids real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjecent to - !! u-points [H ~> m or kg m-2] + !! u-points [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: hbd_grd_v !< HBD thicknesses at t-points adjacent to - !! v-points (left and right) [H ~> m or kg m-2] + !! v-points (left and right) [H ~> m or kg m-2] integer, allocatable, dimension(:,:) :: hbd_u_kmax !< Maximum vertical index in hbd_grd_u [nondim] - integer, allocatable, dimension(:,:) :: hbd_v_kmax !< Maximum vertical index in hbd_grd_v [nondim + integer, allocatable, dimension(:,:) :: hbd_v_kmax !< Maximum vertical index in hbd_grd_v [nondim] type(remapping_CS) :: remap_CS !< Control structure to hold remapping configuration. type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD. type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure needed to get BLD. @@ -70,7 +70,7 @@ module MOM_hor_bnd_diffusion ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_hor_bnd_diffusion" !< Name of this module -integer :: id_clock_hbd !< CPU clock for hbd +integer :: id_clock_hbd !< CPU clock for hbd contains @@ -122,7 +122,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba CS%surface_boundary_scheme = -1 if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then - call MOM_error(FATAL,"Lateral boundary diffusion is true, but no valid boundary layer scheme was found") + call MOM_error(FATAL,"Horizontal boundary diffusion is true, but no valid boundary layer scheme was found") endif ! Read all relevant parameters and write them to the model log. @@ -141,9 +141,10 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - !### Revisit this hard-coded answer_date. + + ! GMM, TODO: add HBD params to control optional arguments in initialize_remapping. call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& - check_reconstruction=.false., check_remapping=.false., answer_date=20190101) + check_reconstruction=.false., check_remapping=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & "If true, write out verbose debugging data in the HBD module.", & @@ -153,7 +154,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba end function hor_bnd_diffusion_init -!> Driver routine for calculating lateral diffusive fluxes near the top and bottom boundaries. +!> Driver routine for calculating horizontal diffusive fluxes near the top and bottom boundaries. !! Diffusion is applied using only information from neighboring cells, as follows: !! 1) remap tracer to a z* grid (HBD grid) !! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach @@ -228,9 +229,6 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & CS%hbd_grd_u(I,j,:), CS) - ! call fluxes_layer_method_old(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & - ! h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & - ! Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS) endif enddo enddo @@ -241,9 +239,6 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & CS%hbd_grd_v(i,J,:), CS) - !call fluxes_layer_method_old(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & - ! h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & - ! Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS) endif enddo enddo @@ -330,29 +325,21 @@ end subroutine hor_bnd_diffusion !> Build the HBD grid where tracers will be rammaped to. subroutine hbd_grid(boundary, G, GV, hbl, h, CS) - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] - type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure ! Local variables - real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] - integer :: k_bot_min, k_bot_max !< k-indices min and max, respectively. - integer :: k_bot_L, k_bot_R !< k-indices for left and right columns, respectively. - integer :: k_bot_diff !< different between left and right k-indices. - integer :: k_top, k_bot !< indices used to store position of maximum isopycnal slope. - real :: zeta_top !< distance from the top of a layer to the boundary - !! layer depth in the native grid [nondim] - real :: zeta_bot !< distance from the bottom of a layer to the boundary - !! layer depth in the native grid [nondim] - integer :: nk, i, j, k !< number of layers in the HBD grid, and integers used in do-loops + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, i, j, k !< number of layers in the HBD grid, and integers used in do-loops ! reset arrays - CS%hbd_grd_u(:,:,:) = 0.0 !CS%H_subroundoff - CS%hbd_grd_v(:,:,:) = 0.0 !CS%H_subroundoff + CS%hbd_grd_u(:,:,:) = 0.0 + CS%hbd_grd_v(:,:,:) = 0.0 CS%hbd_u_kmax(:,:) = 0 CS%hbd_v_kmax(:,:) = 0 @@ -368,7 +355,6 @@ subroutine hbd_grid(boundary, G, GV, hbl, h, CS) endif CS%hbd_u_kmax(I,j) = nk - !CS%hbd_u_kmax(I,j) = CS%hbd_nk ! set the HBD grid to dz_top do k=1,nk @@ -392,7 +378,6 @@ subroutine hbd_grid(boundary, G, GV, hbl, h, CS) endif CS%hbd_v_kmax(i,J) = nk - !CS%hbd_v_kmax(i,J) = CS%hbd_nk ! set the HBD grid to dz_top do k=1,nk @@ -618,6 +603,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b ! Local variables real :: htot ! Summed thickness [H ~> m or kg m-2] integer :: k + ! Surface boundary layer if ( boundary == SURFACE ) then k_top = 1 @@ -639,6 +625,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b return endif enddo + ! Bottom boundary layer elseif ( boundary == BOTTOM ) then k_top = nk @@ -666,7 +653,7 @@ subroutine boundary_k_range(boundary, nk, h, hbl, k_top, zeta_top, k_bot, zeta_b end subroutine boundary_k_range -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. +!> Calculate the horizontal boundary diffusive fluxes using the layer by layer method. !! See \ref section_method subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, area_L, area_R, nk, dz_top, CS) @@ -689,7 +676,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] integer, intent(in ) :: nk !< Number of layers in the HBD grid [nondim] real, dimension(nk), intent(in ) :: dz_top !< The HBD z grid [H ~> m or kg m-2] - type(hbd_CS), pointer :: CS !< Lateral diffusion control structure + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure ! Local variables real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] @@ -702,9 +689,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ integer :: k_bot_min !< Minimum k-index for the bottom integer :: k_bot_max !< Maximum k-index for the bottom integer :: k_bot_diff !< Difference between bottom left and right k-indices - !integer :: k_top_max !< Minimum k-index for the top - !integer :: k_top_min !< Maximum k-index for the top - !integer :: k_top_diff !< Difference between top left and right k-indices integer :: k_top_L, k_bot_L !< k-indices left native grid integer :: k_top_R, k_bot_R !< k-indices right native grid real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary @@ -772,27 +756,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ endif endif -! TODO, boundary == BOTTOM -! if (boundary == BOTTOM) then -! ! TODO: GMM add option to apply linear decay -! k_top_max = MAX(k_top_L, k_top_R) -! ! make sure left and right k indices span same range -! if (k_top_max /= k_top_L) then -! k_top_L = k_top_max -! zeta_top_L = 1.0 -! endif -! if (k_top_max /= k_top_R) then -! k_top_R= k_top_max -! zeta_top_R = 1.0 -! endif -! -! ! tracer flux where the minimum BLD intersets layer -! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) -! -! do k = k_top_max+1,nk -! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) -! enddo -! endif + !GMM, TODO: boundary == BOTTOM ! thicknesses at velocity points do k = 1,ke @@ -832,177 +796,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ end subroutine fluxes_layer_method -!> Calculate the lateral boundary diffusive fluxes using the layer by layer method. -!! See \ref section_method -subroutine fluxes_layer_method_old(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, area_L, area_R, CS) - - integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] - integer, intent(in ) :: ke !< Number of layers in the native grid [nondim] - real, intent(in ) :: hbl_L !< Thickness of the boundary boundary - !! layer (left) [H ~> m or kg m-2] - real, intent(in ) :: hbl_R !< Thickness of the boundary boundary - !! layer (right) [H ~> m or kg m-2] - real, dimension(ke), intent(in ) :: h_L !< Thicknesses in the native grid (left) [H ~> m or kg m-2] - real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] - real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] - real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step - !! at a velocity point [L2 ~> m2] - real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point - !! in the native grid [H L2 conc ~> m3 conc] - real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] - real, intent(in ) :: area_R !< Area of the horizontal grid (right) [L2 ~> m2] - type(hbd_CS), pointer :: CS !< Lateral diffusion control structure - - ! Local variables - real, allocatable :: dz_top(:) !< The HBD z grid to be created [H ~> m or kg m-2] - real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] - real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] - real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] - real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid - !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] - real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k - integer :: k_bot_min !< Minimum k-index for the bottom - integer :: k_bot_max !< Maximum k-index for the bottom - integer :: k_bot_diff !< Difference between bottom left and right k-indices - !integer :: k_top_max !< Minimum k-index for the top - !integer :: k_top_min !< Maximum k-index for the top - !integer :: k_top_diff !< Difference between top left and right k-indices - integer :: k_top_L, k_bot_L !< k-indices left native grid - integer :: k_top_R, k_bot_R !< k-indices right native grid - real :: zeta_top_L, zeta_top_R !< distance from the top of a layer to the boundary - !! layer depth in the native grid [nondim] - real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary - !! layer depth in the native grid [nondim] - real :: wgt !< weight to be used in the linear transition to the interior [nondim] - real :: a !< coefficient to be used in the linear transition to the interior [nondim] - real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] - real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] - integer :: nk !< number of layers in the HBD grid - - F_layer(:) = 0.0 - if (hbl_L == 0. .or. hbl_R == 0.) then - return - endif - - ! Define vertical grid, dz_top - call merge_interfaces(ke, h_L(:), h_R(:), hbl_L, hbl_R, CS%H_subroundoff, dz_top) - nk = SIZE(dz_top) - - ! allocate arrays - allocate(phi_L_z(nk), source=0.0) - allocate(phi_R_z(nk), source=0.0) - allocate(F_layer_z(nk), source=0.0) - - ! remap tracer to dz_top - call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & - CS%H_subroundoff, CS%H_subroundoff) - call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & - CS%H_subroundoff, CS%H_subroundoff) - - ! Calculate vertical indices containing the boundary layer in dz_top - call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) - call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) - - if (boundary == SURFACE) then - k_bot_min = MIN(k_bot_L, k_bot_R) - k_bot_max = MAX(k_bot_L, k_bot_R) - k_bot_diff = (k_bot_max - k_bot_min) - - ! tracer flux where the minimum BLD intersets layer - if ((CS%linear) .and. (k_bot_diff > 1)) then - ! apply linear decay at the base of hbl - do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) - if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & - phi_R_z(k), dz_top(k), dz_top(k)) - enddo - htot = 0.0 - do k = k_bot_min+1,k_bot_max, 1 - htot = htot + dz_top(k) - enddo - - a = -1.0/htot - htot = 0. - do k = k_bot_min+1,k_bot_max, 1 - wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt - htot = htot + dz_top(k) - if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & - phi_R_z(k), dz_top(k), dz_top(k)) - enddo - else - do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) - if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & - phi_R_z(k), dz_top(k), dz_top(k)) - enddo - endif - endif - -! TODO, boundary == BOTTOM -! if (boundary == BOTTOM) then -! ! TODO: GMM add option to apply linear decay -! k_top_max = MAX(k_top_L, k_top_R) -! ! make sure left and right k indices span same range -! if (k_top_max /= k_top_L) then -! k_top_L = k_top_max -! zeta_top_L = 1.0 -! endif -! if (k_top_max /= k_top_R) then -! k_top_R= k_top_max -! zeta_top_R = 1.0 -! endif -! -! ! tracer flux where the minimum BLD intersets layer -! F_layer(k_top_max) = (-heff * khtr_u) * (phi_R_avg - phi_L_avg) -! -! do k = k_top_max+1,nk -! F_layer_z(k) = -(heff * khtr_u) * (phi_R_z(k) - phi_L_z(k)) -! enddo -! endif - - ! thicknesses at velocity points - do k = 1,ke - h_vel(k) = harmonic_mean(h_L(k), h_R(k)) - enddo - - ! remap flux to h_vel (native grid) - call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), 0.0, F_layer(:)) - - ! used to avoid fluxes below hbl - if (CS%linear) then - htot_max = MAX(hbl_L, hbl_R) - else - htot_max = MIN(hbl_L, hbl_R) - endif - - tmp1 = 0.0; tmp2 = 0.0 - do k = 1,ke - ! apply flux_limiter - if (CS%limiter .and. F_layer(k) /= 0.) then - call flux_limiter(F_layer(k), area_L, area_R, phi_L(k), phi_R(k), h_L(k), h_R(k)) - endif - - ! if tracer point is below htot_max, set flux to zero - if (MAX(tmp1+(h_L(k)*0.5), tmp2+(h_R(k)*0.5)) > htot_max) then - F_layer(k) = 0. - endif - - tmp1 = tmp1 + h_L(k) - tmp2 = tmp2 + h_R(k) - enddo - - ! deallocated arrays - deallocate(dz_top) - deallocate(phi_L_z) - deallocate(phi_R_z) - deallocate(F_layer_z) - -end subroutine fluxes_layer_method_old - !> Unit tests for near-boundary horizontal mixing logical function near_boundary_unit_tests( verbose ) logical, intent(in) :: verbose !< If true, output additional information for debugging unit tests @@ -1033,7 +826,9 @@ logical function near_boundary_unit_tests( verbose ) CS%debug=.false. CS%limiter=.false. CS%limiter_remap=.false. - + CS%hbd_nk = 2 + (2*2) + allocate(CS%hbd_grd_u(1,1,CS%hbd_nk), source=0.0) + allocate(CS%hbd_u_kmax(1,1), source=0) near_boundary_unit_tests = .false. write(stdout,*) '==== MOM_hor_bnd_diffusion =======================' @@ -1190,8 +985,9 @@ logical function near_boundary_unit_tests( verbose ) h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) khtr_u = 1. - call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-2.0,0.0/) ) @@ -1200,8 +996,9 @@ logical function near_boundary_unit_tests( verbose ) h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/2.,1./) ; phi_R = (/1.,1./) khtr_u = 0.5 - call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/1.0,0.0/) ) @@ -1210,8 +1007,9 @@ logical function near_boundary_unit_tests( verbose ) h_L = (/1.,2./) ; h_R = (/1.,2./) phi_L = (/0.,0./) ; phi_R = (/0.5,2./) khtr_u = 2. - call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/-1.0,-4.0/) ) @@ -1220,8 +1018,9 @@ logical function near_boundary_unit_tests( verbose ) h_L = (/6.,6./) ; h_R = (/10.,10./) phi_L = (/1.,1./) ; phi_R = (/1.,1./) khtr_u = 1. - call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/0.,0./) ) @@ -1231,9 +1030,9 @@ logical function near_boundary_unit_tests( verbose ) h_L = (/10.,5./) ; h_R = (/10.,0./) phi_L = (/1.,1./) ; phi_R = (/0.,0./) khtr_u = 1. - call fluxes_layer_method_old(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & - khtr_u, F_layer, 1., 1., CS) - + call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) + call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & + khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) near_boundary_unit_tests = near_boundary_unit_tests .or. & test_layer_fluxes( verbose, nk, test_name, F_layer, (/10.,0.0/) ) @@ -1299,6 +1098,40 @@ logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_a end function test_boundary_k_range +!> Same as hbd_grid, but only used in the unit tests. +subroutine hbd_grid_test(boundary, hbl_L, hbl_R, h_L, h_R, CS) + integer, intent(in) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] + real, intent(in) :: hbl_L !< Boundary layer depth, left [H ~> m or kg m-2] + real, intent(in) :: hbl_R !< Boundary layer depth, right [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_L !< Layer thickness in the native grid, left [H ~> m or kg m-2] + real, dimension(2), intent(in) :: h_R !< Layer thickness in the native grid, right [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + + ! Local variables + real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] + integer :: nk, k !< number of layers in the HBD grid, and integers used in do-loops + + ! reset arrays + CS%hbd_grd_u(1,1,:) = 0.0 + CS%hbd_u_kmax(1,1) = 0 + + call merge_interfaces(2, h_L, h_R, hbl_L, hbl_R, CS%H_subroundoff, dz_top) + nk = SIZE(dz_top) + if (nk > CS%hbd_nk) then + write(*,*)'nk, CS%hbd_nk', nk, CS%hbd_nk + call MOM_error(FATAL,"Houston, we've had a problem in hbd_grid_test, (nk cannot be > CS%hbd_nk)") + endif + + CS%hbd_u_kmax(1,1) = nk + + ! set the HBD grid to dz_top + do k=1,nk + CS%hbd_grd_u(1,1,k) = dz_top(k) + enddo + deallocate(dz_top) + +end subroutine hbd_grid_test + !> Deallocates hor_bnd_diffusion control structure subroutine hor_bnd_diffusion_end(CS) type(hbd_CS), pointer :: CS !< Horizontal boundary diffusion control structure @@ -1321,7 +1154,7 @@ end subroutine hor_bnd_diffusion_end !! The bottom boundary layer fluxes remain to be implemented, although some !! of the steps needed to do so have already been added and tested. !! -!! Boundary lateral diffusion is applied as follows: +!! Horizontal boundary diffusion is applied as follows: !! !! 1) remap tracer to a z* grid (HBD grid) !! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach (@ref section_method) diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 3f8c9b5232..6e1f2bee5a 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -359,13 +359,13 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u trim(flux_units), v_extensive=.true., x_cell_method='sum', & conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_hbd_dfx = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffx", & - diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux from the horizontal boundary diffusion "//& - "scheme", trim(flux_units), v_extensive=.true., y_cell_method='sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + diag%axesCuL, Time, trim(flux_longname)//" diffusive zonal flux " //& + "from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + y_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) Tr%id_hbd_dfy = register_diag_field("ocean_model", trim(shortnm)//"_hbd_diffy", & - diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional flux from the horizontal boundary diffusion "//& - "scheme", trim(flux_units), v_extensive=.true., x_cell_method='sum', & - conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) + diag%axesCvL, Time, trim(flux_longname)//" diffusive meridional " //& + "flux from the horizontal boundary diffusion scheme", trim(flux_units), v_extensive=.true., & + x_cell_method='sum', conversion=(US%L_to_m**2)*Tr%flux_scale*US%s_to_T) else Tr%id_adx = register_diag_field("ocean_model", trim(shortnm)//"_adx", & diag%axesCuL, Time, "Advective (by residual mean) Zonal Flux of "//trim(flux_longname), & From a697159a2f07f586bf80298ea011a8ed7292f652 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 23 Mar 2023 15:15:07 -0600 Subject: [PATCH 223/629] Obsolete the USE_LATERAL_BOUNDARY_DIFFUSION option --- src/diagnostics/MOM_obsolete_params.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index e686261fdf..f0d2bc2d6a 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -85,6 +85,8 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) call obsolete_int(param_file, "SEAMOUNT_LENGTH_SCALE", hint="Use SEAMOUNT_X_LENGTH_SCALE instead.") + call obsolete_int(param_file, "USE_LATERAL_BOUNDARY_DIFFUSION", & + hint="Use USE_HORIZONTAL_BOUNDARY_DIFFUSION instead.") call obsolete_logical(param_file, "MSTAR_FIXED", hint="Instead use MSTAR_MODE.") call obsolete_logical(param_file, "USE_VISBECK_SLOPE_BUG", .false.) From ebf11d7c7345f18e81372253b8338b2fad6fa404 Mon Sep 17 00:00:00 2001 From: Keith Lindsay Date: Thu, 23 Mar 2023 19:48:18 -0600 Subject: [PATCH 224/629] migrate nearly all refs to CFC_cap into MOM_tracer_flow_control and MOM_CFC_cap refs moved out of nuopc cap code, MOM_forcing_type, MOM_variables call CFC_cap_set_forcing in call_tracer_set_forcing add call to call_tracer_set_forcing in nuopc cap add arguments to call_tracer_set_forcing increase width in MOM_CFC_cap unit test output correct typo in oil_tracer --- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 17 +- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 56 ---- .../solo_driver/MOM_surface_forcing.F90 | 3 +- src/core/MOM_forcing_type.F90 | 44 +-- src/core/MOM_variables.F90 | 15 +- src/tracer/MOM_CFC_cap.F90 | 256 ++++++++++-------- src/tracer/MOM_tracer_flow_control.F90 | 11 +- src/tracer/oil_tracer.F90 | 2 +- 8 files changed, 166 insertions(+), 238 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 808e6d44d9..e58c2796c8 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -41,7 +41,7 @@ module MOM_ocean_model_nuopc use MOM_time_manager, only : operator(/=), operator(<=), operator(>=) use MOM_time_manager, only : operator(<), real_to_time_type, time_type_to_real use MOM_interpolate, only : time_interp_external_init -use MOM_tracer_flow_control, only : call_tracer_flux_init +use MOM_tracer_flow_control, only : tracer_flow_control_CS, call_tracer_flux_init, call_tracer_set_forcing use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type @@ -210,6 +210,8 @@ module MOM_ocean_model_nuopc type(marine_ice_CS), pointer :: & marine_ice_CSp => NULL() !< A pointer to the control structure for the !! marine ice effects module. + type(tracer_flow_control_CS), pointer :: & + tracer_flow_CSp => NULL() !< A pointer to the tracer flow control structure type(wave_parameters_CS), pointer, public :: & Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & @@ -255,7 +257,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. logical :: use_melt_pot !< If true, allocate melt_potential array - logical :: use_CFC !< If true, allocated arrays for surface CFCs. ! This include declares and sets the variable "version". @@ -283,7 +284,8 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & - diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) + diag_ptr=OS%diag, count_calls=.true., tracer_flow_CSp=OS%tracer_flow_CSp, & + waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) @@ -375,8 +377,6 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i use_melt_pot=.false. endif - call get_param(param_file, mdl, "USE_CFC_CAP", use_CFC, & - default=.false., do_not_log=.true.) call get_param(param_file, mdl, "USE_WAVES", OS%Use_Waves, & "If true, enables surface wave modules.", default=.false.) @@ -384,7 +384,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! vertical integrals, since the related 3-d sums are not negligible in cost. call allocate_surface_state(OS%sfc_state, OS%grid, use_temperature, & do_integrals=.true., gas_fields_ocn=gas_fields_ocn, & - use_meltpot=use_melt_pot, use_cfcs=use_CFC) + use_meltpot=use_melt_pot) call surface_forcing_init(Time_in, OS%grid, OS%US, param_file, OS%diag, & OS%forcing_CSp, OS%restore_salinity, OS%restore_temp, OS%use_waves) @@ -610,6 +610,11 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) endif + if (do_thermo) & + call call_tracer_set_forcing(OS%sfc_state, OS%fluxes, OS%Time, & + real_to_time_type(dt_coupling), OS%grid, OS%US, OS%GV%Rho0, & + OS%tracer_flow_CSp) + call disable_averaging(OS%diag) Master_time = OS%Time ; Time1 = OS%Time 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 27324efa56..30c54e6c4f 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -26,7 +26,6 @@ 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_CFC_cap, only : CFC_cap_fluxes 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 @@ -129,7 +128,6 @@ module MOM_surface_forcing_nuopc type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing character(len=200) :: inputdir !< directory where NetCDF input files are - character(len=200) :: CFC_BC_file !< filename with cfc11 and cfc12 data character(len=200) :: salt_restore_file !< filename for salt restoring data character(len=30) :: salt_restore_var_name !< name of surface salinity in salt_restore_file logical :: mask_srestore !< if true, apply a 2-dimensional mask to the surface @@ -146,11 +144,6 @@ module MOM_surface_forcing_nuopc 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 :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file - integer :: id_cfc11_atm_nh = -1 !< id number for time_interp_external. - integer :: id_cfc11_atm_sh = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm_nh = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm_sh = -1 !< id number for time_interp_external. ! Diagnostics handles type(forcing_diags), public :: handles @@ -593,13 +586,6 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, fluxes%accumulate_p_surf = .true. ! Multiple components may contribute to surface pressure. endif - ! CFCs - if (CS%use_CFC) then - call CFC_cap_fluxes(fluxes, sfc_state, G, US, CS%Rho0, Time, CS%CFC_BC_year_offset, & - CS%id_cfc11_atm_nh, CS%id_cfc11_atm_sh, & - CS%id_cfc12_atm_nh, CS%id_cfc12_atm_sh) - endif - if (associated(IOB%salt_flux)) then do j=js,je ; do i=is,ie fluxes%salt_flux(i,j) = G%mask2dT(i,j)*(fluxes%salt_flux(i,j) + kg_m2_s_conversion*IOB%salt_flux(i-i0,j-j0)) @@ -1117,13 +1103,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, character(len=48) :: stagger character(len=48) :: flnam character(len=240) :: basin_file - character(len=30) :: cfc11_nh_var_name ! name of cfc11 nh in CFC_BC_file - character(len=30) :: cfc11_sh_var_name ! name of cfc11 sh in CFC_BC_file - character(len=30) :: cfc12_nh_var_name ! name of cfc12 nh in CFC_BC_file - character(len=30) :: cfc12_sh_var_name ! name of cfc12 sh in CFC_BC_file integer :: i, j, isd, ied, jsd, jed - integer :: CFC_BC_data_year ! specific year in CFC BC data calendar - integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -1419,42 +1399,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, endif endif ; endif - ! Do not log these params here since they are logged in the CFC cap module - if (CS%use_CFC) then - call get_param(param_file, mdl, "CFC_BC_FILE", CS%CFC_BC_file, & - "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& - "found (units must be parts per trillion).", default=" ", do_not_log=.true.) - if (len_trim(CS%CFC_BC_file) == 0) then - call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") - endif - if (scan(CS%CFC_BC_file, '/') == 0) then - ! Add the directory if CFC_BC_file is not already a complete path. - CS%CFC_BC_file = trim(CS%inputdir)//trim(CS%CFC_BC_file) - endif - call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & - "Specific year in CFC_BC_FILE data calendar", default=2000, do_not_log=.true.) - call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & - "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000, do_not_log=.true.) - CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year - call get_param(param_file, mdl, "CFC11_NH_VARIABLE", cfc11_nh_var_name, & - "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & - default="cfc11_nh", do_not_log=.true.) - call get_param(param_file, mdl, "CFC11_SH_VARIABLE", cfc11_sh_var_name, & - "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & - default="cfc11_sh", do_not_log=.true.) - call get_param(param_file, mdl, "CFC12_NH_VARIABLE", cfc12_nh_var_name, & - "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & - default="cfc12_nh", do_not_log=.true.) - call get_param(param_file, mdl, "CFC12_SH_VARIABLE", cfc12_sh_var_name, & - "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & - default="cfc12_sh", do_not_log=.true.) - - CS%id_cfc11_atm_nh = init_external_field(CS%CFC_BC_file, cfc11_nh_var_name) - CS%id_cfc11_atm_sh = init_external_field(CS%CFC_BC_file, cfc11_sh_var_name) - CS%id_cfc12_atm_nh = init_external_field(CS%CFC_BC_file, cfc12_nh_var_name) - CS%id_cfc12_atm_sh = init_external_field(CS%CFC_BC_file, cfc12_sh_var_name) - endif - ! Set up any restart fields associated with the forcing. call restart_init(param_file, CS%restart_CSp, "MOM_forcing.res") call restart_init_end(CS%restart_CSp) diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index c1e125be83..1d72dc8eb6 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -345,7 +345,8 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US endif if (associated(CS%tracer_flow_CSp)) then - call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS%tracer_flow_CSp) + call call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, CS%Rho0, & + CS%tracer_flow_CSp) endif ! Allow for user-written code to alter the fluxes after all the above diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 4365dd6296..e7fc638e15 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -191,10 +191,8 @@ module MOM_forcing_type real :: C_p !< heat capacity of seawater [Q C-1 ~> J kg-1 degC-1]. !! C_p is is the same value as in thermovar_ptrs_type. - ! CFC-related arrays needed in the MOM_CFC_cap module + ! arrays needed in the some tracer modules, e.g., MOM_CFC_cap real, pointer, dimension(:,:) :: & - cfc11_flux => NULL(), & !< flux of cfc_11 into the ocean [CU R Z T-1 ~> mol m-2 s-1] - cfc12_flux => NULL(), & !< flux of cfc_12 into the ocean [CU R Z T-1 ~> mol m-2 s-1] ice_fraction => NULL(), & !< fraction of sea ice coverage at h-cells, from 0 to 1 [nondim]. u10_sqr => NULL() !< wind magnitude at 10 m squared [L2 T-2 ~> m2 s-2] @@ -364,9 +362,7 @@ module MOM_forcing_type integer :: id_TKE_tidal = -1 integer :: id_buoy = -1 - ! cfc-related diagnostics handles - integer :: id_cfc11 = -1 - integer :: id_cfc12 = -1 + ! tracer surface flux related diagnostics handles integer :: id_ice_fraction = -1 integer :: id_u10_sqr = -1 @@ -1129,10 +1125,6 @@ subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) call hchksum(fluxes%u10_sqr, mesg//" fluxes%u10_sqr", G%HI, haloshift=hshift, scale=US%L_to_m**2*US%s_to_T**2) if (associated(fluxes%ice_fraction)) & call hchksum(fluxes%ice_fraction, mesg//" fluxes%ice_fraction", G%HI, haloshift=hshift) - if (associated(fluxes%cfc11_flux)) & - call hchksum(fluxes%cfc11_flux, mesg//" fluxes%cfc11_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) - if (associated(fluxes%cfc12_flux)) & - call hchksum(fluxes%cfc12_flux, mesg//" fluxes%cfc12_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%salt_flux)) & call hchksum(fluxes%salt_flux, mesg//" fluxes%salt_flux", G%HI, haloshift=hshift, scale=US%RZ_T_to_kg_m2s) if (associated(fluxes%TKE_tidal)) & @@ -1340,26 +1332,9 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, endif endif - ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] ! See: - ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html - ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html if (present(use_cfcs)) then if (use_cfcs) then - handles%id_cfc11 = register_diag_field('ocean_model', 'cfc11_flux', diag%axesT1, Time, & - 'Gas exchange flux of CFC11 into the ocean ', & - 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - cmor_field_name='fgcfc11', & - cmor_long_name='Surface Downward CFC11 Flux', & - cmor_standard_name='surface_downward_cfc11_flux') - - handles%id_cfc12 = register_diag_field('ocean_model', 'cfc12_flux', diag%axesT1, Time, & - 'Gas exchange flux of CFC12 into the ocean ', & - 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & - cmor_field_name='fgcfc12', & - cmor_long_name='Surface Downward CFC12 Flux', & - cmor_standard_name='surface_downward_cfc12_flux') - handles%id_ice_fraction = register_diag_field('ocean_model', 'ice_fraction', diag%axesT1, Time, & 'Fraction of cell area covered by sea ice', 'm2 m-2') @@ -2921,13 +2896,7 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if (handles%id_netFWGlobalScl > 0) & call post_data(handles%id_netFWGlobalScl, fluxes%netFWGlobalScl, diag) - ! post diagnostics related to cfcs ==================================== - - if ((handles%id_cfc11 > 0) .and. associated(fluxes%cfc11_flux)) & - call post_data(handles%id_cfc11, fluxes%cfc11_flux, diag) - - if ((handles%id_cfc11 > 0) .and. associated(fluxes%cfc12_flux)) & - call post_data(handles%id_cfc12, fluxes%cfc12_flux, diag) + ! post diagnostics related to tracer surface fluxes ======================== if ((handles%id_ice_fraction > 0) .and. associated(fluxes%ice_fraction)) & call post_data(handles%id_ice_fraction, fluxes%ice_fraction, diag) @@ -2989,7 +2958,8 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & logical, optional, intent(in) :: salt !< If present and true, allocate salt fluxes logical, optional, intent(in) :: fix_accum_bug !< If present and true, avoid using a bug in !! accumulation of ustar_gustless - logical, optional, intent(in) :: cfc !< If present and true, allocate cfc fluxes + logical, optional, intent(in) :: cfc !< If present and true, allocate fields needed + !! for cfc surface fluxes logical, optional, intent(in) :: waves !< If present and true, allocate wave fields logical, optional, intent(in) :: shelf_sfc_accumulation !< If present and true, and shelf is true, !! then allocate surface flux deposition from the atmosphere @@ -3064,8 +3034,6 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%mass_berg,isd,ied,jsd,jed, iceberg) !These fields should only on allocated when USE_CFC_CAP is activated. - call myAlloc(fluxes%cfc11_flux,isd,ied,jsd,jed, cfc) - call myAlloc(fluxes%cfc12_flux,isd,ied,jsd,jed, cfc) call myAlloc(fluxes%ice_fraction,isd,ied,jsd,jed, cfc) call myAlloc(fluxes%u10_sqr,isd,ied,jsd,jed, cfc) @@ -3322,8 +3290,6 @@ subroutine deallocate_forcing_type(fluxes) if (associated(fluxes%mass_berg)) deallocate(fluxes%mass_berg) if (associated(fluxes%ice_fraction)) deallocate(fluxes%ice_fraction) if (associated(fluxes%u10_sqr)) deallocate(fluxes%u10_sqr) - if (associated(fluxes%cfc11_flux)) deallocate(fluxes%cfc11_flux) - if (associated(fluxes%cfc12_flux)) deallocate(fluxes%cfc12_flux) call coupler_type_destructor(fluxes%tr_fluxes) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 8279afa954..b586d09a09 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -44,8 +44,6 @@ module MOM_variables SST, & !< The sea surface temperature [C ~> degC]. SSS, & !< The sea surface salinity [S ~> psu or gSalt/kg]. sfc_density, & !< The mixed layer density [R ~> kg m-3]. - sfc_cfc11, & !< Sea surface concentration of CFC11 [mol kg-1]. - sfc_cfc12, & !< Sea surface concentration of CFC12 [mol kg-1]. Hml, & !< The mixed layer depth [Z ~> m]. u, & !< The mixed layer zonal velocity [L T-1 ~> m s-1]. v, & !< The mixed layer meridional velocity [L T-1 ~> m s-1]. @@ -328,7 +326,7 @@ module MOM_variables !! the ocean model. Unused fields are unallocated. subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & gas_fields_ocn, use_meltpot, use_iceshelves, & - omit_frazil, use_cfcs) + omit_frazil) type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(surface), intent(inout) :: sfc_state !< ocean surface state type to be allocated. logical, optional, intent(in) :: use_temperature !< If true, allocate the space for thermodynamic variables. @@ -341,14 +339,13 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. logical, optional, intent(in) :: use_meltpot !< If true, allocate the space for melt potential - logical, optional, intent(in) :: use_cfcs !< If true, allocate the space for cfcs logical, optional, intent(in) :: use_iceshelves !< If true, allocate the space for the stresses !! under ice shelves. logical, optional, intent(in) :: omit_frazil !< If present and false, do not allocate the space to !! pass frazil fluxes to the coupler ! local variables - logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil, alloc_cfcs + logical :: use_temp, alloc_integ, use_melt_potential, alloc_iceshelves, alloc_frazil integer :: is, ie, js, je, isd, ied, jsd, jed integer :: isdB, iedB, jsdB, jedB @@ -359,7 +356,6 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & use_temp = .true. ; if (present(use_temperature)) use_temp = use_temperature alloc_integ = .true. ; if (present(do_integrals)) alloc_integ = do_integrals use_melt_potential = .false. ; if (present(use_meltpot)) use_melt_potential = use_meltpot - alloc_cfcs = .false. ; if (present(use_cfcs)) alloc_cfcs = use_cfcs alloc_iceshelves = .false. ; if (present(use_iceshelves)) alloc_iceshelves = use_iceshelves alloc_frazil = .true. ; if (present(omit_frazil)) alloc_frazil = .not.omit_frazil @@ -383,11 +379,6 @@ subroutine allocate_surface_state(sfc_state, G, use_temperature, do_integrals, & allocate(sfc_state%melt_potential(isd:ied,jsd:jed), source=0.0) endif - if (alloc_cfcs) then - allocate(sfc_state%sfc_cfc11(isd:ied,jsd:jed), source=0.0) - allocate(sfc_state%sfc_cfc12(isd:ied,jsd:jed), source=0.0) - endif - if (alloc_integ) then ! Allocate structures for the vertically integrated ocean_mass, ocean_heat, and ocean_salt. allocate(sfc_state%ocean_mass(isd:ied,jsd:jed), source=0.0) @@ -427,8 +418,6 @@ subroutine deallocate_surface_state(sfc_state) if (allocated(sfc_state%ocean_mass)) deallocate(sfc_state%ocean_mass) if (allocated(sfc_state%ocean_heat)) deallocate(sfc_state%ocean_heat) if (allocated(sfc_state%ocean_salt)) deallocate(sfc_state%ocean_salt) - if (allocated(sfc_state%sfc_cfc11)) deallocate(sfc_state%sfc_cfc11) - if (allocated(sfc_state%sfc_cfc12)) deallocate(sfc_state%sfc_cfc12) call coupler_type_destructor(sfc_state%tr_fields) sfc_state%arrays_allocated = .false. diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 427ea1ed9a..4364dac0fd 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -5,6 +5,7 @@ module MOM_CFC_cap ! This file is part of MOM6. See LICENSE.md for the license. use MOM_coms, only : EFP_type +use MOM_debugging, only : hchksum use MOM_diag_mediator, only : diag_ctrl, register_diag_field, post_data use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type @@ -25,7 +26,7 @@ module MOM_CFC_cap use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -33,24 +34,29 @@ module MOM_CFC_cap #include public register_CFC_cap, initialize_CFC_cap, CFC_cap_unit_tests -public CFC_cap_column_physics, CFC_cap_surface_state, CFC_cap_fluxes +public CFC_cap_column_physics, CFC_cap_set_forcing public CFC_cap_stock, CFC_cap_end integer, parameter :: NTR = 2 !< the number of tracers in this module. -!> Contains the concentration array, a pointer to Tr in Tr_reg, and some metadata for a single CFC tracer +!> Contains the concentration array, surface flux, a pointer to Tr in Tr_reg, +!! and some metadata for a single CFC tracer type, private :: CFC_tracer_data - type(vardesc) :: desc !< A set of metadata for the tracer - real :: IC_val = 0.0 !< The initial value assigned to the tracer [mol kg-1]. - real :: land_val = -1.0 !< The value of the tracer used where land is masked out [mol kg-1]. - character(len=32) :: name !< Tracer variable name - integer :: id_cmor !< Diagnostic ID - real, pointer, dimension(:,:,:) :: conc !< The tracer concentration [mol kg-1]. - type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg - end type CFC_tracer_data + type(vardesc) :: desc !< A set of metadata for the tracer + real :: IC_val = 0.0 !< The initial value assigned to the tracer [mol kg-1]. + real :: land_val = -1.0 !< The value of the tracer used where land is + !! masked out [mol kg-1]. + character(len=32) :: name !< Tracer variable name + integer :: id_cmor = -1 !< Diagnostic id + integer :: id_sfc_flux = -1 !< Surface flux id + real, pointer, dimension(:,:,:) :: conc !< The tracer concentration [mol kg-1]. + real, pointer, dimension(:,:) :: sfc_flux !< Surface flux [CU R Z T-1 ~> mol m-2 s-1] + type(tracer_type), pointer :: tr_ptr !< pointer to tracer inside Tr_reg +end type CFC_tracer_data !> The control structure for the CFC_cap tracer package type, public :: CFC_cap_CS ; private + logical :: debug !< If true, write verbose checksums for debugging purposes. character(len=200) :: IC_file !< The file in which the CFC initial values can !! be found, or an empty string for internal initilaization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. @@ -62,7 +68,12 @@ module MOM_CFC_cap !! the timing of diagnostic output. type(MOM_restart_CS), pointer :: restart_CSp => NULL() !< Model restart control structure - type(CFC_tracer_data), dimension(2) :: CFC_data !< per-tracer parameters / metadata + type(CFC_tracer_data), dimension(NTR) :: CFC_data !< per-tracer parameters / metadata + integer :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file + integer :: id_cfc11_atm_nh = -1 !< id number for time_interp_external. + integer :: id_cfc11_atm_sh = -1 !< id number for time_interp_external. + integer :: id_cfc12_atm_nh = -1 !< id number for time_interp_external. + integer :: id_cfc12_atm_sh = -1 !< id number for time_interp_external. end type CFC_cap_CS contains @@ -81,15 +92,17 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Local variables character(len=40) :: mdl = "MOM_CFC_cap" ! This module's name. - character(len=200) :: inputdir ! The directory where NetCDF input files are. ! This include declares and sets the variable "version". # include "version_variable.h" + character(len=200) :: inputdir ! The directory where NetCDF input files are. real, dimension(:,:,:), pointer :: tr_ptr => NULL() - character(len=200) :: dummy ! Dummy variable to store params that need to be logged here. - integer :: dummy_int ! Dummy variable to store params that need to be logged here. + character(len=200) :: CFC_BC_file ! filename with cfc11 and cfc12 data + character(len=30) :: CFC_BC_var_name ! varname of field in CFC_BC_file character :: m2char logical :: register_CFC_cap integer :: isd, ied, jsd, jed, nz, m + integer :: CFC_BC_data_year ! specific year in CFC BC data calendar + integer :: CFC_BC_model_year ! model year corresponding to CFC_BC_data_year isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -101,6 +114,9 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) call get_param(param_file, mdl, "CFC_IC_FILE", CS%IC_file, & "The file in which the CFC initial values can be "//& "found, or an empty string for internal initialization.", & @@ -120,7 +136,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) "if they are not found in the restart files. Otherwise "//& "it is a fatal error if tracers are not found in the "//& "restart files of a restarted run.", default=.false.) - do m=1,2 + do m=1,NTR write(m2char, "(I1)") m call get_param(param_file, mdl, "CFC1"//m2char//"_IC_VAL", CS%CFC_data(m)%IC_val, & "Value that CFC_1"//m2char//" is set to when it is not read from a file.", & @@ -129,41 +145,49 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! the following params are not used in this module. Instead, they are used in ! the cap but are logged here to keep all the CFC cap params together. - call get_param(param_file, mdl, "CFC_BC_FILE", dummy, & + call get_param(param_file, mdl, "CFC_BC_FILE", CFC_BC_file, & "The file in which the CFC-11 and CFC-12 atm concentrations can be "//& "found (units must be parts per trillion).", default=" ") - if (len_trim(dummy) == 0) then + if (len_trim(CFC_BC_file) == 0) then call MOM_error(FATAL, "CFC_BC_FILE must be specified if USE_CFC_CAP=.true.") endif - if (scan(dummy, '/') == 0) then - ! Add the directory if dummy is not already a complete path. + if (scan(CFC_BC_file, '/') == 0) then + ! Add the directory if CFC_BC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") - dummy = trim(slasher(inputdir))//trim(dummy) - call log_param(param_file, mdl, "INPUTDIR/CFC_BC_FILE", dummy, & + CFC_BC_file = trim(slasher(inputdir))//trim(CFC_BC_file) + call log_param(param_file, mdl, "INPUTDIR/CFC_BC_FILE", CFC_BC_file, & "full path of CFC_BC_FILE") endif - if (len_trim(dummy) > 0) then - call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", dummy_int, & + + call get_param(param_file, mdl, "CFC_BC_DATA_YEAR", CFC_BC_data_year, & "Specific year in CFC_BC_FILE data calendar", default=2000) - call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", dummy_int, & + call get_param(param_file, mdl, "CFC_BC_MODEL_YEAR", CFC_BC_model_year, & "Model year corresponding to CFC_BC_MODEL_YEAR", default=2000) - call get_param(param_file, mdl, "CFC11_NH_VARIABLE", dummy, & - "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & - default="cfc11_nh") - call get_param(param_file, mdl, "CFC11_SH_VARIABLE", dummy, & - "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & - default="cfc11_sh") - call get_param(param_file, mdl, "CFC12_NH_VARIABLE", dummy, & - "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & - default="cfc12_nh") - call get_param(param_file, mdl, "CFC12_SH_VARIABLE", dummy, & - "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & - default="cfc12_sh") - endif + CS%CFC_BC_year_offset = CFC_BC_data_year - CFC_BC_model_year + + call get_param(param_file, mdl, "CFC11_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_nh") + CS%id_cfc11_atm_nh = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC11_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & + default="cfc11_sh") + CS%id_cfc11_atm_sh = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_NH_VARIABLE", CFC_BC_var_name, & + "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_nh") + CS%id_cfc12_atm_nh = init_external_field(CFC_BC_file, CFC_BC_var_name) + + call get_param(param_file, mdl, "CFC12_SH_VARIABLE", CFC_BC_var_name, & + "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & + default="cfc12_sh") + CS%id_cfc12_atm_sh = init_external_field(CFC_BC_file, CFC_BC_var_name) ! The following vardesc types contain a package of metadata about each tracer, ! including, the name; units; longname; and grid information. - do m=1,2 + do m=1,NTR write(m2char, "(I1)") m write(CS%CFC_data(m)%name, "(2A)") "CFC_1", m2char CS%CFC_data(m)%desc = var_desc(CS%CFC_data(m)%name, & @@ -172,6 +196,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) caller=mdl) allocate(CS%CFC_data(m)%conc(isd:ied,jsd:jed,nz), source=0.0) + allocate(CS%CFC_data(m)%sfc_flux(isd:ied,jsd:jed), source=0.0) ! This pointer assignment is needed to force the compiler not to do a copy in ! the registration calls. Curses on the designers and implementers of F90. @@ -216,7 +241,7 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) CS%Time => day CS%diag => diag - do m=1,2 + do m=1,NTR if (.not.restart .or. (CS%tracers_may_reinit .and. & .not.query_initialized(CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%restart_CSp))) then call init_tracer_CFC(h, CS%CFC_data(m)%conc, CS%CFC_data(m)%name, CS%CFC_data(m)%land_val, & @@ -225,11 +250,23 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) endif ! cmor diagnostics + ! units for cfc11_flux and cfc12_flux are [Conc R Z T-1 ~> mol m-2 s-1] ! CFC11 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/42625c97b8fe75124a345962c4430982.html + ! http://clipc-services.ceda.ac.uk/dreq/u/0940cbee6105037e4b7aa5579004f124.html ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html + ! http://clipc-services.ceda.ac.uk/dreq/u/e9e21426e4810d0bb2d3dddb24dbf4dc.html write(m2char, "(I1)") m - CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', 'cfc1'//m2char, diag%axesTL, day, & - 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3') + CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', & + 'cfc1'//m2char, diag%axesTL, day, & + 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3') + + CS%CFC_data(m)%id_sfc_flux = register_diag_field('ocean_model', & + 'cfc1'//m2char//'_flux', diag%axesT1, day, & + 'Gas exchange flux of CFC1'//m2char//' into the ocean ', & + 'mol m-2 s-1', conversion=US%RZ_T_to_kg_m2s, & + cmor_field_name='fgcfc1'//m2char, & + cmor_long_name='Surface Downward CFC1'//m2char//' Flux', & + cmor_standard_name='surface_downward_cfc1'//m2char//'_flux') enddo @@ -323,7 +360,7 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] real :: flux_scale - integer :: i, j, k, is, ie, js, je, nz + integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -334,43 +371,43 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C if (associated(KPP_CSp) .and. present(nonLocalTrans)) then flux_scale = GV%Z_to_H / GV%rho0 - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc11_flux(:,:), dt, CS%diag, & - CS%CFC_data(1)%tr_ptr, CS%CFC_data(1)%conc(:,:,:), & - flux_scale=flux_scale) - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc12_flux(:,:), dt, CS%diag, & - CS%CFC_data(2)%tr_ptr, CS%CFC_data(2)%conc(:,:,:), & - flux_scale=flux_scale) + do m=1,NTR + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, & + CS%CFC_data(m)%sfc_flux(:,:), dt, CS%diag, & + CS%CFC_data(m)%tr_ptr, CS%CFC_data(m)%conc(:,:,:), & + flux_scale=flux_scale) + enddo endif endif ! Use a tridiagonal solver to determine the concentrations after the ! surface source is applied and diapycnal advection and diffusion occurs. if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then - do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(1)%conc, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(1)%conc, G, GV, sfc_flux=fluxes%cfc11_flux) - - do k=1,nz ;do j=js,je ; do i=is,ie - h_work(i,j,k) = h_old(i,j,k) - enddo ; enddo ; enddo - call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(2)%conc, dt, fluxes, h_work, & - evap_CFL_limit, minimum_forcing_depth) - call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(2)%conc, G, GV, sfc_flux=fluxes%cfc12_flux) + do m=1,NTR + do k=1,nz ;do j=js,je ; do i=is,ie + h_work(i,j,k) = h_old(i,j,k) + enddo ; enddo ; enddo + call applyTracerBoundaryFluxesInOut(G, GV, CS%CFC_data(m)%conc, dt, fluxes, h_work, & + evap_CFL_limit, minimum_forcing_depth) + call tracer_vertdiff(h_work, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo else - call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(1)%conc, G, GV, sfc_flux=fluxes%cfc11_flux) - call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(2)%conc, G, GV, sfc_flux=fluxes%cfc12_flux) + do m=1,NTR + call tracer_vertdiff(h_old, ea, eb, dt, CS%CFC_data(m)%conc, G, GV, & + sfc_flux=CS%CFC_data(m)%sfc_flux) + enddo endif ! If needed, write out any desired diagnostics from tracer sources & sinks here. - if (CS%CFC_data(1)%id_cmor > 0) call post_data(CS%CFC_data(1)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(1)%conc, & - CS%diag) - if (CS%CFC_data(2)%id_cmor > 0) call post_data(CS%CFC_data(2)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(2)%conc, & - CS%diag) + do m=1,NTR + if (CS%CFC_data(m)%id_cmor > 0) & + call post_data(CS%CFC_data(m)%id_cmor, & + (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(m)%conc, CS%diag) + + if (CS%CFC_data(m)%id_sfc_flux > 0) & + call post_data(CS%CFC_data(m)%id_sfc_flux, CS%CFC_data(m)%sfc_flux, CS%diag) + enddo end subroutine CFC_cap_column_physics @@ -409,58 +446,32 @@ function CFC_cap_stock(h, stocks, G, GV, CS, names, units, stock_index) return endif ; endif - do m=1,2 + do m=1,NTR call query_vardesc(CS%CFC_data(m)%desc, name=names(m), units=units(m), caller="CFC_cap_stock") units(m) = trim(units(m))//" kg" stocks(m) = global_mass_int_EFP(h, G, GV, CS%CFC_data(m)%conc, on_PE_only=.true.) enddo - CFC_cap_stock = 2 + CFC_cap_stock = NTR end function CFC_cap_stock -!> Extracts the ocean surface CFC concentrations and copies them to sfc_state. -subroutine CFC_cap_surface_state(sfc_state, G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(surface), intent(inout) :: sfc_state !< A structure containing fields that - !! describe the surface state of the ocean. - type(CFC_cap_CS), pointer :: CS!< The control structure returned by a previous - !! call to register_CFC_cap. - - ! Local variables - integer :: i, j, is, ie, js, je - - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - - if (.not.associated(CS)) return - - do j=js,je ; do i=is,ie - sfc_state%sfc_cfc11(i,j) = CS%CFC_data(1)%conc(i,j,1) - sfc_state%sfc_cfc12(i,j) = CS%CFC_data(2)%conc(i,j,1) - enddo ; enddo - -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, CFC_BC_year_offset, & - id_cfc11_atm_nh, id_cfc11_atm_sh, id_cfc12_atm_nh, id_cfc12_atm_sh) - type(ocean_grid_type), intent(in ) :: G !< The ocean's grid structure. - type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type +subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) type(surface), intent(in ) :: sfc_state !< A structure containing fields !! that describe the surface state of the ocean. type(forcing), intent(inout) :: fluxes !< A structure containing pointers !! to thermodynamic and tracer forcing fields. Unused fields !! have NULL ptrs. - 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, intent(in ) :: CFC_BC_year_offset !< offset to add to model time to get - !! time value used in CFC_BC_file - integer, intent(inout) :: id_cfc11_atm_nh !< id number for time_interp_external. - integer, intent(inout) :: id_cfc11_atm_sh !< id number for time_interp_external. - integer, intent(inout) :: id_cfc12_atm_nh !< id number for time_interp_external. - integer, intent(inout) :: id_cfc12_atm_sh !< id number for time_interp_external. + type(time_type), intent(in) :: day_start !< Start time of the fluxes. + type(time_type), intent(in) :: day_interval !< Length of time over which these + !! fluxes will be applied. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + !! previous call to register_CFC_cap. ! Local variables type(time_type) :: Time_external ! time value used in CFC_BC_file @@ -483,22 +494,23 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, CFC_BC_year_offs real :: kw_coeff ! A coefficient used to compute the piston velocity [Z T-1 T2 L-2 = Z T L-2 ~> s / m] real, parameter :: pa_to_atm = 9.8692316931427e-6 ! factor for converting from Pa to atm [atm Pa-1]. real :: press_to_atm ! converts from model pressure units to atm [atm T2 R-1 L-2 ~> atm Pa-1] - integer :: i, j, is, ie, js, je + integer :: i, j, is, ie, js, je, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Time_external = increment_date(Time, years=CFC_BC_year_offset) + ! Time_external = increment_date(day_start + day_interval/2, years=CS%CFC_BC_year_offset) + Time_external = increment_date(day_start, years=CS%CFC_BC_year_offset) ! CFC11 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol - call time_interp_external(id_cfc11_atm_nh, Time_external, cfc11_atm_nh) + call time_interp_external(CS%id_cfc11_atm_nh, Time_external, cfc11_atm_nh) cfc11_atm_nh = cfc11_atm_nh * 1.0e-12 - call time_interp_external(id_cfc11_atm_sh, Time_external, cfc11_atm_sh) + call time_interp_external(CS%id_cfc11_atm_sh, Time_external, cfc11_atm_sh) cfc11_atm_sh = cfc11_atm_sh * 1.0e-12 ! CFC12 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol - call time_interp_external(id_cfc12_atm_nh, Time_external, cfc12_atm_nh) + call time_interp_external(CS%id_cfc12_atm_nh, Time_external, cfc12_atm_nh) cfc12_atm_nh = cfc12_atm_nh * 1.0e-12 - call time_interp_external(id_cfc12_atm_sh, Time_external, cfc12_atm_sh) + call time_interp_external(CS%id_cfc12_atm_sh, Time_external, cfc12_atm_sh) cfc12_atm_sh = cfc12_atm_sh * 1.0e-12 !--------------------------------------------------------------------- @@ -544,14 +556,21 @@ subroutine CFC_cap_fluxes(fluxes, sfc_state, G, US, Rho0, Time, CFC_BC_year_offs ! CFC flux units: CU R Z T-1 = mol kg-1 R Z T-1 ~> mol m-2 s-1 kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_11) cair(i,j) = press_to_atm * alpha_11 * cfc11_atm(i,j) * fluxes%p_surf_full(i,j) - fluxes%cfc11_flux(i,j) = kw(i,j) * (cair(i,j) - sfc_state%sfc_CFC11(i,j)) * Rho0 + CS%CFC_data(1)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(1)%conc(i,j,1)) * Rho0 kw(i,j) = kw_wo_sc_no_term(i,j) * sqrt(660.0 / sc_12) cair(i,j) = press_to_atm * alpha_12 * cfc12_atm(i,j) * fluxes%p_surf_full(i,j) - fluxes%cfc12_flux(i,j) = kw(i,j) * (cair(i,j) - sfc_state%sfc_CFC12(i,j)) * Rho0 + CS%CFC_data(2)%sfc_flux(i,j) = kw(i,j) * (cair(i,j) - CS%CFC_data(2)%conc(i,j,1)) * Rho0 enddo ; enddo -end subroutine CFC_cap_fluxes + if (CS%debug) then + do m=1,NTR + call hchksum(CS%CFC_data(m)%sfc_flux, trim(CS%CFC_data(m)%name)//" sfc_flux", G%HI, & + scale=US%RZ_T_to_kg_m2s) + enddo + endif + +end subroutine CFC_cap_set_forcing !> Calculates the CFC's solubility function following Warner and Weiss (1985) DSR, vol 32. subroutine get_solubility(alpha_11, alpha_12, ta, sal , mask) @@ -638,8 +657,9 @@ subroutine CFC_cap_end(CS) integer :: m if (associated(CS)) then - do m=1,2 + do m=1,NTR if (associated(CS%CFC_data(m)%conc)) deallocate(CS%CFC_data(m)%conc) + if (associated(CS%CFC_data(m)%sfc_flux)) deallocate(CS%CFC_data(m)%sfc_flux) enddo deallocate(CS) @@ -716,7 +736,7 @@ logical function compare_values(verbose, test_name, calc, ans, limit) write(stdout,10) calc, ans endif -10 format("calc=",f20.16," ans",f20.16) +10 format("calc=",f22.16," ans",f22.16) end function compare_values !> \namespace mom_CFC_cap diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index f4794921e3..58bada441f 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -45,7 +45,7 @@ module MOM_tracer_flow_control use MOM_OCMIP2_CFC, only : OCMIP2_CFC_column_physics, OCMIP2_CFC_surface_state use MOM_OCMIP2_CFC, only : OCMIP2_CFC_stock, OCMIP2_CFC_end, OCMIP2_CFC_CS use MOM_CFC_cap, only : register_CFC_cap, initialize_CFC_cap -use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_surface_state +use MOM_CFC_cap, only : CFC_cap_column_physics, CFC_cap_set_forcing use MOM_CFC_cap, only : CFC_cap_stock, CFC_cap_end, CFC_cap_CS use oil_tracer, only : register_oil_tracer, initialize_oil_tracer use oil_tracer, only : oil_tracer_column_physics, oil_tracer_surface_state @@ -379,7 +379,7 @@ end subroutine get_chl_from_model !> This subroutine calls the individual tracer modules' subroutines to !! specify or read quantities related to their surface forcing. -subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, CS) +subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, CS) type(surface), intent(inout) :: sfc_state !< A structure containing fields that !! describe the surface state of the @@ -391,6 +391,8 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G type(time_type), intent(in) :: day_interval !< Length of time over which these !! fluxes will be applied. type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, intent(in) :: Rho0 !< The mean ocean density [R ~> kg m-3] type(tracer_flow_control_CS), pointer :: CS !< The control structure returned by a !! previous call to call_tracer_register. @@ -399,6 +401,9 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G ! if (CS%use_ideal_age) & ! call ideal_age_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, & ! G, CS%ideal_age_tracer_CSp) + if (CS%use_CFC_cap) & + call CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US, Rho0, & + CS%CFC_cap_CSp) end subroutine call_tracer_set_forcing @@ -821,8 +826,6 @@ subroutine call_tracer_surface_state(sfc_state, h, G, GV, US, CS) call advection_test_tracer_surface_state(sfc_state, h, G, GV, CS%advection_test_tracer_CSp) if (CS%use_OCMIP2_CFC) & call OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS%OCMIP2_CFC_CSp) - if (CS%use_CFC_cap) & - call CFC_cap_surface_state(sfc_state, G, CS%CFC_cap_CSp) if (CS%use_MOM_generic_tracer) & call MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS%MOM_generic_tracer_CSp) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 3fc2537caa..aa365b1c6d 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -113,7 +113,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) ! Add the directory if CS%IC_file is not already a complete path. call get_param(param_file, mdl, "INPUTDIR", inputdir, default=".") CS%IC_file = trim(slasher(inputdir))//trim(CS%IC_file) - call log_param(param_file, mdl, "INPUTDIR/CFC_IC_FILE", CS%IC_file) + call log_param(param_file, mdl, "INPUTDIR/OIL_IC_FILE", CS%IC_file) endif call get_param(param_file, mdl, "OIL_IC_FILE_IS_Z", CS%Z_IC_file, & "If true, OIL_IC_FILE is in depth space, not layer space", & From 37389b5ab832c215df4cdd5a5e23753691980e34 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 26 Mar 2023 13:38:00 -0400 Subject: [PATCH 225/629] Fix indexing bugs in get_field_nc (#334) Fixed two horizontal indexing bugs in `get_field_nc`, where the difference between the array starting index (always 1 in this subroutine) and the values in the handle argument were not being taken into account when the array was being passed in with only its computational domain. Also initialized the internal `unlim_index` array in `get_netcdf_fields` to fix a problem with using an uninitialized array that was being flagged when run in debug mode. With this commit, the model is once again reproducing the expected answers when rescaling is applied for vertical distances or time. Co-authored-by: Marshall Ward --- src/framework/MOM_io.F90 | 9 ++++--- src/framework/MOM_io_file.F90 | 48 ++++++++++++++++++++++------------- src/framework/MOM_netcdf.F90 | 3 +++ 3 files changed, 39 insertions(+), 21 deletions(-) diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 3e90ecd9b1..1026216426 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -2057,15 +2057,16 @@ subroutine MOM_read_data_2d(filename, fieldname, data, MOM_Domain, & end subroutine MOM_read_data_2d -!> Read a 2d array from file using native netCDF I/O. +!> Read a 2d array (which might have halos) from a file using native netCDF I/O. subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & timelevel, position, rescale) character(len=*), intent(in) :: filename !< Input filename character(len=*), intent(in) :: fieldname !< Field variable name - real, intent(out) :: values(:,:) - !< Field value + real, intent(inout) :: values(:,:) + !< Field values read from the file. It would be intent(out) but for the + !! need to preserve any initialized values in the halo regions. type(MOM_domain_type), intent(in) :: MOM_Domain !< Model domain decomposition integer, optional, intent(in) :: timelevel @@ -2073,7 +2074,7 @@ subroutine read_netCDF_data_2d(filename, fieldname, values, MOM_Domain, & integer, optional, intent(in) :: position !< Grid positioning flag real, optional, intent(in) :: rescale - !< Rescale factor + !< Rescale factor, omitting this is the same as setting it to 1. integer :: turns ! Number of quarter-turns from input to model grid diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index 0e60158093..e1613fbbb3 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -1681,15 +1681,18 @@ subroutine read_field_chksum_nc(handle, field, chksum, valid_chksum) end subroutine read_field_chksum_nc -!> Read the values of a netCDF field +!> Read the values of a netCDF field into an array that might have halos subroutine get_field_nc(handle, label, values, rescale) class(MOM_netcdf_file), intent(in) :: handle - ! Handle of netCDF file to be read + !< Handle of netCDF file to be read character(len=*), intent(in) :: label - ! Field variable name - real, intent(out) :: values(:,:) - ! Field values read from file + !< Field variable name + real, intent(inout) :: values(:,:) + !< Field values read from the file. It would be intent(out) but for the + !! need to preserve any initialized values in the halo regions. real, optional, intent(in) :: rescale + !< A multiplicative rescaling factor for the values that are read. + !! Omitting this is the same as setting it to 1. logical :: data_domain ! True if values matches the data domain size @@ -1701,10 +1704,12 @@ subroutine get_field_nc(handle, label, values, rescale) ! Index bounds of compute domain integer :: isd, ied, jsd, jed ! Index bounds of data domain + integer :: iscl, iecl, jscl, jecl + ! Local 1-based index bounds of compute domain integer :: bounds(2,2) ! Index bounds of domain - real, allocatable :: values_nc(:,:) - ! Local copy of field, used for data-decomposed I/O + real, allocatable :: values_c(:,:) + ! Field values on the compute domain, used for copying to a data domain isc = handle%HI%isc iec = handle%HI%iec @@ -1727,36 +1732,45 @@ subroutine get_field_nc(handle, label, values, rescale) field_nc = handle%fields%get(label) - if (data_domain) then - allocate(values_nc(isc:iec,jsc:jec)) - values(:,:) = 0. - endif + if (data_domain) & + allocate(values_c(1:iec-isc+1,1:jec-jsc+1)) if (handle%domain_decomposed) then bounds(1,:) = [isc, jsc] + [handle%HI%idg_offset, handle%HI%jdg_offset] bounds(2,:) = [iec, jec] + [handle%HI%idg_offset, handle%HI%jdg_offset] if (data_domain) then - call read_netcdf_field(handle%handle_nc, field_nc, values_nc, bounds=bounds) + call read_netcdf_field(handle%handle_nc, field_nc, values_c, bounds=bounds) else call read_netcdf_field(handle%handle_nc, field_nc, values, bounds=bounds) endif else if (data_domain) then - call read_netcdf_field(handle%handle_nc, field_nc, values_nc) + call read_netcdf_field(handle%handle_nc, field_nc, values_c) else call read_netcdf_field(handle%handle_nc, field_nc, values) endif endif - if (data_domain) & - values(isc:iec,jsc:jec) = values_nc(:,:) + if (data_domain) then + iscl = isc - isd + 1 + iecl = iec - isd + 1 + jscl = jsc - jsd + 1 + jecl = jec - jsd + 1 + + values(iscl:iecl,jscl:jecl) = values_c(:,:) + else + iscl = 1 + iecl = iec - isc + 1 + jscl = 1 + jecl = jec - jsc + 1 + endif ! NOTE: It is more efficient to do the rescale in-place while copying - ! values_nc(:,:) to values(:,:). But since rescale is only present for + ! values_c(:,:) to values(:,:). But since rescale is only present for ! debugging, we can probably disregard this impact on performance. if (present(rescale)) then if (rescale /= 1.0) then - values(isc:iec,jsc:jec) = rescale * values(isc:iec,jsc:jec) + values(iscl:iecl,jscl:jecl) = rescale * values(iscl:iecl,jscl:jecl) endif endif end subroutine get_field_nc diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 index 54aad20c27..95e6aa7bb7 100644 --- a/src/framework/MOM_netcdf.F90 +++ b/src/framework/MOM_netcdf.F90 @@ -665,6 +665,9 @@ subroutine get_netcdf_fields(handle, axes, fields) call check_netcdf_call(rc, 'get_netcdf_fields', & 'File "' // trim(handle%filename) // '"') + ! Initialize unlim_index with an unreachable value (outside [1,ndims]) + unlim_index = -1 + allocate(axes(ndims)) do i = 1, ndims rc = nf90_inquire_dimension(handle%ncid, dimids(i), name=label, len=len) From 32b969ef4b1f0b21bc548d45cb76e30acaa8a6a4 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Thu, 30 Mar 2023 15:53:11 -0600 Subject: [PATCH 226/629] Accommodate multi-instance runs in CESM (#241) * changes in nuopc cap, infra, and MOM.F90 to receive ensembe id from the coupler (alternative to FMS ensemble mngr) * multi-instance logfile name correction in nuopc cap * append ensemble suffix to _doc files * changes in rpointer and restart file name handling to accommodate multi-instance CESM runs * remove fms2_io_mod usage in FMS1/MOM_ensemble_manager_infra.F90 * rm whitespace in mom_cap --- config_src/drivers/nuopc_cap/mom_cap.F90 | 64 +++++++++++++------ .../nuopc_cap/mom_ocean_model_nuopc.F90 | 5 +- .../infra/FMS1/MOM_ensemble_manager_infra.F90 | 13 +++- .../infra/FMS2/MOM_ensemble_manager_infra.F90 | 15 ++++- src/core/MOM.F90 | 8 ++- src/framework/MOM_file_parser.F90 | 9 ++- src/framework/MOM_get_input.F90 | 2 +- 7 files changed, 84 insertions(+), 32 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 76d541813e..f74aa45c77 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -28,9 +28,11 @@ module MOM_cap_mod use MOM_cap_methods, only: mom_import, mom_export, mom_set_geomtype, mod2med_areacor use MOM_cap_methods, only: med2mod_areacor, state_diagnose use MOM_cap_methods, only: ChkErr +use MOM_ensemble_manager, only: ensemble_manager_init #ifdef CESMCOUPLED use shr_log_mod, only: shr_log_setLogUnit +use nuopc_shr_methods, only: get_component_instance #endif use time_utils_mod, only: esmf2fms_time @@ -146,7 +148,8 @@ module MOM_cap_mod logical :: cesm_coupled = .false. type(ESMF_GeomType_Flag) :: geomtype #endif -character(len=8) :: restart_mode = 'alarms' +character(len=8) :: restart_mode = 'alarms' +character(len=16) :: inst_suffix = '' contains @@ -422,6 +425,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar + character(len=:), allocatable :: rpointer_filename + integer :: inst_index !-------------------------------- rc = ESMF_SUCCESS @@ -451,6 +456,13 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) CALL ESMF_TimeIntervalGet(TINT, S=DT_OCEAN, RC=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return +#ifdef CESMCOUPLED + call get_component_instance(gcomp, inst_suffix, inst_index, rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ensemble_manager_init(inst_suffix) + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) +#endif + ! reset shr logging to my log file if (localPet==0) then call NUOPC_CompAttributeGet(gcomp, name="diro", & @@ -460,11 +472,19 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) isPresent=isPresentLogfile, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresentDiro .and. isPresentLogfile) then - call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) + call NUOPC_CompAttributeGet(gcomp, name="diro", value=diro, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name="logfile", value=logfile, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + if (cesm_coupled) then + ! Multiinstance logfile name needs a correction + if(logfile(4:4) == '_') then + logfile = logfile(1:3)//trim(inst_suffix)//logfile(9:) + endif + endif + + open(newunit=stdout,file=trim(diro)//"/"//trim(logfile)) else stdout = output_unit endif @@ -521,12 +541,6 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) time0 = set_date (YEAR,MONTH,DAY,HOUR,MINUTE,SECOND) - - ! rsd need to figure out how to get this without share code - !call shr_nuopc_get_component_instance(gcomp, inst_suffix, inst_index) - !inst_name = "OCN"//trim(inst_suffix) - - if (is_root_pe()) then write(stdout,*) subname//'start time: y,m,d-',year,month,day,'h,m,s=',hour,minute,second endif @@ -581,9 +595,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (localPet == 0) then ! this hard coded for rpointer.ocn right now - open(newunit=readunit, file='rpointer.ocn', form='formatted', status='old', iostat=iostat) + open(newunit=readunit, file=rpointer_filename, form='formatted', status='old', iostat=iostat) if (iostat /= 0) then - call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening rpointer.ocn', & + call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening '//rpointer_filename, & line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif @@ -593,7 +607,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (len(trim(restartfiles))>1 .and. iostat<0) then exit ! done reading restart files list. else - call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading rpointer.ocn', & + call ESMF_LogSetError(ESMF_RC_FILE_READ, msg=subname//' ERROR reading '//rpointer_filename, & line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif @@ -616,7 +630,12 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif ocean_public%is_ocean_pe = .true. - call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) + if (cesm_coupled .and. len_trim(inst_suffix)>0) then + call ocean_model_init(ocean_public, ocean_state, time0, time_start, & + input_restart_file=trim(adjustl(restartfiles)), inst_index=inst_index) + else + call ocean_model_init(ocean_public, ocean_state, time0, time_start, input_restart_file=trim(adjustl(restartfiles))) + endif ! GMM, this call is not needed in CESM. Check with EMC if it can be deleted. call ocean_model_flux_init(ocean_state) @@ -1489,6 +1508,7 @@ subroutine ModelAdvance(gcomp, rc) character(len=128) :: fldname character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' character(len=8) :: suffix + character(len=:), allocatable :: rpointer_filename integer :: num_rest_files rc = ESMF_SUCCESS @@ -1658,6 +1678,8 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_VMGet(vm, localPet=localPet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) + write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & trim(casename), year, month, day, seconds call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) @@ -1665,13 +1687,17 @@ subroutine ModelAdvance(gcomp, rc) call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) if (localPet == 0) then ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean - open(newunit=writeunit, file='rpointer.ocn', form='formatted', status='unknown', iostat=iostat) + open(newunit=writeunit, file=rpointer_filename, form='formatted', status='unknown', iostat=iostat) if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & - msg=subname//' ERROR opening rpointer.ocn', line=__LINE__, file=u_FILE_u, rcToReturn=rc) + msg=subname//' ERROR opening '//rpointer_filename, line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif - write(writeunit,'(a)') trim(restartname)//'.nc' + if (len_trim(inst_suffix) == 0) then + write(writeunit,'(a)') trim(restartname)//'.nc' + else + write(writeunit,'(a)') trim(restartname)//'.'//trim(inst_suffix)//'.nc' + endif if (num_rest_files > 1) then ! append i.th restart file name to rpointer diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index e58c2796c8..9c81a67202 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -231,7 +231,7 @@ module MOM_ocean_model_nuopc !! This subroutine initializes both the ocean state and the ocean surface type. !! Because of the way that indicies and domains are handled, Ocean_sfc must have !! been used in a previous call to initialize_ocean_type. -subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file) +subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, input_restart_file, inst_index) type(ocean_public_type), target, & intent(inout) :: Ocean_sfc !< A structure containing various publicly !! visible ocean surface properties after initialization, @@ -248,6 +248,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i !! tracer fluxes, and can be used to spawn related !! internal variables in the ice model. character(len=*), optional, intent(in) :: input_restart_file !< If present, name of restart file to read + integer, optional :: inst_index !< Ensemble index provided by the cap (instead of FMS ensemble manager) ! Local variables real :: Rho0 ! The Boussinesq ocean density, in kg m-3. @@ -285,7 +286,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & diag_ptr=OS%diag, count_calls=.true., tracer_flow_CSp=OS%tracer_flow_CSp, & - waves_CSp=OS%Waves) + waves_CSp=OS%Waves, ensemble_num=inst_index) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & C_p_scaled=OS%fluxes%C_p, use_temp=use_temperature) diff --git a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 index 66bbb86e2f..3ab9d591da 100644 --- a/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_ensemble_manager_infra.F90 @@ -9,6 +9,7 @@ module MOM_ensemble_manager_infra use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix implicit none ; private @@ -20,9 +21,15 @@ module MOM_ensemble_manager_infra !> Initializes the ensemble manager which divides available resources !! in order to concurrently execute an ensemble of model realizations. -subroutine ensemble_manager_init() - - call FMS_ensemble_manager_init() +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif end subroutine ensemble_manager_init diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 index 66bbb86e2f..c9eb067e54 100644 --- a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -9,6 +9,8 @@ module MOM_ensemble_manager_infra use ensemble_manager_mod, only : FMS_get_ensemble_size => get_ensemble_size use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist +use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix +use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix implicit none ; private @@ -20,9 +22,16 @@ module MOM_ensemble_manager_infra !> Initializes the ensemble manager which divides available resources !! in order to concurrently execute an ensemble of model realizations. -subroutine ensemble_manager_init() - - call FMS_ensemble_manager_init() +subroutine ensemble_manager_init(ensemble_suffix) + character(len=*), optional, intent(in) :: ensemble_suffix !> Ensemble suffix provided by the cap. This may be + !! provided to bypass FMS ensemble manager. + + if (present(ensemble_suffix)) then + call fms2_io_set_filename_appendix(trim(ensemble_suffix)) + call fms_io_set_filename_appendix(trim(ensemble_suffix)) + else + call FMS_ensemble_manager_init() + endif end subroutine ensemble_manager_init diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c61f130ef7..54d2310cfe 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1830,7 +1830,7 @@ end subroutine step_offline !! initializing the ocean state variables, and initializing subsidiary modules subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & - count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp) + count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp, ensemble_num) type(time_type), target, intent(inout) :: Time !< model time, set in this routine type(time_type), intent(in) :: Time_init !< The start time for the coupled model's calendar type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse @@ -1853,7 +1853,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & !! dynamics timesteps. type(ice_shelf_CS), optional, pointer :: ice_shelf_CSp !< A pointer to an ice shelf control structure type(Wave_parameters_CS), & - optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + integer, optional :: ensemble_num !< Ensemble index provided by the cap (instead of FMS + !! ensemble manager) ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid @@ -1962,7 +1964,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Read paths and filenames from namelist and store in "dirs". ! Also open the parsed input parameter file(s) and setup param_file. - call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file) + call get_MOM_input(param_file, dirs, default_input_filename=input_restart_file, ensemble_num=ensemble_num) verbosity = 2 ; call read_param(param_file, "VERBOSITY", verbosity) call MOM_set_verbosity(verbosity) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 3a25981dc8..c85cccd9e2 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -124,7 +124,7 @@ module MOM_file_parser contains !> Make the contents of a parameter input file availalble in a param_file_type -subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) +subroutine open_param_file(filename, CS, checkable, component, doc_file_dir, ensemble_num) character(len=*), intent(in) :: filename !< An input file name, optionally with the full path type(param_file_type), intent(inout) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters @@ -134,11 +134,13 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) !! to generate parameter documentation file names; the default is"MOM" character(len=*), optional, intent(in) :: doc_file_dir !< An optional directory in which to write out !! the documentation files. The default is effectively './'. + integer, optional, intent(in) :: ensemble_num !< ensemble number to be appended to _doc filenames (optional) ! Local variables logical :: file_exists, Netcdf_file, may_check, reopened_file integer :: ios, iounit, strlen, i character(len=240) :: doc_path + character(len=5) :: ensemble_suffix type(parameter_block), pointer :: block => NULL() may_check = .true. ; if (present(checkable)) may_check = checkable @@ -211,6 +213,11 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) call read_param(CS,"REPORT_UNUSED_PARAMS",CS%report_unused) call read_param(CS,"FATAL_UNUSED_PARAMS",CS%unused_params_fatal) CS%doc_file = "MOM_parameter_doc" + if (present(ensemble_num)) then + ! append instance suffix to doc_file + write(ensemble_suffix,'(A,I0.4)') '_', ensemble_num + CS%doc_file = trim(CS%doc_file)//ensemble_suffix + endif if (present(component)) CS%doc_file = trim(component)//"_parameter_doc" call read_param(CS,"DOCUMENT_FILE", CS%doc_file) if (.not.may_check) then diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index b6b5b89be9..4c643a5442 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -102,7 +102,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, if (len_trim(trim(parameter_filename(io))) > 0) then if (present(ensemble_num)) then call open_param_file(ensembler(parameter_filename(io),ensemble_num), param_file, & - check_params, doc_file_dir=output_dir) + check_params, doc_file_dir=output_dir, ensemble_num=ensemble_num) else call open_param_file(ensembler(parameter_filename(io)), param_file, & check_params, doc_file_dir=output_dir) From 588cf03adeed355e3db9a12a73c726f3b88b4c35 Mon Sep 17 00:00:00 2001 From: "Alan J. Wallcraft" Date: Sun, 19 Mar 2023 16:37:44 +0000 Subject: [PATCH 227/629] Add PPM_CM and HYCOM1_ONLY_IMPROVES Add "PPM_CW" as an option for INTERPOLATION_SCHEME and REMAPPING_SCHEME. This implements the original Colella and Woodward (1984) edge calculation for PPM. It computes 4th order explicit edge values but constrains them to produce a monotonic profile, which is particularly effective for remapping. INTERPOLATION_SCHEME="PPM_CW" is identical to "REMAPPING_PPM_HYBGEN", but hybgen_PPM_coefs has been replaced by edge_values_explicit_h4cw and PPM_monotonicity for flexibility and to simplify upgrades. Answers with existing INTERPOLATION_SCHEME options are unchanged. REMAPPING_SCHEME="PPM_CW" is a new option which can perform better than "P1M_H2" when used with INTERPOLATION_SCHEME="PPM_CW". Answers with existing REMAPPING_SCHEME options are unchanged. HYCOM1 regridding walks a monotonic density profile to locate the new interface locations where the interface density equals the target density. However, it assumes that moving one interface has no effect on the density at all other interfaces and this need not be the case. When regridding, with HYCOM1_ONLY_IMPROVES=True, an interface is only moved if this improves the fit to its target density. The default of False does not change answers. --- src/ALE/MOM_ALE.F90 | 4 +- src/ALE/MOM_regridding.F90 | 17 +++-- src/ALE/MOM_remapping.F90 | 17 ++++- src/ALE/PPM_functions.F90 | 31 ++++++++- src/ALE/coord_hycom.F90 | 122 +++++++++++++++++++++++++++++---- src/ALE/regrid_edge_values.F90 | 102 ++++++++++++++++++++++++++- src/ALE/regrid_interp.F90 | 27 +++++++- 7 files changed, 297 insertions(+), 23 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 2a9ebc09c8..137f6cee9b 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -206,12 +206,12 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAPPING_SCHEME", string, & "This sets the reconstruction scheme used "//& "for vertical remapping for all variables. "//& - "It can be one of the following schemes: "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=remappingDefaultScheme) call get_param(param_file, mdl, "VELOCITY_REMAPPING_SCHEME", vel_string, & "This sets the reconstruction scheme used for vertical remapping "//& "of velocities. By default it is the same as REMAPPING_SCHEME. "//& - "It can be one of the following schemes: "//& + "It can be one of the following schemes: \n"//& trim(remappingSchemesDoc), default=trim(string)) call get_param(param_file, mdl, "FATAL_CHECK_RECONSTRUCTIONS", check_reconstruction, & "If true, cell-by-cell reconstructions are checked for "//& diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 53072909a5..5e46b8d1f6 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -166,6 +166,7 @@ module MOM_regridding " P1M_H4 (2nd-order accurate)\n"//& " P1M_IH4 (2nd-order accurate)\n"//& " PLM (2nd-order accurate)\n"//& + " PPM_CW (3rd-order accurate)\n"//& " PPM_H4 (3rd-order accurate)\n"//& " PPM_IH4 (3rd-order accurate)\n"//& " P3M_IH4IH3 (4th-order accurate)\n"//& @@ -269,7 +270,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m "determine the new grid. These parameters are "//& "only relevant when REGRIDDING_COORDINATE_MODE is "//& "set to a function of state. Otherwise, it is not "//& - "used. It can be one of the following schemes: "//& + "used. It can be one of the following schemes: \n"//& trim(regriddingInterpSchemeDoc), default=trim(string2)) call set_regrid_params(CS, interp_scheme=string) @@ -582,6 +583,13 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_params(CS, min_thickness=0.) endif + if (main_parameters .and. coordinateMode(coord_mode) == REGRIDDING_HYCOM1) then + call get_param(param_file, mdl, "HYCOM1_ONLY_IMPROVES", tmpLogical, & + "When regridding, an interface is only moved if this improves the fit to the target density.", & + default=.false.) + call set_hycom_params(CS%hycom_CS, only_improves=tmpLogical) + endif + CS%use_hybgen_unmix = .false. if (coordinateMode(coord_mode) == REGRIDDING_HYBGEN) then call get_param(param_file, mdl, "USE_HYBGEN_UNMIX", CS%use_hybgen_unmix, & @@ -865,7 +873,7 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & call build_grid_arbitrary( G, GV, h, dzInterface, trickGnuCompiler, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) + call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) case ( REGRIDDING_HYBGEN ) call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -1515,12 +1523,13 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_shelf_h ) +subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position @@ -1575,7 +1584,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, CS, frac_she ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) enddo - call build_hycom1_column(CS%hycom_CS, tv%eqn_of_state, GV%ke, nominalDepth, & + call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, & h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & z_col, z_col_new, zScale=GV%Z_to_H, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index 9ebc0601d2..eeb4590a08 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -8,12 +8,14 @@ module MOM_remapping use MOM_io, only : stdout, stderr use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h4, edge_values_implicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use remapping_attic, only : remapping_attic_unit_tests use PCM_functions, only : PCM_reconstruction use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use MOM_hybgen_remap, only : hybgen_plm_coefs, hybgen_ppm_coefs, hybgen_weno_coefs @@ -48,6 +50,7 @@ module MOM_remapping integer, parameter :: REMAPPING_PCM = 0 !< O(h^1) remapping scheme integer, parameter :: REMAPPING_PLM = 2 !< O(h^2) remapping scheme integer, parameter :: REMAPPING_PLM_HYBGEN = 3 !< O(h^2) remapping scheme +integer, parameter :: REMAPPING_PPM_CW =10 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PPM_H4 = 4 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PPM_IH4 = 5 !< O(h^3) remapping scheme integer, parameter :: REMAPPING_PPM_HYBGEN = 6 !< O(h^3) remapping scheme @@ -287,7 +290,7 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & local_remapping_scheme = REMAPPING_PCM elseif (n0<=3) then local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PLM ) - elseif (n0<=4) then + elseif (n0<=4 .and. local_remapping_scheme /= REMAPPING_PPM_CW ) then local_remapping_scheme = min( local_remapping_scheme, REMAPPING_PPM_H4 ) endif select case ( local_remapping_scheme ) @@ -310,6 +313,15 @@ subroutine build_reconstructions_1d( CS, n0, h0, u0, ppoly_r_coefs, & if ( CS%boundary_extrapolation ) & call PLM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) iMethod = INTEGRATION_PLM + case ( REMAPPING_PPM_CW ) + ! identical to REMAPPING_PPM_HYBGEN + call edge_values_explicit_h4cw( n0, h0, u0, ppoly_r_E, h_neglect_edge ) + call PPM_monotonicity( n0, u0, ppoly_r_E ) + call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) + if ( CS%boundary_extrapolation ) then + call PPM_boundary_extrapolation( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect ) + endif + iMethod = INTEGRATION_PPM case ( REMAPPING_PPM_H4 ) call edge_values_explicit_h4( n0, h0, u0, ppoly_r_E, h_neglect_edge, answer_date=CS%answer_date ) call PPM_reconstruction( n0, h0, u0, ppoly_r_E, ppoly_r_coefs, h_neglect, answer_date=CS%answer_date ) @@ -1283,6 +1295,9 @@ subroutine setReconstructionType(string,CS) case ("PLM_HYBGEN") CS%remapping_scheme = REMAPPING_PLM_HYBGEN degree = 1 + case ("PPM_CW") + CS%remapping_scheme = REMAPPING_PPM_CW + degree = 2 case ("PPM_H4") CS%remapping_scheme = REMAPPING_PPM_H4 degree = 2 diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index aa24806d68..805a70d502 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -13,7 +13,7 @@ module PPM_functions implicit none ; private -public PPM_reconstruction, PPM_boundary_extrapolation +public PPM_reconstruction, PPM_boundary_extrapolation, PPM_monotonicity !> A tiny width that is so small that adding it to cell widths does not !! change the value due to a computational representation. It is used @@ -127,6 +127,35 @@ subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) end subroutine PPM_limiter_standard +!> Adjusts edge values using the original monotonicity constraint (Colella & Woodward, JCP 1984) +!! Based on hybgen_ppm_coefs +subroutine PPM_monotonicity( N, u, edge_values ) + integer, intent(in) :: N !< Number of cells + real, dimension(:), intent(in) :: u !< cell average properties (size N) [A] + real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] + + ! Local variables + integer :: k ! Loop index + real :: a6,da ! scalar temporaries + + ! Loop on interior cells to impose monotonicity + ! Eq. 1.10 of (Colella & Woodward, JCP 84) + do k = 2,N-1 + if (((u(k+1)-u(k))*(u(k)-u(k-1)) <= 0.)) then !local extremum + edge_values(k,1) = u(k) + edge_values(k,2) = u(k) + else + da = edge_values(k,2)-edge_values(k,1) + a6 = 6.0*u(k) - 3.0*(edge_values(k,1)+edge_values(k,2)) + if (da*a6 > da*da) then !peak in right half of zone + edge_values(k,1) = 3.0*u(k) - 2.0*edge_values(k,2) + elseif (da*a6 < -da*da) then !peak in left half of zone + edge_values(k,2) = 3.0*u(k) - 2.0*edge_values(k,1) + endif + endif + enddo ! end loop on interior cells + +end subroutine PPM_monotonicity !------------------------------------------------------------------------------ !> Reconstruction by parabolas within boundary cells diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index 5a3ffaff52..aa2715eb42 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -4,8 +4,10 @@ module coord_hycom ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL +use MOM_remapping, only : remapping_CS, remapping_core_h use MOM_EOS, only : EOS_type, calculate_density -use regrid_interp, only : interp_CS_type, build_and_interpolate_grid +use regrid_interp, only : interp_CS_type, build_and_interpolate_grid, regridding_set_ppolys +use regrid_interp, only : DEGREE_MAX implicit none ; private @@ -27,6 +29,9 @@ module coord_hycom !> Maximum thicknesses of layers [H ~> m or kg m-2] real, allocatable, dimension(:) :: max_layer_thickness + !> If true, an interface only moves if it improves the density fit + logical :: only_improves = .false. + !> Interpolation control structure type(interp_CS_type) :: interp_CS end type hycom_CS @@ -69,10 +74,11 @@ subroutine end_coord_hycom(CS) end subroutine end_coord_hycom !> This subroutine can be used to set the parameters for the coord_hycom module -subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, interp_CS) +subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, only_improves, interp_CS) type(hycom_CS), pointer :: CS !< Coordinate control structure real, dimension(:), optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] real, dimension(:), optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] + logical, optional, intent(in) :: only_improves !< If true, an interface only moves if it improves the density fit type(interp_CS_type), optional, intent(in) :: interp_CS !< Controls for interpolation if (.not. associated(CS)) call MOM_error(FATAL, "set_hycom_params: CS not associated") @@ -91,13 +97,16 @@ subroutine set_hycom_params(CS, max_interface_depths, max_layer_thickness, inter CS%max_layer_thickness(:) = max_layer_thickness(:) endif + if (present(only_improves)) CS%only_improves = only_improves + if (present(interp_CS)) CS%interp_CS = interp_CS end subroutine set_hycom_params !> Build a HyCOM coordinate column -subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & +subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & z_col, z_col_new, zScale, h_neglect, h_neglect_edge) type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure integer, intent(in) :: nz !< Number of levels real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) @@ -116,8 +125,17 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & ! Local variables integer :: k - real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] - real, dimension(CS%nk) :: h_col_new ! New layer thicknesses + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(CS%nk) :: h_col_new ! New layer thicknesses [H ~> m or kg m-2] + real, dimension(CS%nk) :: r_col_new ! New layer densities [R ~> kg m-3] + real, dimension(CS%nk) :: T_col_new ! New layer temperatures [C ~> degC] + real, dimension(CS%nk) :: S_col_new ! New layer salinities [S ~> ppt] + real, dimension(CS%nk) :: p_col_new ! New layer pressure [R L2 T-2 ~> Pa] + real, dimension(CS%nk+1) :: RiA_ini ! Initial nk+1 interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real, dimension(CS%nk+1) :: RiA_new ! New interface density anomaly w.r.t. the + ! interface target densities [R ~> kg m-3] + real :: z_1, z_nz ! mid point of 1st and last layers [H ~> m or kg m-2] real :: z_scale ! A scaling factor from the input thicknesses to the target thicknesses, ! perhaps 1 or a factor in [H Z-1 ~> 1 or kg m-3] real :: stretching ! z* stretching, converts z* to z [nondim]. @@ -130,18 +148,43 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & z_scale = 1.0 ; if (present(zScale)) z_scale = zScale - ! Work bottom recording potential density - call calculate_density(T, S, p_col, rho_col, eqn_of_state) - ! This ensures the potential density profile is monotonic - ! although not necessarily single valued. - do k = nz-1, 1, -1 - rho_col(k) = min( rho_col(k), rho_col(k+1) ) - enddo + if (CS%only_improves .and. nz == CS%nk) then + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + h, T, S, p_col, rho_col, RiA_ini, h_neglect, h_neglect_edge) + else + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + endif ! Interpolates for the target interface position with the rho_col profile ! Based on global density profile, interpolate to generate a new grid call build_and_interpolate_grid(CS%interp_CS, rho_col, nz, h(:), z_col, & CS%target_density, CS%nk, h_col_new, z_col_new, h_neglect, h_neglect_edge) + if (CS%only_improves .and. nz == CS%nk) then + ! Only move an interface if it improves the density fit + z_1 = 0.5 * ( z_col(1) + z_col(2) ) + z_nz = 0.5 * ( z_col(nz) + z_col(nz+1) ) + do k = 1,CS%nk + p_col_new(k) = p_col(1) + ( 0.5 * ( z_col_new(K) + z_col_new(K+1) ) - z_1 ) / ( z_nz - z_1 ) * & + ( p_col(nz) - p_col(1) ) + enddo + ! Remap from original h and T,S to get T,S_col_new + call remapping_core_h(remapCS, nz, h(:), T, CS%nk, h_col_new, T_col_new, h_neglect, h_neglect_edge) + call remapping_core_h(remapCS, nz, h(:), S, CS%nk, h_col_new, S_col_new, h_neglect, h_neglect_edge) + call build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, CS%nk, depth, & + h_col_new, T_col_new, S_col_new, p_col_new, r_col_new, RiA_new, h_neglect, h_neglect_edge) + do k= 2,CS%nk + if ( abs(RiA_ini(K)) <= abs(RiA_new(K)) .and. z_col(K) > z_col_new(K-1) .and. & + z_col(K) < z_col_new(K+1)) then + z_col_new(K) = z_col(K) + endif + enddo + endif !only_improves ! Sweep down the interfaces and make sure that the interface is at least ! as deep as a nominal target z* grid @@ -165,4 +208,59 @@ subroutine build_hycom1_column(CS, eqn_of_state, nz, depth, h, T, S, p_col, & enddo ; endif end subroutine build_hycom1_column +!> Calculate interface density anomaly w.r.t. the target. +subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_col, & + R, RiAnom, h_neglect, h_neglect_edge) + type(hycom_CS), intent(in) :: CS !< Coordinate control structure + type(remapping_CS), intent(in) :: remapCS !< Remapping parameters and options + type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure + integer, intent(in) :: nz !< Number of levels + real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) + real, dimension(nz), intent(in) :: T !< Temperature of column [C ~> degC] + real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] + real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] + !! to desired units for zInterface, perhaps GV%Z_to_H. + real, dimension(nz), intent(out) :: R !< Layer density [R ~> kg m-3] + real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly + !! w.r.t. the interface target + !! densities [R ~> kg m-3] + real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of + !! cell reconstruction [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of + !! edge value calculation [H ~> m or kg m-2] + ! Local variables + integer :: degree,k + real, dimension(nz) :: rho_col ! Layer densities in a column [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_E ! Polynomial edge values [R ~> kg m-3] + real, dimension(nz,2) :: ppoly_S ! Polynomial edge slopes [R H-1] + real, dimension(nz,DEGREE_MAX+1) :: ppoly_C ! Polynomial interpolant coeficients on the local 0-1 grid [R ~> kg m-3] + + ! Work bottom recording potential density + call calculate_density(T, S, p_col, rho_col, eqn_of_state) + ! This ensures the potential density profile is monotonic + ! although not necessarily single valued. + do k = nz-1, 1, -1 + rho_col(k) = min( rho_col(k), rho_col(k+1) ) + enddo + + call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h, ppoly_E, ppoly_S, ppoly_C, & + degree, h_neglect, h_neglect_edge) + + R(1) = rho_col(1) + RiAnom(1) = ppoly_E(1,1) - CS%target_density(1) + do k= 2,nz + R(k) = rho_col(k) + if (ppoly_E(k-1,2) > CS%target_density(k)) then + RiAnom(k) = ppoly_E(k-1,2) - CS%target_density(k) !interface is heavier than target + elseif (ppoly_E(k,1) < CS%target_density(k)) then + RiAnom(k) = ppoly_E(k,1) - CS%target_density(k) !interface is lighter than target + else + RiAnom(k) = 0.0 !interface spans the target + endif + enddo + RiAnom(nz+1) = ppoly_E(nz,2) - CS%target_density(nz+1) + +end subroutine build_hycom1_target_anomaly + end module coord_hycom diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 3f59fac60f..9b574348af 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -14,7 +14,7 @@ module regrid_edge_values ! The following routines are visible to the outside world ! ----------------------------------------------------------------------------- public bound_edge_values, average_discontinuous_edge_values, check_discontinuous_edge_values -public edge_values_explicit_h2, edge_values_explicit_h4 +public edge_values_explicit_h2, edge_values_explicit_h4, edge_values_explicit_h4cw public edge_values_implicit_h4, edge_values_implicit_h6 public edge_slopes_implicit_h3, edge_slopes_implicit_h5 @@ -357,6 +357,106 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) end subroutine edge_values_explicit_h4 +!> Compute h4 edge values (explicit fourth order accurate) +!! in the same units as u. +!! +!! From (Colella & Woodward, JCP, 1984) and based on hybgen_ppm_coefs. +!! +!! Compute edge values based on fourth-order explicit estimates. +!! These estimates are based on a cubic interpolant spanning four cells +!! and evaluated at the location of the middle edge. An interpolant spanning +!! cells i-2, i-1, i and i+1 is evaluated at edge i-1/2. The estimate for +!! each edge is unique. +!! +!! i-2 i-1 i i+1 +!! ..--o------o------o------o------o--.. +!! i-1/2 +!! +!! For this fourth-order scheme, at least four cells must exist. +subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) + integer, intent(in) :: N !< Number of cells + real, dimension(N), intent(in) :: h !< cell widths [H] + real, dimension(N), intent(in) :: u !< cell average properties in arbitrary units [A] + real, dimension(N,2), intent(inout) :: edge_val !< Returned edge values [A]; the second index + !! is for the two edges of each cell. + real, optional, intent(in) :: h_neglect !< A negligibly small width [H] + + ! Local variables + real :: dp(N) ! Input grid layer thicknesses, but with a minimum thickness [H ~> m or kg m-2] + real :: hNeglect ! A negligible thickness in the same units as h + real :: da ! Difference between the unlimited scalar edge value estimates [A] + real :: a6 ! Scalar field differences that are proportional to the curvature [A] + real :: slk, srk ! Differences between adjacent cell averages of scalars [A] + real :: sck ! Scalar differences across a cell. + real :: au(N) ! Scalar field difference across each cell [A] + real :: al(N), ar(N) ! Scalar field at the left and right edges of a cell [A] + real :: h112(N+1), h122(N+1) ! Combinations of thicknesses [H ~> m or kg m-2] + real :: I_h12(N+1) ! Inverses of combinations of thickesses [H-1 ~> m-1 or m2 kg-1] + real :: h2_h123(N) ! A ratio of a layer thickness of the sum of 3 adjacent thicknesses [nondim] + real :: I_h0123(N) ! Inverse of the sum of 4 adjacent thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: h01_h112(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + real :: h23_h122(N+1) ! A ratio of sums of adjacent thicknesses [nondim], 2/3 in the limit of uniform thicknesses. + integer :: k + + hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect + + ! Set the thicknesses for very thin layers to some minimum value. + do k=1,N ; dp(k) = max(h(k), hNeglect) ; enddo + + !compute grid metrics + do k=2,N + h112(K) = 2.*dp(k-1) + dp(k) + h122(K) = dp(k-1) + 2.*dp(k) + I_h12(K) = 1.0 / (dp(k-1) + dp(k)) + enddo !k + do k=2,N-1 + h2_h123(k) = dp(k) / (dp(k) + (dp(k-1)+dp(k+1))) + enddo + do K=3,N-1 + I_h0123(K) = 1.0 / ((dp(k-2) + dp(k-1)) + (dp(k) + dp(k+1))) + + h01_h112(K) = (dp(k-2) + dp(k-1)) / (2.0*dp(k-1) + dp(k)) + h23_h122(K) = (dp(k) + dp(k+1)) / (dp(k-1) + 2.0*dp(k)) + enddo + + !Compute average slopes: Colella, Eq. (1.8) + au(1) = 0. + do k=2,N-1 + slk = u(k )-u(k-1) + srk = u(k+1)-u(k) + if (slk*srk > 0.) then + sck = h2_h123(k)*( h112(K)*srk*I_h12(K+1) + h122(K+1)*slk*I_h12(K) ) + au(k) = sign(min(abs(2.0*slk), abs(sck), abs(2.0*srk)), sck) + else + au(k) = 0. + endif + enddo !k + au(N) = 0. + + !Compute "first guess" edge values: Colella, Eq. (1.6) + al(1) = u(1) ! 1st layer PCM + ar(1) = u(1) ! 1st layer PCM + al(2) = u(1) ! 1st layer PCM + do K=3,N-1 + ! This is a 4th order explicit edge value estimate. + al(k) = (dp(k)*u(k-1) + dp(k-1)*u(k)) * I_h12(K) & + + I_h0123(K)*( 2.*dp(k)*dp(k-1)*I_h12(K)*(u(k)-u(k-1)) * & + ( h01_h112(K) - h23_h122(K) ) & + + (dp(k)*au(k-1)*h23_h122(K) - dp(k-1)*au(k)*h01_h112(K)) ) + ar(k-1) = al(k) + enddo !k + ar(N-1) = u(N) ! last layer PCM + al(N) = u(N) ! last layer PCM + ar(N) = u(N) ! last layer PCM + + !Set coefficients + do k=1,N + edge_val(k,1) = al(k) + edge_val(k,2) = ar(k) + enddo !k + +end subroutine edge_values_explicit_h4cw + !> Compute ih4 edge values (implicit fourth order accurate) !! in the same units as u. !! diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 4d09daf6f3..e119ce9d53 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -7,11 +7,13 @@ module regrid_interp use MOM_string_functions, only : uppercase use regrid_edge_values, only : edge_values_explicit_h2, edge_values_explicit_h4 +use regrid_edge_values, only : edge_values_explicit_h4cw use regrid_edge_values, only : edge_values_implicit_h4, edge_values_implicit_h6 use regrid_edge_values, only : edge_slopes_implicit_h3, edge_slopes_implicit_h5 use PLM_functions, only : PLM_reconstruction, PLM_boundary_extrapolation use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation +use PPM_functions, only : PPM_monotonicity use PQM_functions, only : PQM_reconstruction, PQM_boundary_extrapolation_v1 use P1M_functions, only : P1M_interpolation, P1M_boundary_extrapolation @@ -45,6 +47,7 @@ module regrid_interp integer, parameter :: INTERPOLATION_P1M_H4 = 1 !< O(h^2) integer, parameter :: INTERPOLATION_P1M_IH4 = 2 !< O(h^2) integer, parameter :: INTERPOLATION_PLM = 3 !< O(h^2) +integer, parameter :: INTERPOLATION_PPM_CW =10 !< O(h^3) integer, parameter :: INTERPOLATION_PPM_H4 = 4 !< O(h^3) integer, parameter :: INTERPOLATION_PPM_IH4 = 5 !< O(h^3) integer, parameter :: INTERPOLATION_P3M_IH4IH3 = 6 !< O(h^4) @@ -144,6 +147,25 @@ subroutine regridding_set_ppolys(CS, densities, n0, h0, ppoly0_E, ppoly0_S, & call PLM_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect ) endif + case ( INTERPOLATION_PPM_CW ) + if ( n0 >= 4 ) then + degree = DEGREE_2 + call edge_values_explicit_h4cw( n0, h0, densities, ppoly0_E, h_neglect_edge ) + call PPM_monotonicity( n0, densities, ppoly0_E ) + call PPM_reconstruction( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call PPM_boundary_extrapolation( n0, h0, densities, ppoly0_E, & + ppoly0_coefs, h_neglect ) + endif + else + degree = DEGREE_1 + call edge_values_explicit_h2( n0, h0, densities, ppoly0_E ) + call P1M_interpolation( n0, h0, densities, ppoly0_E, ppoly0_coefs, h_neglect, answer_date=CS%answer_date ) + if (extrapolate) then + call P1M_boundary_extrapolation( n0, h0, densities, ppoly0_E, ppoly0_coefs ) + endif + endif + case ( INTERPOLATION_PPM_H4 ) if ( n0 >= 4 ) then degree = DEGREE_2 @@ -486,7 +508,7 @@ end function get_polynomial_coordinate !> Numeric value of interpolation_scheme corresponding to scheme name integer function interpolation_scheme(interp_scheme) character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme - !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" select case ( uppercase(trim(interp_scheme)) ) @@ -494,6 +516,7 @@ integer function interpolation_scheme(interp_scheme) case ("P1M_H4"); interpolation_scheme = INTERPOLATION_P1M_H4 case ("P1M_IH2"); interpolation_scheme = INTERPOLATION_P1M_IH4 case ("PLM"); interpolation_scheme = INTERPOLATION_PLM + case ("PPM_CW"); interpolation_scheme = INTERPOLATION_PPM_CW case ("PPM_H4"); interpolation_scheme = INTERPOLATION_PPM_H4 case ("PPM_IH4"); interpolation_scheme = INTERPOLATION_PPM_IH4 case ("P3M_IH4IH3"); interpolation_scheme = INTERPOLATION_P3M_IH4IH3 @@ -509,7 +532,7 @@ end function interpolation_scheme subroutine set_interp_scheme(CS, interp_scheme) type(interp_CS_type), intent(inout) :: CS !< A control structure for regrid_interp character(len=*), intent(in) :: interp_scheme !< Name of the interpolation scheme - !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_H4", + !! Valid values include "P1M_H2", "P1M_H4", "P1M_IH2", "PLM", "PPM_CW", "PPM_H4", !! "PPM_IH4", "P3M_IH4IH3", "P3M_IH6IH5", "PQM_IH4IH3", and "PQM_IH6IH5" CS%interpolation_scheme = interpolation_scheme(interp_scheme) From 1bb66a44c27242f3390906267e545d9f4f7e32f8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 20 Feb 2023 09:39:25 -0500 Subject: [PATCH 228/629] +Update check_MOM6_scaling_factors with C and S Updated check_MOM6_scaling_factors and compose_dimension_list to reflect that fact that MOM6 is now doing dimensional consistency testing for temperature (via [C ~> degC]) and salinity (via [S ~> ppt]), with an expanded dimension of the scaling key from 6 to 8 and additional calls to add_scaling. Also updated the weights on the add_scaling calls, which are essentially counts of the frequency of the various unit descriptors in the MOM6 code, to reflect only the counts of variables with doxygen comments (i.e., arguments, function return values and elements of types) but excluding the user, framework and diagnostics directories and the passive tracer packages. All model solutions are bitwise identical, but there will be updated suggestions for combinations of scaling factors that minimize the aliasing of the units that are used. --- src/core/MOM_check_scaling.F90 | 248 +++++++++++++++++---------------- 1 file changed, 131 insertions(+), 117 deletions(-) diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 index 55bd471fee..1d7c27b6fd 100644 --- a/src/core/MOM_check_scaling.F90 +++ b/src/core/MOM_check_scaling.F90 @@ -28,19 +28,23 @@ subroutine check_MOM6_scaling_factors(GV, US) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type ! Local variables - integer, parameter :: ndims = 6 ! The number of rescalable dimensional factors. + integer, parameter :: ndims = 8 ! The number of rescalable dimensional factors. real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units. integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. character(len=2), dimension(ndims) :: key - ! character(len=128) :: mesg, msg_frag integer, allocatable :: weights(:) character(len=80), allocatable :: descriptions(:) - ! logical :: verbose, very_verbose integer :: n, ns, max_pow + ! If no scaling is being done, simply return. + if ((US%Z_to_m == 1.) .and. (GV%H_to_MKS == 1.) .and. (US%L_to_m == 1.) .and. & + (US%T_to_s == 1.) .and. (US%R_to_kg_m3 == 1.) .and. (US%Q_to_J_kg == 1.) .and. & + (US%C_to_degC == 1.) .and. (US%S_to_ppt == 1.)) return + ! Set the names and scaling factors of the dimensions being rescaled. - key(:) = ["Z", "H", "L", "T", "R", "Q"] - scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg /) + key(:) = ["Z", "H", "L", "T", "R", "Q", "C", "S"] + scales(:) = (/ US%Z_to_m, GV%H_to_MKS, US%L_to_m, US%T_to_s, US%R_to_kg_m3, US%Q_to_J_kg, & + US%C_to_degC, US%S_to_ppt/) call scales_to_powers(scales, scale_pow2) max_pow = 40 ! 60 @@ -71,124 +75,134 @@ subroutine compose_dimension_list(ns, des, wts) !! perhaps the number of times it occurs in the MOM6 code. ns = 0 - ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence. - call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 1239) ! Layer thicknesses - call add_scaling(ns, des, wts, "[Z ~> m]", 660) ! Depths and vertical distance - call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 506) ! Horizontal velocities - call add_scaling(ns, des, wts, "[R ~> kg m-3]", 356) ! Densities - call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 247) ! Rates - call add_scaling(ns, des, wts, "[T ~> s]", 237) ! Time intervals - call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 231) ! Dynamic pressure + ! Accumulate a list of units used in MOM6, in approximate descending order of frequency of occurrence in + ! doxygen comments (i.e., arguments and elements in types), excluding the code in the user, ice_shelf and + ! framework directories and the passive tracer packages. + call add_scaling(ns, des, wts, "[H ~> m or kg m-2]", 716) ! Layer thicknesses + call add_scaling(ns, des, wts, "[L T-1 ~> m s-1]", 264) ! Horizontal velocities + call add_scaling(ns, des, wts, "[Z ~> m]", 244) ! Depths and vertical distance + call add_scaling(ns, des, wts, "[T ~> s]", 154) ! Time intervals + call add_scaling(ns, des, wts, "[S ~> ppt]", 135) ! Salinities + call add_scaling(ns, des, wts, "[C ~> degC]", 135) ! Temperatures + call add_scaling(ns, des, wts, "[R L2 T-2 ~> Pa]", 133) ! Dynamic pressure ! call add_scaling(ns, des, wts, "[R L2 T-2 ~> J m-3]") ! Energy density - call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 181) ! Vertical viscosities and diffusivities - call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 174) ! Cell volumes or masses - call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 163) ! Volume or mass transports - call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 136) ! Horizontal accelerations - call add_scaling(ns, des, wts, "[L ~> m]", 107) ! Horizontal distances - call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 104) ! Friction velocities and viscous coupling - call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 89) ! Inverse cell thicknesses - call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 88) ! Resolved kinetic energy per unit mass - call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 85) ! Integrated turbulent kinetic energy density - call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 78) ! Horizontal viscosity or diffusivity - call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 69) ! Squared shears and buoyancy frequency - call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 68) ! Lateral cell face areas - call add_scaling(ns, des, wts, "[L2 ~> m2]", 67) ! Horizontal areas - - call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 61) ! Specific volumes - call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 62) ! Vertical heat fluxes - call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 60) ! Inverse vertical distances - call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 57) ! Gravitational acceleration - call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 52) ! Vertical mass fluxes - call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 51) ! Vertical thickness fluxes - call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 45) ! Integrated turbulent kinetic energy sources - call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 42) ! Layer or column mass loads - call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 33) ! Integrated turbulent kinetic energy sources - call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 35) ! Squared layer thicknesses - call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 33) ! Turbulent kinetic energy - call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 32) ! Inverse horizontal distances - call add_scaling(ns, des, wts, "[R L Z T-2 ~> Pa]", 27) ! Wind stresses - call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 33) ! Inverse velocities squared - call add_scaling(ns, des, wts, "[R Z L2 T-2 ~> J m-2]", 25) ! Integrated energy - ! call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]") ! Depth integral of pressures (25) - call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 25) ! Integrated energy - call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 24) ! Layer-integrated density - call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 20) ! pbce or gtot - call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 19) ! Laplacian of velocity - - call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 18) ! Biharmonic viscosity - call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 17) ! Layer integrated velocities - call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 15) ! Slopes - call add_scaling(ns, des, wts, "[Z L2 ~> m3]", 14) ! Diagnostic volumes - call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 12) ! Layer integrated velocities - call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 14) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] - call add_scaling(ns, des, wts, "[Z2 ~> m2]", 12) ! Squared vertical distances - call add_scaling(ns, des, wts, "[R Z L2 T-1 ~> kg s-1]", 12) ! Mass fluxes - call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 12) ! Inverse areas - call add_scaling(ns, des, wts, "[L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]", 11) ! Gravitational acceleration over density - call add_scaling(ns, des, wts, "[Z T-2 ~> m s-2]", 10) ! Buoyancy differences or their derivatives - ! Could also add [Z T-2 degC-1 ~> m s-2 degC-1] or [Z T-2 ppt-1 ~> m s-2 ppt-1] - call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 10) ! Energy sources, including for MEKE - call add_scaling(ns, des, wts, "[L3 ~> m3]", 10) ! Metric dependent constants for viscosity - call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 9) ! Inverse of denominator in some weighted averages - call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 9) ! Mixed layer local work variables - call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 9) ! Overturning (GM) streamfunction - call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 9) ! Buoyancy frequency in some params. - call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 8) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z2 T-1 ~> m2 s-1]", 132) ! Vertical viscosities and diffusivities + call add_scaling(ns, des, wts, "[R ~> kg m-3]", 122) ! Densities + + call add_scaling(ns, des, wts, "[H L2 T-1 ~> m3 s-1 or kg s-1]", 97) ! Volume or mass transports + call add_scaling(ns, des, wts, "[H L2 ~> m3 or kg]", 91) ! Cell volumes or masses + call add_scaling(ns, des, wts, "[L T-2 ~> m s-2]", 82) ! Horizontal accelerations + call add_scaling(ns, des, wts, "[T-1 ~> s-1]", 67) ! Rates + call add_scaling(ns, des, wts, "[Z T-1 ~> m s-1]", 56) ! Friction velocities and viscous coupling + call add_scaling(ns, des, wts, "[Q R Z T-1 ~> W m-2]", 42) ! Vertical heat fluxes + call add_scaling(ns, des, wts, "[L2 T-1 ~> m2 s-1]", 45) ! Horizontal viscosity or diffusivity + call add_scaling(ns, des, wts, "[L2 T-2 ~> m2 s-2]", 37) ! Resolved kinetic energy per unit mass + call add_scaling(ns, des, wts, "[L ~> m]", 35) ! Horizontal distances + call add_scaling(ns, des, wts, "[T-2 ~> s-2]", 33) ! Squared shears and buoyancy frequency + + call add_scaling(ns, des, wts, "[R Z L T-2 ~> Pa]", 33) ! Wind stresses + call add_scaling(ns, des, wts, "[H L ~> m2 or kg m-1]", 32) ! Lateral cell face areas + call add_scaling(ns, des, wts, "[L2 ~> m2]", 31) ! Horizontal areas + call add_scaling(ns, des, wts, "[R C-1 ~> kg m-3 degC-1]", 26) ! Thermal expansion coefficients + call add_scaling(ns, des, wts, "[L2 Z-1 T-2 ~> m s-2]", 26) ! Gravitational acceleration + call add_scaling(ns, des, wts, "[R S-1 ~> kg m-3 ppt-1]", 23) ! Haline contraction coefficients + call add_scaling(ns, des, wts, "[R Z3 T-3 ~> W m-2]", 23) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[R Z T-1 ~> kg m-2 s-1]", 19) ! Vertical mass fluxes + call add_scaling(ns, des, wts, "[C H ~> degC m or degC kg m-2]", 17) ! Heat content + call add_scaling(ns, des, wts, "[H-1 ~> m-1 or m2 kg-1]", 17) ! Inverse cell thicknesses + + call add_scaling(ns, des, wts, "[Z-1 ~> m-1]", 14) ! Inverse vertical distances + call add_scaling(ns, des, wts, "[R-1 ~> m3 kg-1]", 14) ! Specific volumes + call add_scaling(ns, des, wts, "[Z L-1 ~> nondim]", 12) ! Slopes + call add_scaling(ns, des, wts, "[L-1 ~> m-1]", 12) ! Inverse horizontal distances + call add_scaling(ns, des, wts, "[L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]", 12) ! pbce or gtot + call add_scaling(ns, des, wts, "[R Z ~> kg m-2]", 11) ! Layer or column mass loads + call add_scaling(ns, des, wts, "[Z L2 T-2 ~> m3 s-2]", 11) ! Integrated energy per unit mass + call add_scaling(ns, des, wts, "[R Z3 T-2 ~> J m-2]", 11) ! Integrated turbulent kinetic energy density + call add_scaling(ns, des, wts, "[H T-1 ~> m s-1 or kg m-2 s-1]", 9) ! Vertical thickness fluxes + call add_scaling(ns, des, wts, "[L-1 T-1 ~> m-1 s-1]", 9) ! Laplacian of velocity + + call add_scaling(ns, des, wts, "[Z3 T-3 ~> m3 s-3]", 9) ! Integrated turbulent kinetic energy sources + call add_scaling(ns, des, wts, "[S H ~> ppt m or ppt kg m-2]", 8) ! Depth integrated salinity + call add_scaling(ns, des, wts, "[Z2 T-2 ~> m2 s-2]", 8) ! Turbulent kinetic energy + call add_scaling(ns, des, wts, "[R L2 Z T-2 ~> Pa m]", 7) ! Vertically integrated pressure anomalies call add_scaling(ns, des, wts, "[Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1]", 7) ! (TKE_to_Kd) - call add_scaling(ns, des, wts, "[Q degC-1 ~> J kg-1 degC-1]", 7) ! Heat capacity - - call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 6) ! Potential energy height derivatives - call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 7) ! Partial derivatives of energy - call add_scaling(ns, des, wts, "[R L2 T-2 Z-1 ~> Pa m-1]", 7) ! Converts depth to pressure - call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 7) ! Rigidity of ice - call add_scaling(ns, des, wts, "[H L2 T-3 ~> m3 s-3]", 9) ! Kinetic energy diagnostics - call add_scaling(ns, des, wts, "[H-1 T-1 ~> m-1 s-1 or m2 kg-1 s-1]", 6) ! Layer potential vorticity - call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 3) ! Kinetic energy dissipation rates - call add_scaling(ns, des, wts, "[Z2 L-2 ~> 1]", 1) ! Slopes squared - call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 6) ! Thickness to height conversion - call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 6) ! Pressure conversion factor - ! Could also add [m T2 R-1 L-2 ~> m Pa-1] - ! Could also add [degC T2 R-1 L-2 ~> degC Pa-1] - call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 5) ! Vertical density gradients + call add_scaling(ns, des, wts, "[L4 T-1 ~> m4 s-1]", 7) ! Biharmonic viscosity + call add_scaling(ns, des, wts, "[L3 ~> m3]", 7) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 T-3 ~> m2 s-3]", 7) ! Buoyancy flux or MEKE sources [L2 T-3 ~> W kg-1] + call add_scaling(ns, des, wts, "[H2 ~> m2 or kg2 m-4]", 7) ! Squared layer thicknesses + call add_scaling(ns, des, wts, "[C H T-1 ~> degC m s-1 or degC kg m-2 s-1]", 7) ! vertical heat fluxes + + call add_scaling(ns, des, wts, "[L-2 ~> m-2]", 6) ! Inverse areas + call add_scaling(ns, des, wts, "[R Z L2 T-3 ~> W m-2]", 6) ! Energy sources, including for MEKE + call add_scaling(ns, des, wts, "[Z2 T-3 ~> m2 s-3]", 5) ! Certain buoyancy fluxes + call add_scaling(ns, des, wts, "[Z2 ~> m2]", 5) ! Squared vertical distances + call add_scaling(ns, des, wts, "[S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1]", 5) ! vertical salinity fluxes + call add_scaling(ns, des, wts, "[R-1 C-1 ~> m3 kg-1 degC-1]", 5) ! Specific volume temperature gradient + call add_scaling(ns, des, wts, "[R-1 S-1 ~> m3 kg-1 ppt-1]", 4) ! Specific volume salnity gradient + call add_scaling(ns, des, wts, "[Q R Z ~> J m-2]", 4) ! time-integrated frazil heat flux + call add_scaling(ns, des, wts, "[Z C-1 ~> m degC-1]", 4) ! Inverse temperature gradients + call add_scaling(ns, des, wts, "[Z S-1 ~> m ppt-1]", 4) ! Inverse salinity gradients + + call add_scaling(ns, des, wts, "[R Z3 T-2 H-1 ~> J m-3 or J kg-1]", 4) ! Partial derivatives of energy + call add_scaling(ns, des, wts, "[R Z3 T-2 S-1 ~> J m-2 ppt-1]", 4) ! Sensitity of energy change to salinity + call add_scaling(ns, des, wts, "[R Z3 T-2 C-1 ~> J m-2 degC-1]", 4) ! Sensitity of energy change to temperature call add_scaling(ns, des, wts, "[R L4 T-4 ~> Pa m2 s-2]", 4) ! Integral in geopotential of pressure - call add_scaling(ns, des, wts, "[L Z-1 ~> nondim]", 4) ! Inverse slopes + call add_scaling(ns, des, wts, "[Q ~> J kg-1]", 4) ! Latent heats + call add_scaling(ns, des, wts, "[Q C-1 ~> J kg-1 degC-1]", 4) ! Heat capacity call add_scaling(ns, des, wts, "[L-3 ~> m-3]", 4) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[L2 Z-2 T-2 ~> s-2]", 4) ! Buoyancy frequency in some params. + call add_scaling(ns, des, wts, "[H R ~> kg m-2 or kg2 m-5]", 4) ! Layer-integrated density + call add_scaling(ns, des, wts, "[H L T-1 ~> m2 s-1 or kg m-1 s-1]", 4) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[H T2 L-1 ~> s2 or kg s2 m-3]", 4) ! BT_cont_type face curvature fit call add_scaling(ns, des, wts, "[H L-1 ~> nondim or kg m-3]", 4) ! BT_cont_type face curvature fit - call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 20) ! Diagnostic conversions to mass - ! Could also add [m3 H-1 L-2 ~> 1 or m3 kg-1] - call add_scaling(ns, des, wts, "[Z T-2 R-1 ~> m4 s-2 kg-1]", 9) ! Gravitational acceleration over density - call add_scaling(ns, des, wts, "[R Z L4 T-3 ~> kg m2 s-3]", 9) ! MEKE fluxes - call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 3) ! Thickness to pressure conversion - - call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 3) ! Inverse of column mass - call add_scaling(ns, des, wts, "[L4 ~> m4]", 3) ! Metric dependent constants for viscosity - call add_scaling(ns, des, wts, "[T-1 Z-1 ~> s-1 m-1]", 2) ! Barotropic PV, for some options - call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 2) ! River mixing term [R Z2 T-1 ~> Pa s] - call add_scaling(ns, des, wts, "[degC Q-1 ~> kg degC J-1]", 2) ! Inverse heat capacity - ! Could add call add_scaling(ns, des, wts, "[Q-1 ~> kg J-1]", 1) ! Inverse heat content - call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 2) ! Ice rigidity term - call add_scaling(ns, des, wts, "[R Z-1 ~> kg m-4]", 3) ! Vertical density gradient - call add_scaling(ns, des, wts, "[R Z L2 ~> kg]", 3) ! Depth and time integrated mass fluxes - call add_scaling(ns, des, wts, "[R L2 T-3 ~> W m-2]", 3) ! Depth integrated friction work - call add_scaling(ns, des, wts, "[ppt2 R-2 ~> ppt2 m6 kg-2]", 3) ! T / S gauge transformation - call add_scaling(ns, des, wts, "[R L-1 ~> kg m-4]", 2) ! Horizontal density gradient - ! Could add call add_scaling(ns, des, wts, "[H Z ~> m2 or kg m-1]", 2) ! Temporary variables - call add_scaling(ns, des, wts, "[Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]", 2) ! Heating to PE change - call add_scaling(ns, des, wts, "[R2 L2 Z2 T-4 ~> Pa2]", 2) ! Squared wind stresses - call add_scaling(ns, des, wts, "[L-2 T-2 ~> m-2 s-2]", 2) ! Squared Laplacian of velocity - call add_scaling(ns, des, wts, "[T H Z-1 ~> s or s kg m-3]", 2) ! Time step times thickness conversion - call add_scaling(ns, des, wts, "[T H Z-1 R-1 ~> s m3 kg-1 or s]", 2) ! Time step over density with conversion - call add_scaling(ns, des, wts, "[H-3 ~> m-3 or m6 kg-3]", 1) ! A local term in ePBL - call add_scaling(ns, des, wts, "[H-4 ~> m-4 or m8 kg-4]", 1) ! A local term in ePBL - call add_scaling(ns, des, wts, "[H T Z-2 ~> s m-1 or kg s m-4]", 1) ! A local term in ePBL - - call add_scaling(ns, des, wts, "[H3 ~> m3 or kg3 m-6]", 1) ! Thickness cubed in a denominator - call add_scaling(ns, des, wts, "[H2 T-2 ~> m2 s-2 or kg2 m-4 s-2]", 1) ! Thickness times f squared - call add_scaling(ns, des, wts, "[H T2 R-1 Z-2 ~> m Pa-1 or s2 m-1]", 1) ! Pressure to thickness conversion - call add_scaling(ns, des, wts, "[L2 Z-2 ~> nondim]", 1) ! Inverse slope squared - call add_scaling(ns, des, wts, "[H R L2 T-2 ~> m Pa]", 1) ! Integral in thickness of pressure - call add_scaling(ns, des, wts, "[R T2 Z-1 ~> kg s2 m-4]", 1) ! Density divided by gravitational acceleration + call add_scaling(ns, des, wts, "[C2 ~> degC2]", 4) ! Squared temperature anomalies + call add_scaling(ns, des, wts, "[S2 ~> ppt2]", 3) ! Squared salinity anomalies + call add_scaling(ns, des, wts, "[C S ~> degC ppt]", 3) ! Covariance of temperature and salinity anomalies + call add_scaling(ns, des, wts, "[S R Z ~> gSalt m-2]", 3) ! Total ocean column salt + call add_scaling(ns, des, wts, "[C R Z ~> degC kg m-2]", 3) ! Total ocean column temperature + call add_scaling(ns, des, wts, "[Pa T2 R-1 L-2 ~> 1]", 3) ! Pressure conversions + call add_scaling(ns, des, wts, "[Z H-1 ~> nondim or m3 kg-1]", 3) ! Thickness to height conversion + call add_scaling(ns, des, wts, "[R Z2 T-2 ~> J m-3]", 3) ! Potential energy height derivatives + + call add_scaling(ns, des, wts, "[H-2 ~> m-2 or m4 kg-2]", 3) ! Mixed layer local work variables + call add_scaling(ns, des, wts, "[C S-1 ~> degC ppt-1]", 2) ! T / S gauge transformation + call add_scaling(ns, des, wts, "[R S-2 ~> kg m-3 ppt-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R C-2 ~> kg m-3 degC-2]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[R S-1 C-1 ~> kg m-3 ppt-1 degC-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]", 2) ! Second derivative of density + call add_scaling(ns, des, wts, "[T2 L-2 ~> s2 m-2]", 2) ! Inverse velocities squared + call add_scaling(ns, des, wts, "[R Z2 T-3 ~> W m-3]", 2) ! Kinetic energy dissipation rates + call add_scaling(ns, des, wts, "[R H-1 ~> kg m-4 or m-1]", 2) ! Vertical density gradients + + call add_scaling(ns, des, wts, "[L4 ~> m4]", 2) ! Metric dependent constants for viscosity + call add_scaling(ns, des, wts, "[Z L T-1 ~> m2 s-1]", 2) ! Layer integrated velocities + call add_scaling(ns, des, wts, "[C Z ~> degC m]", 2) ! Depth integrated temperature + call add_scaling(ns, des, wts, "[S Z ~> ppt m]", 1) ! Layer integrated salinity + call add_scaling(ns, des, wts, "[T L4 ~> s m4]", 2) ! Biharmonic metric dependent constant + call add_scaling(ns, des, wts, "[L6 ~> m6]", 2) ! Biharmonic Leith metric dependent constant + call add_scaling(ns, des, wts, "[L4 Z-1 T-1 ~> m3 s-1]", 2) ! Rigidity of ice + call add_scaling(ns, des, wts, "[L4 Z-2 T-1 ~> m2 s-1]", 1) ! Ice rigidity term + call add_scaling(ns, des, wts, "[R-1 Z-1 ~> m2 kg-1]", 1) ! Inverse of column mass + call add_scaling(ns, des, wts, "[Z-2 ~> m-2]", 1) ! Inverse of denominator in some weighted averages + + call add_scaling(ns, des, wts, "[R Z2 T-1 ~> J s m-3]", 1) ! River mixing term + call add_scaling(ns, des, wts, "[R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1]", 1) ! Thickness to pressure conversion + call add_scaling(ns, des, wts, "[Z T2 R-1 L-2 ~> m Pa-1]", 1) ! Atmospheric pressure SSH correction + call add_scaling(ns, des, wts, "[T Z ~> s m] ", 1) ! Time integrated SSH + call add_scaling(ns, des, wts, "[Z-1 T-1 ~> m-1 s-1]", 1) ! barotropic PV + call add_scaling(ns, des, wts, "[L2 T ~> m2 s]", 1) ! Greatbatch & Lamb 90 coefficient + call add_scaling(ns, des, wts, "[Z L2 T-1 ~> m3 s-1]", 1) ! Overturning (GM) streamfunction + call add_scaling(ns, des, wts, "[kg H-1 L-2 ~> kg m-3 or 1]", 1) ! Diagnostic conversions to mass + call add_scaling(ns, des, wts, "[S-1 ~> ppt-1]", 1) ! Unscaling salinity + call add_scaling(ns, des, wts, "[C-1 ~> degC-1]", 1) ! Unscaling temperature + + call add_scaling(ns, des, wts, "[R Z H-1 ~> kg m-3 or 1] ", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H R-1 Z-1 ~> m3 kg-2 or 1]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[H Z-1 ~> 1 or kg m-3]", 1) ! A unit conversion factor + call add_scaling(ns, des, wts, "[m T s-1 L-1 ~> 1]", 1) ! A unit conversion factor end subroutine compose_dimension_list From 19f861314c21f3b24fa2c7bb951e6fc73761a854 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Mar 2023 09:31:41 -0400 Subject: [PATCH 229/629] +(*)Remove coord_SLight Removed the coord_slight module and all calls to it, and obsoleted all run-time parameters that are exclusively related to it. This code was an attempt from 2015 to define an appropriate hybrid vertical coordinate for global climate modeling, but it never worked very well (usually falling apart in the second year), and it has not been used in any publication or active model for many years. The test case that exercised this coordinate in the MOM6-examples test suite is also being removed via MOM6-examples PR #388. The coord_SLight code is being eliminated altogether now to simplify the MOM6 code base and reduce the volume of untested and unused code. All answers in all known MOM6 configurations in active use are bitwise identical, although there is a remote chance that someone somewhere might be using the SLIGHT coordinate. --- src/ALE/MOM_regridding.F90 | 188 +----- src/ALE/coord_slight.F90 | 733 ------------------------ src/ALE/regrid_consts.F90 | 6 - src/diagnostics/MOM_obsolete_params.F90 | 8 + src/framework/MOM_diag_remap.F90 | 4 - 5 files changed, 18 insertions(+), 921 deletions(-) delete mode 100644 src/ALE/coord_slight.F90 diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 5e46b8d1f6..b9d74c01a2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -22,7 +22,7 @@ module MOM_regridding use regrid_consts, only : REGRIDDING_LAYER, REGRIDDING_ZSTAR use regrid_consts, only : REGRIDDING_RHO, REGRIDDING_SIGMA use regrid_consts, only : REGRIDDING_ARBITRARY, REGRIDDING_SIGMA_SHELF_ZSTAR -use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE +use regrid_consts, only : REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_ADAPTIVE use regrid_interp, only : interp_CS_type, set_interp_scheme, set_interp_extrap use coord_zlike, only : init_coord_zlike, zlike_CS, set_zlike_params, build_zstar_column, end_coord_zlike @@ -30,7 +30,6 @@ module MOM_regridding use coord_rho, only : init_coord_rho, rho_CS, set_rho_params, build_rho_column, end_coord_rho use coord_rho, only : old_inflate_layers_1d use coord_hycom, only : init_coord_hycom, hycom_CS, set_hycom_params, build_hycom1_column, end_coord_hycom -use coord_slight, only : init_coord_slight, slight_CS, set_slight_params, build_slight_column, end_coord_slight use coord_adapt, only : init_coord_adapt, adapt_CS, set_adapt_params, build_adapt_column, end_coord_adapt use MOM_hybgen_regrid, only : hybgen_regrid, hybgen_regrid_CS, init_hybgen_regrid, end_hybgen_regrid use MOM_hybgen_regrid, only : write_Hybgen_coord_file @@ -61,7 +60,7 @@ module MOM_regridding !! This array is the nominal coordinate of interfaces and is the !! running sum of coordinateResolution, in [R ~> kg m-3]. i.e. !! target_density(k+1) = coordinateResolution(k) + coordinateResolution(k) - !! It is only used in "rho", "SLight" or "Hycom" mode. + !! It is only used in "rho" or "Hycom" mode. real, dimension(:), allocatable :: target_density !> A flag to indicate that the target_density arrays has been filled with data. @@ -129,7 +128,6 @@ module MOM_regridding type(sigma_CS), pointer :: sigma_CS => null() !< Control structure for sigma coordinate generator type(rho_CS), pointer :: rho_CS => null() !< Control structure for rho coordinate generator type(hycom_CS), pointer :: hycom_CS => null() !< Control structure for hybrid coordinate generator - type(slight_CS), pointer :: slight_CS => null() !< Control structure for Slight-coordinate generator type(adapt_CS), pointer :: adapt_CS => null() !< Control structure for adaptive coordinate generator type(hybgen_regrid_CS), pointer :: hybgen_CS => NULL() !< Control structure for hybgen regridding @@ -157,7 +155,6 @@ module MOM_regridding " RHO - continuous isopycnal\n"//& " HYCOM1 - HyCOM-like hybrid coordinate\n"//& " HYBGEN - Hybrid coordinate from the Hycom hybgen code\n"//& - " SLIGHT - stretched coordinates above continuous isopycnal\n"//& " ADAPTIVE - optimize for smooth neutral density surfaces" !> Documentation for regridding interpolation schemes @@ -209,18 +206,17 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m character(len=200) :: inputdir, fileName character(len=320) :: message ! Temporary strings character(len=12) :: expected_units, alt_units ! Temporary strings - logical :: tmpLogical, fix_haloclines, do_sum, main_parameters + logical :: tmpLogical, do_sum, main_parameters logical :: coord_is_state_dependent, ierr integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the remapping expressions to use. - real :: filt_len, strat_tol, tmpReal, P_Ref + real :: tmpReal, P_Ref real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). - real :: dz_fixed_sfc, Rho_avg_depth, nlay_sfc_int real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] - integer :: nz_fixed_sfc, k, nzf(4) + integer :: k, nzf(4) real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] ! or [Z ~> m] or [H ~> m or kg m-2] or [R ~> kg m-3] or other units. real, dimension(:), allocatable :: h_max ! Maximum layer thicknesses [H ~> m or kg m-2] @@ -489,7 +485,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m if (coordinateMode(coord_mode) == REGRIDDING_ZSTAR .or. & coordinateMode(coord_mode) == REGRIDDING_HYCOM1 .or. & coordinateMode(coord_mode) == REGRIDDING_HYBGEN .or. & - coordinateMode(coord_mode) == REGRIDDING_SLIGHT .or. & coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then ! Adjust target grid to be consistent with maximum_depth tmpReal = sum( dz(:) ) @@ -597,49 +592,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m default=.false.) endif - if (coordinateMode(coord_mode) == REGRIDDING_SLIGHT) then - ! Set SLight-specific regridding parameters. - call get_param(param_file, mdl, "SLIGHT_DZ_SURFACE", dz_fixed_sfc, & - "The nominal thickness of fixed thickness near-surface "//& - "layers with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "SLIGHT_NZ_SURFACE_FIXED", nz_fixed_sfc, & - "The number of fixed-depth surface layers with the SLight "//& - "coordinate.", units="nondimensional", default=2) - call get_param(param_file, mdl, "SLIGHT_SURFACE_AVG_DEPTH", Rho_avg_depth, & - "The thickness of the surface region over which to average "//& - "when calculating the density to use to define the interior "//& - "with the SLight coordinate.", units="m", default=1.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "SLIGHT_NLAY_TO_INTERIOR", nlay_sfc_int, & - "The number of layers to offset the surface density when "//& - "defining where the interior ocean starts with SLight.", & - units="nondimensional", default=2.0) - call get_param(param_file, mdl, "SLIGHT_FIX_HALOCLINES", fix_haloclines, & - "If true, identify regions above the reference pressure "//& - "where the reference pressure systematically underestimates "//& - "the stratification and use this in the definition of the "//& - "interior with the SLight coordinate.", default=.false.) - - call set_regrid_params(CS, dz_min_surface=dz_fixed_sfc, & - nz_fixed_surface=nz_fixed_sfc, Rho_ML_avg_depth=Rho_avg_depth, & - nlay_ML_to_interior=nlay_sfc_int, fix_haloclines=fix_haloclines) - if (fix_haloclines) then - ! Set additional parameters related to SLIGHT_FIX_HALOCLINES. - call get_param(param_file, mdl, "HALOCLINE_FILTER_LENGTH", filt_len, & - "A length scale over which to smooth the temperature and "//& - "salinity before identifying erroneously unstable haloclines.", & - units="m", default=2.0, scale=GV%m_to_H) - call get_param(param_file, mdl, "HALOCLINE_STRAT_TOL", strat_tol, & - "A tolerance for the ratio of the stratification of the "//& - "apparent coordinate stratification to the actual value "//& - "that is used to identify erroneously unstable haloclines. "//& - "This ratio is 1 when they are equal, and sensible values "//& - "are between 0 and 0.5.", units="nondimensional", default=0.2) - call set_regrid_params(CS, halocline_filt_len=filt_len, & - halocline_strat_tol=strat_tol) - endif - - endif - if (coordinateMode(coord_mode) == REGRIDDING_ADAPTIVE) then call get_param(param_file, mdl, "ADAPT_TIME_RATIO", adaptTimeRatio, & "Ratio of ALE timestep to grid timescale.", units="nondim", default=1.0e-1) @@ -718,10 +670,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call set_regrid_max_depths(CS, z_max, GV%m_to_H) elseif (index(trim(string),'FNC1:')==1) then call dz_function1( trim(string(6:)), dz_max ) - if ((coordinateMode(coord_mode) == REGRIDDING_SLIGHT) .and. & - (dz_fixed_sfc > 0.0)) then - do k=1,nz_fixed_sfc ; dz_max(k) = dz_fixed_sfc ; enddo - endif z_max(1) = 0.0 ; do K=1,ke ; z_max(K+1) = z_max(K) + dz_max(K) ; enddo call log_param(param_file, mdl, "!MAXIMUM_INT_DEPTHS", z_max, & trim(message), units=coordinateUnits(coord_mode)) @@ -803,7 +751,6 @@ subroutine end_regridding(CS) if (associated(CS%sigma_CS)) call end_coord_sigma(CS%sigma_CS) if (associated(CS%rho_CS)) call end_coord_rho(CS%rho_CS) if (associated(CS%hycom_CS)) call end_coord_hycom(CS%hycom_CS) - if (associated(CS%slight_CS)) call end_coord_slight(CS%slight_CS) if (associated(CS%adapt_CS)) call end_coord_adapt(CS%adapt_CS) if (associated(CS%hybgen_CS)) call end_hybgen_regrid(CS%hybgen_CS) @@ -877,9 +824,6 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & case ( REGRIDDING_HYBGEN ) call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) - case ( REGRIDDING_SLIGHT ) - call build_grid_SLight( G, GV, G%US, h, tv, dzInterface, CS ) - call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) @@ -923,7 +867,7 @@ subroutine regridding_preadjust_reqs(CS, do_conv_adj, do_hybgen_unmix, hybgen_CS select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_SIGMA, REGRIDDING_ARBITRARY, & - REGRIDDING_HYCOM1, REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + REGRIDDING_HYCOM1, REGRIDDING_ADAPTIVE ) do_conv_adj = .false. ; do_hybgen_unmix = .false. case ( REGRIDDING_RHO ) do_conv_adj = .true. ; do_hybgen_unmix = .false. @@ -1671,84 +1615,6 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) enddo ; enddo end subroutine build_grid_adaptive -!> Builds a grid that tracks density interfaces for water that is denser than -!! the surface density plus an increment of some number of layers, and uses all -!! lighter layers uniformly above this location. Note that this amounts to -!! interpolating to find the depth of an arbitrary (non-integer) interface index -!! which should make the results vary smoothly in space to the extent that the -!! surface density and interior stratification vary smoothly in space. Over -!! shallow topography, this will tend to give a uniform sigma-like coordinate. -!! For sufficiently shallow water, a minimum grid spacing is used to avoid -!! certain instabilities. -subroutine build_grid_SLight(G, GV, US, h, tv, dzInterface, CS) - type(ocean_grid_type), intent(in) :: G !< Grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] - type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure - type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position - - real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] - real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - - ! Local variables - real :: depth ! Depth of the ocean relative to the mean sea surface height in thickness units [H ~> m or kg m-2] - integer :: i, j, k, nz - real :: h_neglect, h_neglect_edge - - if (CS%remap_answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif - - nz = GV%ke - - call assert((GV%ke == CS%nk), "build_grid_SLight is only written to work "//& - "with the same number of input and target layers.") - call assert(CS%target_density_set, "build_grid_SLight : "//& - "Target densities must be set before build_grid_SLight is called.") - - ! Build grid based on target interface densities - do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 - if (G%mask2dT(i,j)>0.) then - - depth = (G%bathyT(i,j)+G%Z_ref) * GV%Z_to_H - z_col(1) = 0. ! Work downward rather than bottom up - do K=1,nz - z_col(K+1) = z_col(K) + h(i,j,k) - p_col(k) = tv%P_Ref + CS%compressibility_fraction * & - ( 0.5 * ( z_col(K) + z_col(K+1) ) * (GV%H_to_RZ*GV%g_Earth) - tv%P_Ref ) - enddo - - call build_slight_column(CS%slight_CS, tv%eqn_of_state, GV%H_to_RZ*GV%g_Earth, & - GV%H_subroundoff, nz, depth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), p_col, z_col, z_col_new, & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - - ! Calculate the final change in grid position after blending new and old grids - call filtered_grid_motion( CS, nz, z_col, z_col_new, dz_col ) - do K=1,nz+1 ; dzInterface(i,j,K) = -dz_col(K) ; enddo -#ifdef __DO_SAFETY_CHECKS__ - if (dzInterface(i,j,1) /= 0.) stop 'build_grid_SLight: Surface moved?!' - if (dzInterface(i,j,nz+1) /= 0.) stop 'build_grid_SLight: Bottom moved?!' -#endif - - ! This adjusts things robust to round-off errors - call adjust_interface_motion( CS, nz, h(i,j,:), dzInterface(i,j,:) ) - - else ! on land - dzInterface(i,j,:) = 0. - endif ! mask2dT - enddo ; enddo ! i,j - -end subroutine build_grid_SLight - !> Adjust dz_Interface to ensure non-negative future thicknesses subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -2042,7 +1908,7 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) scheme = coordinateMode(coordMode) select case ( scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_ADAPTIVE ) uniformResolution(:) = maxDepth / real(nk) @@ -2085,9 +1951,6 @@ subroutine initCoord(CS, GV, US, coord_mode, param_file) CS%interp_CS) case (REGRIDDING_HYBGEN) call init_hybgen_regrid(CS%hybgen_CS, GV, US, param_file) - case (REGRIDDING_SLIGHT) - call init_coord_slight(CS%slight_CS, CS%nk, CS%ref_pressure, CS%target_density, & - CS%interp_CS, GV%m_to_H) case (REGRIDDING_ADAPTIVE) call init_coord_adapt(CS%adapt_CS, CS%nk, CS%coordinateResolution, GV%m_to_H, US%kg_m3_to_R) end select @@ -2181,8 +2044,6 @@ subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) select case (CS%regridding_scheme) case (REGRIDDING_HYCOM1) call set_hycom_params(CS%hycom_CS, max_interface_depths=CS%max_interface_depths) - case (REGRIDDING_SLIGHT) - call set_slight_params(CS%slight_CS, max_interface_depths=CS%max_interface_depths) end select end subroutine set_regrid_max_depths @@ -2207,8 +2068,6 @@ subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) select case (CS%regridding_scheme) case (REGRIDDING_HYCOM1) call set_hycom_params(CS%hycom_CS, max_layer_thickness=CS%max_layer_thickness) - case (REGRIDDING_SLIGHT) - call set_slight_params(CS%slight_CS, max_layer_thickness=CS%max_layer_thickness) end select end subroutine set_regrid_max_thickness @@ -2320,7 +2179,7 @@ function getCoordinateUnits( CS ) character(len=20) :: getCoordinateUnits select case ( CS%regridding_scheme ) - case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, REGRIDDING_SLIGHT, & + case ( REGRIDDING_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & REGRIDDING_ADAPTIVE ) getCoordinateUnits = 'meter' case ( REGRIDDING_SIGMA_SHELF_ZSTAR ) @@ -2361,8 +2220,6 @@ function getCoordinateShortName( CS ) getCoordinateShortName = 'z-rho' case ( REGRIDDING_HYBGEN ) getCoordinateShortName = 'hybrid' - case ( REGRIDDING_SLIGHT ) - getCoordinateShortName = 's-rho' case ( REGRIDDING_ADAPTIVE ) getCoordinateShortName = 'adaptive' case default @@ -2375,8 +2232,7 @@ end function getCoordinateShortName !> Can be used to set any of the parameters for MOM_regridding. subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_grid_weight, & interp_scheme, depth_of_time_filter_shallow, depth_of_time_filter_deep, & - compress_fraction, ref_pressure, dz_min_surface, nz_fixed_surface, Rho_ML_avg_depth, & - nlay_ML_to_interior, fix_haloclines, halocline_filt_len, halocline_strat_tol, & + compress_fraction, ref_pressure, & integrate_downward_for_e, remap_answers_2018, remap_answer_date, & adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha, adaptDoMin, adaptDrho0) type(regridding_CS), intent(inout) :: CS !< Regridding control structure @@ -2390,18 +2246,6 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri real, optional, intent(in) :: compress_fraction !< Fraction of compressibility to add to potential density [nondim] real, optional, intent(in) :: ref_pressure !< The reference pressure for density-dependent !! coordinates [R L2 T-2 ~> Pa] - real, optional, intent(in) :: dz_min_surface !< The fixed resolution in the topmost - !! SLight_nkml_min layers [H ~> m or kg m-2] - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the top of the model - real, optional, intent(in) :: Rho_ml_avg_depth !< Averaging depth over which to determine mixed layer potential - !! density [H ~> m or kg m-2] - real, optional, intent(in) :: nlay_ML_to_interior !< Number of layers to offset the mixed layer density to find - !! resolved stratification [nondim] - logical, optional, intent(in) :: fix_haloclines !< Detect regions with much weaker stratification in the coordinate - real, optional, intent(in) :: halocline_filt_len !< Length scale over which to filter T & S when looking for - !! spuriously unstable water mass profiles [H ~> m or kg m-2] - real, optional, intent(in) :: halocline_strat_tol !< Value of the stratification ratio that defines a problematic - !! halocline region. logical, optional, intent(in) :: integrate_downward_for_e !< If true, integrate for interface positions downward !! from the top. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions @@ -2466,18 +2310,6 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri call set_hycom_params(CS%hycom_CS, interp_CS=CS%interp_CS) case (REGRIDDING_HYBGEN) ! Do nothing for now. - case (REGRIDDING_SLIGHT) - if (present(min_thickness)) call set_slight_params(CS%slight_CS, min_thickness=min_thickness) - if (present(dz_min_surface)) call set_slight_params(CS%slight_CS, dz_ml_min=dz_min_surface) - if (present(nz_fixed_surface)) call set_slight_params(CS%slight_CS, nz_fixed_surface=nz_fixed_surface) - if (present(Rho_ML_avg_depth)) call set_slight_params(CS%slight_CS, Rho_ML_avg_depth=Rho_ML_avg_depth) - if (present(nlay_ML_to_interior)) call set_slight_params(CS%slight_CS, nlay_ML_offset=nlay_ML_to_interior) - if (present(fix_haloclines)) call set_slight_params(CS%slight_CS, fix_haloclines=fix_haloclines) - if (present(halocline_filt_len)) call set_slight_params(CS%slight_CS, halocline_filter_length=halocline_filt_len) - if (present(halocline_strat_tol)) call set_slight_params(CS%slight_CS, halocline_strat_tol=halocline_strat_tol) - if (present(compress_fraction)) call set_slight_params(CS%slight_CS, compressibility_fraction=compress_fraction) - if (associated(CS%slight_CS) .and. (present(interp_scheme) .or. present(boundary_extrapolation))) & - call set_slight_params(CS%slight_CS, interp_CS=CS%interp_CS) case (REGRIDDING_ADAPTIVE) if (present(adaptTimeRatio)) call set_adapt_params(CS%adapt_CS, adaptTimeRatio=adaptTimeRatio) if (present(adaptZoom)) call set_adapt_params(CS%adapt_CS, adaptZoom=adaptZoom) @@ -2535,7 +2367,7 @@ function getStaticThickness( CS, SSH, depth ) select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & - REGRIDDING_SLIGHT, REGRIDDING_ADAPTIVE ) + REGRIDDING_ADAPTIVE ) if (depth>0.) then z = ssh do k = 1, CS%nk diff --git a/src/ALE/coord_slight.F90 b/src/ALE/coord_slight.F90 deleted file mode 100644 index 4b4ac8a153..0000000000 --- a/src/ALE/coord_slight.F90 +++ /dev/null @@ -1,733 +0,0 @@ -!> Regrid columns for the SLight coordinate -module coord_slight - -! This file is part of MOM6. See LICENSE.md for the license. - -use MOM_error_handler, only : MOM_error, FATAL -use MOM_EOS, only : EOS_type, calculate_compress -use MOM_EOS, only : calculate_density, calculate_density_derivs -use regrid_interp, only : interp_CS_type, regridding_set_ppolys -use regrid_interp, only : NR_ITERATIONS, NR_TOLERANCE, DEGREE_MAX - -implicit none ; private - -!> Control structure containing required parameters for the SLight coordinate -type, public :: slight_CS ; private - - !> Number of layers/levels - integer :: nk - - !> Minimum thickness allowed when building the new grid through regridding [H ~> m or kg m-2] - real :: min_thickness - - !> Reference pressure for potential density calculations [R L2 T-2 ~> Pa] - real :: ref_pressure - - !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. [nondim] - real :: compressibility_fraction - - ! The following 4 parameters were introduced for use with the SLight coordinate: - !> Depth over which to average to determine the mixed layer potential density [H ~> m or kg m-2] - real :: Rho_ML_avg_depth - - !> Number of layers to offset the mixed layer density to find resolved stratification [nondim] - real :: nlay_ml_offset - - !> The number of fixed-thickness layers at the top of the model - integer :: nz_fixed_surface = 2 - - !> The fixed resolution in the topmost SLight_nkml_min layers [H ~> m or kg m-2] - real :: dz_ml_min - - !> If true, detect regions with much weaker stratification in the coordinate - !! than based on in-situ density, and use a stretched coordinate there. - logical :: fix_haloclines = .false. - - !> A length scale over which to filter T & S when looking for spuriously - !! unstable water mass profiles [H ~> m or kg m-2]. - real :: halocline_filter_length - - !> A value of the stratification ratio that defines a problematic halocline region [nondim]. - real :: halocline_strat_tol - - !> Nominal density of interfaces [R ~> kg m-3]. - real, allocatable, dimension(:) :: target_density - - !> Maximum depths of interfaces [H ~> m or kg m-2]. - real, allocatable, dimension(:) :: max_interface_depths - - !> Maximum thicknesses of layers [H ~> m or kg m-2]. - real, allocatable, dimension(:) :: max_layer_thickness - - !> Interpolation control structure - type(interp_CS_type) :: interp_CS -end type slight_CS - -public init_coord_slight, set_slight_params, build_slight_column, end_coord_slight - -contains - -!> Initialise a slight_CS with pointers to parameters -subroutine init_coord_slight(CS, nk, ref_pressure, target_density, interp_CS, m_to_H) - type(slight_CS), pointer :: CS !< Unassociated pointer to hold the control structure - integer, intent(in) :: nk !< Number of layers in the grid - real, intent(in) :: ref_pressure !< Coordinate reference pressure [R L2 T-2 ~> Pa] - real, dimension(:), intent(in) :: target_density !< Nominal density of interfaces [R ~> kg m-3] - type(interp_CS_type), intent(in) :: interp_CS !< Controls for interpolation - real, optional, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - - real :: m_to_H_rescale ! A unit conversion factor. - - if (associated(CS)) call MOM_error(FATAL, "init_coord_slight: CS already associated!") - allocate(CS) - allocate(CS%target_density(nk+1)) - - m_to_H_rescale = 1.0 ; if (present(m_to_H)) m_to_H_rescale = m_to_H - - CS%nk = nk - CS%ref_pressure = ref_pressure - CS%target_density(:) = target_density(:) - CS%interp_CS = interp_CS - - ! Set real parameter default values - CS%compressibility_fraction = 0. ! Nondim. - CS%Rho_ML_avg_depth = 1.0 * m_to_H_rescale - CS%nlay_ml_offset = 2.0 ! Nondim. - CS%dz_ml_min = 1.0 * m_to_H_rescale - CS%halocline_filter_length = 2.0 * m_to_H_rescale - CS%halocline_strat_tol = 0.25 ! Nondim. - -end subroutine init_coord_slight - -!> This subroutine deallocates memory in the control structure for the coord_slight module -subroutine end_coord_slight(CS) - type(slight_CS), pointer :: CS !< Coordinate control structure - - ! nothing to do - if (.not. associated(CS)) return - deallocate(CS%target_density) - deallocate(CS) -end subroutine end_coord_slight - -!> This subroutine can be used to set the parameters for the coord_slight module -subroutine set_slight_params(CS, max_interface_depths, max_layer_thickness, & - min_thickness, compressibility_fraction, dz_ml_min, & - nz_fixed_surface, Rho_ML_avg_depth, nlay_ML_offset, fix_haloclines, & - halocline_filter_length, halocline_strat_tol, interp_CS) - type(slight_CS), pointer :: CS !< Coordinate control structure - real, dimension(:), & - optional, intent(in) :: max_interface_depths !< Maximum depths of interfaces [H ~> m or kg m-2] - real, dimension(:), & - optional, intent(in) :: max_layer_thickness !< Maximum thicknesses of layers [H ~> m or kg m-2] - real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the - !! new grid through regridding [H ~> m or kg m-2] - real, optional, intent(in) :: compressibility_fraction !< Fraction (between 0 and 1) of - !! compressibility to add to potential density profiles when - !! interpolating for target grid positions. [nondim] - real, optional, intent(in) :: dz_ml_min !< The fixed resolution in the topmost - !! SLight_nkml_min layers [H ~> m or kg m-2] - integer, optional, intent(in) :: nz_fixed_surface !< The number of fixed-thickness layers at the - !! top of the model - real, optional, intent(in) :: Rho_ML_avg_depth !< Depth over which to average to determine - !! the mixed layer potential density [H ~> m or kg m-2] - real, optional, intent(in) :: nlay_ML_offset !< Number of layers to offset the mixed layer - !! density to find resolved stratification [nondim] - logical, optional, intent(in) :: fix_haloclines !< If true, detect regions with much weaker than - !! based on in-situ density, and use a stretched coordinate there. - real, optional, intent(in) :: halocline_filter_length !< A length scale over which to filter T & S - !! when looking for spuriously unstable water mass profiles [H ~> m or kg m-2]. - real, optional, intent(in) :: halocline_strat_tol !< A value of the stratification ratio that - !! defines a problematic halocline region [nondim]. - type(interp_CS_type), & - optional, intent(in) :: interp_CS !< Controls for interpolation - - if (.not. associated(CS)) call MOM_error(FATAL, "set_slight_params: CS not associated") - - if (present(max_interface_depths)) then - if (size(max_interface_depths) /= CS%nk+1) & - call MOM_error(FATAL, "set_slight_params: max_interface_depths inconsistent size") - allocate(CS%max_interface_depths(CS%nk+1)) - CS%max_interface_depths(:) = max_interface_depths(:) - endif - - if (present(max_layer_thickness)) then - if (size(max_layer_thickness) /= CS%nk) & - call MOM_error(FATAL, "set_slight_params: max_layer_thickness inconsistent size") - allocate(CS%max_layer_thickness(CS%nk)) - CS%max_layer_thickness(:) = max_layer_thickness(:) - endif - - if (present(min_thickness)) CS%min_thickness = min_thickness - if (present(compressibility_fraction)) CS%compressibility_fraction = compressibility_fraction - - if (present(dz_ml_min)) CS%dz_ml_min = dz_ml_min - if (present(nz_fixed_surface)) CS%nz_fixed_surface = nz_fixed_surface - if (present(Rho_ML_avg_depth)) CS%Rho_ML_avg_depth = Rho_ML_avg_depth - if (present(nlay_ML_offset)) CS%nlay_ML_offset = nlay_ML_offset - if (present(fix_haloclines)) CS%fix_haloclines = fix_haloclines - if (present(halocline_filter_length)) CS%halocline_filter_length = halocline_filter_length - if (present(halocline_strat_tol)) then - if (halocline_strat_tol > 1.0) call MOM_error(FATAL, "set_slight_params: "//& - "HALOCLINE_STRAT_TOL must not exceed 1.0.") - CS%halocline_strat_tol = halocline_strat_tol - endif - - if (present(interp_CS)) CS%interp_CS = interp_CS -end subroutine set_slight_params - -!> Build a SLight coordinate column -subroutine build_slight_column(CS, eqn_of_state, H_to_pres, H_subroundoff, & - nz, depth, h_col, T_col, S_col, p_col, z_col, z_col_new, & - h_neglect, h_neglect_edge) - type(slight_CS), intent(in) :: CS !< Coordinate control structure - type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure - real, intent(in) :: H_to_pres !< A conversion factor from thicknesses to - !! scaled pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real, intent(in) :: H_subroundoff !< GV%H_subroundoff - integer, intent(in) :: nz !< Number of levels - real, intent(in) :: depth !< Depth of ocean bottom (positive [H ~> m or kg m-2]) - real, dimension(nz), intent(in) :: T_col !< T for column [C ~> degC] - real, dimension(nz), intent(in) :: S_col !< S for column [S ~> ppt] - real, dimension(nz), intent(in) :: h_col !< Layer thicknesses [H ~> m or kg m-2] - real, dimension(nz), intent(in) :: p_col !< Layer center pressure [R L2 T-2 ~> Pa] - real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] - real, dimension(nz+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of - !! cell reconstructions [H ~> m or kg m-2]. - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose - !! of edge value calculations [H ~> m or kg m-2]. - ! Local variables - real, dimension(nz) :: rho_col ! Layer densities [R ~> kg m-3] - real, dimension(nz) :: T_f, S_f ! Filtered layer temperature [C ~> degC] and salinity [S ~> ppt] - logical, dimension(nz+1) :: reliable ! If true, this interface is in a reliable position. - real, dimension(nz+1) :: T_int, S_int ! Temperature [C ~> degC] and salinity [S ~> ppt] interpolated to interfaces. - real, dimension(nz+1) :: rho_tmp ! A temporary density [R ~> kg m-3] - real, dimension(nz+1) :: drho_dp ! The partial derivative of density with pressure [T2 L-2 ~> kg m-3 Pa-1] - real, dimension(nz+1) :: p_IS, p_R ! Pressures [R L2 T-2 ~> Pa] - real, dimension(nz+1) :: drhoIS_dT ! The partial derivative of in situ density with temperature - ! in [R C-1 ~> kg m-3 degC-1] - real, dimension(nz+1) :: drhoIS_dS ! The partial derivative of in situ density with salinity - ! in [R S-1 ~> kg m-3 ppt-1] - real, dimension(nz+1) :: drhoR_dT ! The partial derivative of reference density with temperature - ! in [R C-1 ~> kg m-3 degC-1] - real, dimension(nz+1) :: drhoR_dS ! The partial derivative of reference density with salinity - ! in [R S-1 ~> kg m-3 ppt-1] - real, dimension(nz+1) :: strat_rat - real :: H_to_cPa ! A conversion factor from thicknesses to the compressibility fraction times - ! the units of pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] - real :: drIS, drR ! In situ and reference density differences [R ~> kg m-3] - real :: Fn_now, I_HStol, Fn_zero_val ! Nondimensional variables [nondim] - real :: z_int_unst ! The depth where the stratification allows the interior grid to start [H ~> m or kg m-2] - real :: dz ! A uniform layer thickness in very shallow water [H ~> m or kg m-2]. - real :: dz_ur ! The total thickness of an unstable region [H ~> m or kg m-2]. - real :: wgt, cowgt ! A weight and its complement [nondim]. - real :: rho_ml_av ! The average potential density in a near-surface region [R ~> kg m-3]. - real :: H_ml_av ! A thickness to try to use in taking the near-surface average [H ~> m or kg m-2]. - real :: rho_x_z ! A cumulative integral of a density [R H ~> kg m-2 or kg2 m-5]. - real :: z_wt ! The thickness actually used in taking the near-surface average [H ~> m or kg m-2]. - real :: k_interior ! The (real) value of k where the interior grid starts [nondim]. - real :: k_int2 ! The (real) value of k where the interior grid starts [nondim]. - real :: z_interior ! The depth where the interior grid starts [H ~> m or kg m-2]. - real :: z_ml_fix ! The depth at which the fixed-thickness near-surface layers end [H ~> m or kg m-2]. - real :: dz_dk ! The thickness of layers between the fixed-thickness - ! near-surface layars and the interior [H ~> m or kg m-2]. - real :: Lfilt ! A filtering lengthscale [H ~> m or kg m-2]. - logical :: maximum_depths_set ! If true, the maximum depths of interface have been set. - logical :: maximum_h_set ! If true, the maximum layer thicknesses have been set. - real :: h_tr, b_denom_1, b1, d1 ! Temporary variables used by the tridiagonal solver. - real, dimension(nz) :: c1 ! Temporary variables used by the tridiagonal solver. - integer :: kur1, kur2 ! The indicies at the top and bottom of an unreliable region. - integer :: kur_ss ! The index to start with in the search for the next unstable region. - integer :: k, nkml - - maximum_depths_set = allocated(CS%max_interface_depths) - maximum_h_set = allocated(CS%max_layer_thickness) - - if (z_col(nz+1) - z_col(1) < nz*CS%min_thickness) then - ! This is a nearly massless total depth, so distribute the water evenly. - dz = (z_col(nz+1) - z_col(1)) / real(nz) - do K=2,nz ; z_col_new(K) = z_col(1) + dz*real(K-1) ; enddo - else - call calculate_density(T_col, S_col, p_col, rho_col, eqn_of_state) - - ! Find the locations of the target potential densities, flagging - ! locations in apparently unstable regions as not reliable. - call rho_interfaces_col(rho_col, h_col, z_col, CS%target_density, nz, & - z_col_new, CS, reliable, debug=.true., & - h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - - ! Ensure that the interfaces are at least CS%min_thickness apart. - if (CS%min_thickness > 0.0) then - ! Move down interfaces below overly thin layers. - do K=2,nz ; if (z_col_new(K) < z_col_new(K-1) + CS%min_thickness) then - z_col_new(K) = z_col_new(K-1) + CS%min_thickness - endif ; enddo - ! Now move up any interfaces that are too close to the bottom. - do K=nz,2,-1 ; if (z_col_new(K) > z_col_new(K+1) - CS%min_thickness) then - z_col_new(K) = z_col_new(K+1) - CS%min_thickness - else - exit ! No more interfaces can be too close to the bottom. - endif ; enddo - endif - - ! Fix up the unreliable regions. - kur_ss = 2 ! reliable(1) and reliable(nz+1) must always be true. - do - ! Search for the uppermost unreliable interface postion. - kur1 = nz+2 - do K=kur_ss,nz ; if (.not.reliable(K)) then - kur1 = K ; exit - endif ; enddo - if (kur1 > nz) exit ! Everything is now reliable. - - kur2 = kur1-1 ! For error checking. - do K=kur1+1,nz+1 ; if (reliable(K)) then - kur2 = K-1 ; kur_ss = K ; exit - endif ; enddo - if (kur2 < kur1) call MOM_error(FATAL, "Bad unreliable range.") - - dz_ur = z_col_new(kur2+1) - z_col_new(kur1-1) - ! drho = CS%target_density(kur2+1) - CS%target_density(kur1-1) - ! Perhaps reset the wgt and cowgt depending on how bad the old interface - ! locations were. - wgt = 1.0 ; cowgt = 0.0 ! = 1.0-wgt - do K=kur1,kur2 - z_col_new(K) = cowgt*z_col_new(K) + & - wgt * (z_col_new(kur1-1) + dz_ur*(K - (kur1-1)) / ((kur2 - kur1) + 2)) - enddo - enddo - - ! Determine which interfaces are in the s-space region and the depth extent - ! of this region. - z_wt = 0.0 ; rho_x_z = 0.0 - H_ml_av = CS%Rho_ml_avg_depth - do k=1,nz - if (z_wt + h_col(k) >= H_ml_av) then - rho_x_z = rho_x_z + rho_col(k) * (H_ml_av - z_wt) - z_wt = H_ml_av - exit - else - rho_x_z = rho_x_z + rho_col(k) * h_col(k) - z_wt = z_wt + h_col(k) - endif - enddo - if (z_wt > 0.0) rho_ml_av = rho_x_z / z_wt - - nkml = CS%nz_fixed_surface - ! Find the interface that matches rho_ml_av. - if (rho_ml_av <= CS%target_density(nkml)) then - k_interior = CS%nlay_ml_offset + real(nkml) - elseif (rho_ml_av > CS%target_density(nz+1)) then - k_interior = real(nz+1) - else ; do K=nkml,nz - if ((rho_ml_av >= CS%target_density(K)) .and. & - (rho_ml_av < CS%target_density(K+1))) then - k_interior = (CS%nlay_ml_offset + K) + & - (rho_ml_av - CS%target_density(K)) / & - (CS%target_density(K+1) - CS%target_density(K)) - exit - endif - enddo ; endif - if (k_interior > real(nz+1)) k_interior = real(nz+1) - - ! Linearly interpolate to find z_interior. This could be made more sophisticated. - K = int(ceiling(k_interior)) - z_interior = (K-k_interior)*z_col_new(K-1) + (1.0+(k_interior-K))*z_col_new(K) - - if (CS%fix_haloclines) then - ! ! Identify regions above the reference pressure where the chosen - ! ! potential density significantly underestimates the actual - ! ! stratification, and use these to find a second estimate of - ! ! z_int_unst and k_interior. - - if (CS%halocline_filter_length > 0.0) then - Lfilt = CS%halocline_filter_length - - ! Filter the temperature and salnity with a fixed lengthscale. - h_tr = h_col(1) + H_subroundoff - b1 = 1.0 / (h_tr + Lfilt) ; d1 = h_tr * b1 - T_f(1) = (b1*h_tr)*T_col(1) ; S_f(1) = (b1*h_tr)*S_col(1) - do k=2,nz - c1(k) = Lfilt * b1 - h_tr = h_col(k) + H_subroundoff ; b_denom_1 = h_tr + d1*Lfilt - b1 = 1.0 / (b_denom_1 + Lfilt) ; d1 = b_denom_1 * b1 - T_f(k) = b1 * (h_tr*T_col(k) + Lfilt*T_f(k-1)) - S_f(k) = b1 * (h_tr*S_col(k) + Lfilt*S_f(k-1)) - enddo - do k=nz-1,1,-1 - T_f(k) = T_f(k) + c1(k+1)*T_f(k+1) ; S_f(k) = S_f(k) + c1(k+1)*S_f(k+1) - enddo - else - do k=1,nz ; T_f(k) = T_col(k) ; S_f(k) = S_col(k) ; enddo - endif - - T_int(1) = T_f(1) ; S_int(1) = S_f(1) - do K=2,nz - T_int(K) = 0.5*(T_f(k-1) + T_f(k)) ; S_int(K) = 0.5*(S_f(k-1) + S_f(k)) - p_IS(K) = z_col(K) * H_to_pres - p_R(K) = CS%ref_pressure + CS%compressibility_fraction * ( p_IS(K) - CS%ref_pressure ) - enddo - T_int(nz+1) = T_f(nz) ; S_int(nz+1) = S_f(nz) - p_IS(nz+1) = z_col(nz+1) * H_to_pres - call calculate_density_derivs(T_int, S_int, p_IS, drhoIS_dT, drhoIS_dS, & - eqn_of_state, (/2,nz/) ) - call calculate_density_derivs(T_int, S_int, p_R, drhoR_dT, drhoR_dS, & - eqn_of_state, (/2,nz/) ) - if (CS%compressibility_fraction > 0.0) then - call calculate_compress(T_int, S_int, p_R(:), rho_tmp, drho_dp, eqn_of_state, (/2,nz/)) - else - do K=2,nz ; drho_dp(K) = 0.0 ; enddo - endif - - H_to_cPa = CS%compressibility_fraction * H_to_pres - strat_rat(1) = 1.0 - do K=2,nz - drIS = drhoIS_dT(K) * (T_f(k) - T_f(k-1)) + & - drhoIS_dS(K) * (S_f(k) - S_f(k-1)) - drR = (drhoR_dT(K) * (T_f(k) - T_f(k-1)) + & - drhoR_dS(K) * (S_f(k) - S_f(k-1))) + & - drho_dp(K) * (H_to_cPa*0.5*(h_col(k) + h_col(k-1))) - - if (drIS <= 0.0) then - strat_rat(K) = 2.0 ! Maybe do this? => ; if (drR < 0.0) strat_rat(K) = -2.0 - else - strat_rat(K) = 2.0*max(drR,0.0) / (drIS + abs(drR)) - endif - enddo - strat_rat(nz+1) = 1.0 - - z_int_unst = 0.0 ; Fn_now = 0.0 - Fn_zero_val = min(2.0*CS%halocline_strat_tol, & - 0.5*(1.0 + CS%halocline_strat_tol)) - if (CS%halocline_strat_tol > 0.0) then - ! Use Adcroft's reciprocal rule. - I_HStol = 0.0 ; if (Fn_zero_val - CS%halocline_strat_tol > 0.0) & - I_HStol = 1.0 / (Fn_zero_val - CS%halocline_strat_tol) - do k=nz,1,-1 ; if (CS%ref_pressure > p_IS(k+1)) then - z_int_unst = z_int_unst + Fn_now * h_col(k) - if (strat_rat(K) <= Fn_zero_val) then - if (strat_rat(K) <= CS%halocline_strat_tol) then ; Fn_now = 1.0 - else - Fn_now = max(Fn_now, (Fn_zero_val - strat_rat(K)) * I_HStol) - endif - endif - endif ; enddo - else - do k=nz,1,-1 ; if (CS%ref_pressure > p_IS(k+1)) then - z_int_unst = z_int_unst + Fn_now * h_col(k) - if (strat_rat(K) <= CS%halocline_strat_tol) Fn_now = 1.0 - endif ; enddo - endif - - if (z_interior < z_int_unst) then - ! Find a second estimate of the extent of the s-coordinate region. - kur1 = max(int(ceiling(k_interior)),2) - if (z_col_new(kur1-1) < z_interior) then - k_int2 = kur1 - do K = kur1,nz+1 ; if (z_col_new(K) >= z_int_unst) then - ! This is linear interpolation again. - if (z_col_new(K-1) >= z_int_unst) & - call MOM_error(FATAL,"build_grid_SLight, bad halocline structure.") - k_int2 = real(K-1) + (z_int_unst - z_col_new(K-1)) / & - (z_col_new(K) - z_col_new(K-1)) - exit - endif ; enddo - if (z_col_new(nz+1) < z_int_unst) then - ! This should be unnecessary. - z_int_unst = z_col_new(nz+1) ; k_int2 = real(nz+1) - endif - - ! Now take the larger values. - if (k_int2 > k_interior) then - k_interior = k_int2 ; z_interior = z_int_unst - endif - endif - endif - endif ! fix_haloclines - - z_col_new(1) = 0.0 - do K=2,nkml+1 - z_col_new(K) = min((K-1)*CS%dz_ml_min, & - z_col_new(nz+1) - CS%min_thickness*(nz+1-K)) - enddo - z_ml_fix = z_col_new(nkml+1) - if (z_interior > z_ml_fix) then - dz_dk = (z_interior - z_ml_fix) / (k_interior - (nkml+1)) - do K=nkml+2,int(floor(k_interior)) - z_col_new(K) = z_ml_fix + dz_dk * (K - (nkml+1)) - enddo - else ! The fixed-thickness z-region penetrates into the interior. - do K=nkml+2,nz - if (z_col_new(K) <= z_col_new(CS%nz_fixed_surface+1)) then - z_col_new(K) = z_col_new(CS%nz_fixed_surface+1) - else ; exit ; endif - enddo - endif - - if (maximum_depths_set .and. maximum_h_set) then ; do k=2,nz - ! The loop bounds are 2 & nz so the top and bottom interfaces do not move. - ! Recall that z_col_new is positive downward. - z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K), & - z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; elseif (maximum_depths_set) then ; do K=2,nz - z_col_new(K) = min(z_col_new(K), CS%max_interface_depths(K)) - enddo ; elseif (maximum_h_set) then ; do k=2,nz - z_col_new(K) = min(z_col_new(K), z_col_new(K-1) + CS%max_layer_thickness(k-1)) - enddo ; endif - - endif ! Total thickness exceeds nz*CS%min_thickness. - -end subroutine build_slight_column - -!> Finds the new interface locations in a column of water that match the -!! prescribed target densities. -subroutine rho_interfaces_col(rho_col, h_col, z_col, rho_tgt, nz, z_col_new, & - CS, reliable, debug, h_neglect, h_neglect_edge) - integer, intent(in) :: nz !< Number of layers - real, dimension(nz), intent(in) :: rho_col !< Initial layer reference densities [R ~> kg m-3]. - real, dimension(nz), intent(in) :: h_col !< Initial layer thicknesses [H ~> m or kg m-2]. - real, dimension(nz+1), intent(in) :: z_col !< Initial interface heights [H ~> m or kg m-2]. - real, dimension(nz+1), intent(in) :: rho_tgt !< Interface target densities. - real, dimension(nz+1), intent(inout) :: z_col_new !< New interface heights [H ~> m or kg m-2]. - type(slight_CS), intent(in) :: CS !< Coordinate control structure - logical, dimension(nz+1), intent(inout) :: reliable !< If true, the interface positions - !! are well defined from a stable region. - logical, optional, intent(in) :: debug !< If present and true, do debugging checks. - real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of - !! cell reconstructions [H ~> m or kg m-2] - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose - !! of edge value calculations [H ~> m or kg m-2] - - real, dimension(nz+1) :: ru_max_int ! The maximum and minimum densities in - real, dimension(nz+1) :: ru_min_int ! an unstable region around an interface [R ~> kg m-3]. - real, dimension(nz) :: ru_max_lay ! The maximum and minimum densities in - real, dimension(nz) :: ru_min_lay ! an unstable region containing a layer [R ~> kg m-3]. - real, dimension(nz,2) :: ppoly_i_E ! Edge value of polynomial [R ~> kg m-3] - real, dimension(nz,2) :: ppoly_i_S ! Edge slope of polynomial [R H-1 ~> kg m-4 or m-1] - real, dimension(nz,DEGREE_MAX+1) :: ppoly_i_coefficients ! Coefficients of polynomial [R ~> kg m-3] - logical, dimension(nz) :: unstable_lay ! If true, this layer is in an unstable region. - logical, dimension(nz+1) :: unstable_int ! If true, this interface is in an unstable region. - real :: rt ! The current target density [R ~> kg m-3]. - real :: zf ! The fractional z-position within a layer of the target density [nondim]. - real :: rfn ! The target density relative to the interpolated density [R ~> kg m-3] - real :: a(5) ! Coefficients of a local polynomial minus the target density [R ~> kg m-3]. - real :: zf1, zf2 ! Two previous estimates of zf [nondim] - real :: rfn1, rfn2 ! Values of rfn at zf1 and zf2 [R ~> kg m-3] - real :: drfn_dzf ! The partial derivative of rfn with zf [R ~> kg m-3] - real :: sgn, delta_zf, zf_prev ! [nondim] - real :: tol ! The tolerance for convergence of zf [nondim] - logical :: k_found ! If true, the position has been found. - integer :: k_layer ! The index of the stable layer containing an interface. - integer :: ppoly_degree - integer :: k, k1, k1_min, itt, max_itt, m - - real :: z_sgn ! 1 or -1, depending on whether z increases with increasing K. - logical :: debugging - - debugging = .false. ; if (present(debug)) debugging = debug - max_itt = NR_ITERATIONS - tol = NR_TOLERANCE - - z_sgn = 1.0 ; if ( z_col(1) > z_col(nz+1) ) z_sgn = -1.0 - if (debugging) then - do K=1,nz - if (abs((z_col(K+1) - z_col(K)) - z_sgn*h_col(k)) > & - 1.0e-14*(abs(z_col(K+1)) + abs(z_col(K)) + abs(h_col(k))) ) & - call MOM_error(FATAL, "rho_interfaces_col: Inconsistent z_col and h_col") - enddo - endif - - if ( z_col(1) == z_col(nz+1) ) then - ! This is a massless column! - do K=1,nz+1 ; z_col_new(K) = z_col(1) ; reliable(K) = .true. ; enddo - return - endif - - ! This sets up the piecewise polynomials based on the rho_col profile. - call regridding_set_ppolys(CS%interp_CS, rho_col, nz, h_col, ppoly_i_E, ppoly_i_S, & - ppoly_i_coefficients, ppoly_degree, h_neglect, h_neglect_edge) - - ! Determine the density ranges of unstably stratified segments. - ! Interfaces that start out in an unstably stratified segment can - ! only escape if they are outside of the bounds of that segment, and no - ! interfaces are ever mapped into an unstable segment. - unstable_int(1) = .false. - ru_max_int(1) = ppoly_i_E(1,1) - - unstable_lay(1) = (ppoly_i_E(1,1) > ppoly_i_E(1,2)) - ru_max_lay(1) = max(ppoly_i_E(1,1), ppoly_i_E(1,2)) - - do K=2,nz - unstable_int(K) = (ppoly_i_E(k-1,2) > ppoly_i_E(k,1)) - ru_max_int(K) = max(ppoly_i_E(k-1,2), ppoly_i_E(k,1)) - ru_min_int(K) = min(ppoly_i_E(k-1,2), ppoly_i_E(k,1)) - if (unstable_int(K) .and. unstable_lay(k-1)) & - ru_max_int(K) = max(ru_max_lay(k-1), ru_max_int(K)) - - unstable_lay(k) = (ppoly_i_E(k,1) > ppoly_i_E(k,2)) - ru_max_lay(k) = max(ppoly_i_E(k,1), ppoly_i_E(k,2)) - ru_min_lay(k) = min(ppoly_i_E(k,1), ppoly_i_E(k,2)) - if (unstable_lay(k) .and. unstable_int(K)) & - ru_max_lay(k) = max(ru_max_int(K), ru_max_lay(k)) - enddo - unstable_int(nz+1) = .false. - ru_min_int(nz+1) = ppoly_i_E(nz,2) - - do K=nz,1,-1 - if (unstable_lay(k) .and. unstable_int(K+1)) & - ru_min_lay(k) = min(ru_min_int(K+1), ru_min_lay(k)) - - if (unstable_int(K) .and. unstable_lay(k)) & - ru_min_int(K) = min(ru_min_lay(k), ru_min_int(K)) - enddo - - z_col_new(1) = z_col(1) ; reliable(1) = .true. - k1_min = 1 - do K=2,nz ! Find the locations of the various target densities for the interfaces. - rt = rho_tgt(K) - k_layer = -1 - k_found = .false. - - ! Many light layers are found at the top, so start there. - if (rt <= ppoly_i_E(k1_min,1)) then - z_col_new(K) = z_col(k1_min) - k_found = .true. - ! Do not change k1_min for the next layer. - elseif (k1_min == nz+1) then - z_col_new(K) = z_col(nz+1) - else - ! Start with the previous location and search outward. - if (unstable_int(K) .and. (rt >= ru_min_int(K)) .and. (rt <= ru_max_int(K))) then - ! This interface started in an unstable region and should not move due to remapping. - z_col_new(K) = z_col(K) ; reliable(K) = .false. - k1_min = K ; k_found = .true. - elseif ((rt >= ppoly_i_E(k-1,2)) .and. (rt <= ppoly_i_E(k,1))) then - ! This interface is already in the right place and does not move. - z_col_new(K) = z_col(K) ; reliable(K) = .true. - k1_min = K ; k_found = .true. - elseif (rt < ppoly_i_E(k-1,2)) then ! Search upward - do k1=K-1,k1_min,-1 - ! Check whether rt is in layer k. - if ((rt < ppoly_i_E(k1,2)) .and. (rt > ppoly_i_E(k1,1))) then - ! rt is in layer k. - k_layer = k1 - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_lay(k1) .and. (rt >= ru_min_lay(k1)) .and. (rt <= ru_max_lay(K1))) then - ! rt would be found at unstable layer that it can not penetrate. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1+1) ; reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif - ! Check whether rt is at interface K. - if (k1 > 1) then ; if ((rt <= ppoly_i_E(k1,1)) .and. (rt >= ppoly_i_E(k1-1,2))) then - ! rt is at interface K1 - z_col_new(K) = z_col(K1) ; reliable(K) = .true. - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_int(K1) .and. (rt >= ru_min_int(k1)) .and. (rt <= ru_max_int(K1))) then - ! rt would be found at an unstable interface that it can not pass. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1) ; reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif ; endif - enddo - - if (.not.k_found) then - ! This should not happen unless k1_min = 1. - if (k1_min < 2) then - z_col_new(K) = z_col(k1_min) - else - z_col_new(K) = z_col(k1_min) - endif - endif - - else ! Search downward - do k1=K,nz - if ((rt < ppoly_i_E(k1,2)) .and. (rt > ppoly_i_E(k1,1))) then - ! rt is in layer k. - k_layer = k1 - k1_min = k1 ; k_found = .true. ; exit - elseif (unstable_lay(k1) .and. (rt >= ru_min_lay(k1)) .and. (rt <= ru_max_lay(K1))) then - ! rt would be found at unstable layer that it can not penetrate. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1) - reliable(K) = .false. - k1_min = k1 ; k_found = .true. ; exit - endif - if (k1 < nz) then ; if ((rt <= ppoly_i_E(k1+1,1)) .and. (rt >= ppoly_i_E(k1,2))) then - ! rt is at interface K1+1 - - z_col_new(K) = z_col(K1+1) ; reliable(K) = .true. - k1_min = k1+1 ; k_found = .true. ; exit - elseif (unstable_int(K1+1) .and. (rt >= ru_min_int(k1+1)) .and. (rt <= ru_max_int(K1+1))) then - ! rt would be found at an unstable interface that it can not pass. - ! It is possible that this can never happen? - z_col_new(K) = z_col(K1+1) - reliable(K) = .false. - k1_min = k1+1 ; k_found = .true. ; exit - endif ; endif - enddo - if (.not.k_found) then - z_col_new(K) = z_col(nz+1) - if (rt >= ppoly_i_E(nz,2)) then - reliable(K) = .true. - else - reliable(K) = .false. - endif - endif - endif - - if (k_layer > 0) then ! The new location is inside of layer k_layer. - ! Note that this is coded assuming that this layer is stably stratified. - if (.not.(ppoly_i_E(k1,2) > ppoly_i_E(k1,1))) call MOM_error(FATAL, & - "build_grid_SLight: Erroneously searching for an interface in an unstratified layer.") - - ! Use the false position method to find the location (degree <= 1) or the first guess. - zf = (rt - ppoly_i_E(k1,1)) / (ppoly_i_E(k1,2) - ppoly_i_E(k1,1)) - - if (ppoly_degree > 1) then ! Iterate to find the solution. - a(:) = 0.0 ; a(1) = ppoly_i_coefficients(k_layer,1) - rt - do m=2,ppoly_degree+1 ; a(m) = ppoly_i_coefficients(k_layer,m) ; enddo - ! Bracket the root. - zf1 = 0.0 ; rfn1 = a(1) - zf2 = 1.0 ; rfn2 = a(1) + (a(2) + (a(3) + (a(4) + a(5)))) - if (rfn1 * rfn2 > 0.0) call MOM_error(FATAL, "build_grid_SLight: Bad bracketing.") - - do itt=1,max_itt - rfn = a(1) + zf*(a(2) + zf*(a(3) + zf*(a(4) + zf*a(5)))) - ! Reset one of the ends of the bracket. - if (rfn * rfn1 > 0.0) then - zf1 = zf ; rfn1 = rfn - else - zf2 = zf ; rfn2 = rfn - endif - if (rfn1 == rfn2) exit - - drfn_dzf = (a(2) + zf*(2.0*a(3) + zf*(3.0*a(4) + zf*4.0*a(5)))) - sgn = 1.0 ; if (drfn_dzf < 0.0) sgn = -1.0 - - if ((sgn*(zf - rfn) >= zf1 * abs(drfn_dzf)) .and. & - (sgn*(zf - rfn) <= zf2 * abs(drfn_dzf))) then - delta_zf = -rfn / drfn_dzf - zf = zf + delta_zf - else ! Newton's method goes out of bounds, so use a false position method estimate - zf_prev = zf - zf = ( rfn2 * zf1 - rfn1 * zf2 ) / (rfn2 - rfn1) - delta_zf = zf - zf_prev - endif - - if (abs(delta_zf) < tol) exit - enddo - endif - z_col_new(K) = z_col(k_layer) + zf * z_sgn * h_col(k_layer) - reliable(K) = .true. - endif - - endif - - enddo - z_col_new(nz+1) = z_col(nz+1) ; reliable(nz+1) = .true. - -end subroutine rho_interfaces_col - -end module coord_slight diff --git a/src/ALE/regrid_consts.F90 b/src/ALE/regrid_consts.F90 index 9fe638dd5b..0c5ccf268f 100644 --- a/src/ALE/regrid_consts.F90 +++ b/src/ALE/regrid_consts.F90 @@ -16,8 +16,6 @@ module regrid_consts integer, parameter :: REGRIDDING_SIGMA = 4 !< Sigma coordinates identifier integer, parameter :: REGRIDDING_ARBITRARY = 5 !< Arbitrary coordinates identifier integer, parameter :: REGRIDDING_HYCOM1 = 6 !< Simple HyCOM coordinates without BBL -integer, parameter :: REGRIDDING_SLIGHT = 7 !< Identifier for stretched coordinates in the - !! lightest water, isopycnal below integer, parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR = 8 !< Identifiered for z* coordinates at the bottom, !! sigma-near the top integer, parameter :: REGRIDDING_ADAPTIVE = 9 !< Adaptive coordinate mode identifier @@ -31,7 +29,6 @@ module regrid_consts character(len=*), parameter :: REGRIDDING_ARBITRARY_STRING = "ARB" !< Arbitrary coordinates character(len=*), parameter :: REGRIDDING_HYCOM1_STRING = "HYCOM1" !< Hycom string character(len=*), parameter :: REGRIDDING_HYBGEN_STRING = "HYBGEN" !< Hybgen string -character(len=*), parameter :: REGRIDDING_SLIGHT_STRING = "SLIGHT" !< Hybrid S-rho string character(len=*), parameter :: REGRIDDING_SIGMA_SHELF_ZSTAR_STRING = "SIGMA_SHELF_ZSTAR" !< Hybrid z*/sigma character(len=*), parameter :: REGRIDDING_ADAPTIVE_STRING = "ADAPTIVE" !< Adaptive coordinate string character(len=*), parameter :: DEFAULT_COORDINATE_MODE = REGRIDDING_LAYER_STRING !< Default coordinate mode @@ -63,7 +60,6 @@ function coordinateMode(string) case (trim(REGRIDDING_SIGMA_STRING)); coordinateMode = REGRIDDING_SIGMA case (trim(REGRIDDING_HYCOM1_STRING)); coordinateMode = REGRIDDING_HYCOM1 case (trim(REGRIDDING_HYBGEN_STRING)); coordinateMode = REGRIDDING_HYBGEN - case (trim(REGRIDDING_SLIGHT_STRING)); coordinateMode = REGRIDDING_SLIGHT case (trim(REGRIDDING_ARBITRARY_STRING)); coordinateMode = REGRIDDING_ARBITRARY case (trim(REGRIDDING_SIGMA_SHELF_ZSTAR_STRING)); coordinateMode = REGRIDDING_SIGMA_SHELF_ZSTAR case (trim(REGRIDDING_ADAPTIVE_STRING)); coordinateMode = REGRIDDING_ADAPTIVE @@ -85,7 +81,6 @@ function coordinateUnitsI(coordMode) case (REGRIDDING_SIGMA); coordinateUnitsI = "Non-dimensional" case (REGRIDDING_HYCOM1); coordinateUnitsI = "m" case (REGRIDDING_HYBGEN); coordinateUnitsI = "m" - case (REGRIDDING_SLIGHT); coordinateUnitsI = "m" case (REGRIDDING_ADAPTIVE); coordinateUnitsI = "m" case default ; call MOM_error(FATAL, "coordinateUnts: "//& "Unrecognized coordinate mode.") @@ -121,7 +116,6 @@ logical function state_dependent_int(mode) case (REGRIDDING_SIGMA); state_dependent_int = .false. case (REGRIDDING_HYCOM1); state_dependent_int = .true. case (REGRIDDING_HYBGEN); state_dependent_int = .true. - case (REGRIDDING_SLIGHT); state_dependent_int = .true. case (REGRIDDING_ADAPTIVE); state_dependent_int = .true. case default ; call MOM_error(FATAL, "state_dependent: "//& "Unrecognized choice of coordinate.") diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 99e6c386c6..9152efa9ec 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -73,6 +73,14 @@ subroutine find_obsolete_params(param_file) call obsolete_real(param_file, "ZSTAR_RIGID_SURFACE_THRESHOLD") call obsolete_logical(param_file, "HENYEY_IGW_BACKGROUND_NEW") + call obsolete_real(param_file, "SLIGHT_DZ_SURFACE") + call obsolete_int(param_file, "SLIGHT_NZ_SURFACE_FIXED") + call obsolete_real(param_file, "SLIGHT_SURFACE_AVG_DEPTH") + call obsolete_real(param_file, "SLIGHT_NLAY_TO_INTERIOR") + call obsolete_logical(param_file, "SLIGHT_FIX_HALOCLINES") + call obsolete_real(param_file, "HALOCLINE_FILTER_LENGTH") + call obsolete_real(param_file, "HALOCLINE_STRAT_TOL") + ! Test for inconsistent parameter settings. split = .true. ; test_logic = .false. call read_param(param_file,"SPLIT",split) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cd5682d2d9..ff0eda6325 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -327,10 +327,6 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) - elseif (remap_cs%vertical_coord == coordinateMode('SLIGHT')) then -! call build_slight_column(remap_cs%regrid_cs,remap_cs%remap_cs, nz, & -! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: SLIGHT coordinate not coded for diagnostics yet!") elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then ! call build_hycom1_column(remap_cs%regrid_cs, nz, & ! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) From a6f813e059c2b07dfb27b1bbd2b9e501d1817fba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 13 Mar 2023 14:10:14 -0400 Subject: [PATCH 230/629] (*)Fix MOM_calc_grad_Coriolis GLOBAL_INDEXING bug Fixed a bug in MOM_calculate_grad_Coriolis() that was causing the model to hang due to mismatched halo updates when GLOBAL_INDEXING = True. Also added missing callTree (a.k.a. granny tracker) calls at the start and end of the same routine. All answers are bitwise identical in any cases that worked before. --- src/initialization/MOM_shared_initialization.F90 | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 2981bb9e94..46d0448699 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -96,11 +96,13 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) intent(out) :: dF_dy !< y-component of grad f [T-1 L-1 ~> s-1 m-1] type(unit_scale_type), optional, intent(in) :: US !< A dimensional unit scaling type ! Local variables + character(len=40) :: mdl = "MOM_calculate_grad_Coriolis" ! This subroutine's name. integer :: i,j real :: f1, f2 ! Average of adjacent Coriolis parameters [T-1 ~> s-1] + call callTree_enter(trim(mdl)//"(), MOM_shared_initialization.F90") if ((LBOUND(G%CoriolisBu,1) > G%isc-1) .or. & - (LBOUND(G%CoriolisBu,2) > G%isc-1)) then + (LBOUND(G%CoriolisBu,2) > G%jsc-1)) then ! The gradient of the Coriolis parameter can not be calculated with this grid. dF_dx(:,:) = 0.0 ; dF_dy(:,:) = 0.0 return @@ -115,6 +117,7 @@ subroutine MOM_calculate_grad_Coriolis(dF_dx, dF_dy, G, US) dF_dy(i,j) = G%IdyT(i,j) * ( f1 - f2 ) enddo ; enddo call pass_vector(dF_dx, dF_dy, G%Domain, stagger=AGRID) + call callTree_leave(trim(mdl)//'()') end subroutine MOM_calculate_grad_Coriolis From 30371003eb5b139b726c67f14e1f420c19978973 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 2 Jun 2022 15:14:59 -0400 Subject: [PATCH 231/629] 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 232/629] 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 233/629] 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 234/629] +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 235/629] 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 236/629] +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 237/629] 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 238/629] 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 239/629] 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 240/629] (*)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 241/629] +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 242/629] +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 243/629] 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 244/629] (*)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 245/629] +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 246/629] *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 247/629] +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 248/629] 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 249/629] *+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 250/629] +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 251/629] (*)+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 252/629] *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 253/629] *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 254/629] +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 255/629] +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 256/629] *+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 257/629] +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 258/629] 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 259/629] *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 260/629] +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 261/629] *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 262/629] +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 263/629] +*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 264/629] 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 265/629] +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 266/629] +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 267/629] +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 268/629] 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 269/629] 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 270/629] Add .nc extension to ALE Vertical_coordinate. The `Vertical_coordinate.nc` files has two points of creation, MOM_coord_initialization and MOM_ALE. Having moved the file from the infra to netCDF I/O layer, the .nc extension is no longer automatically applied. The extension was explicitly added to `Vertical_coordinate` in MOM_coord_initialization, but not to MOM_ALE. This patch adds the extension. Thanks to Kate Hedstrom for detecting this and Keith Lindsay for the proposed fix. --- src/ALE/MOM_ALE.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 137f6cee9b..e40bba3e2f 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1456,7 +1456,7 @@ subroutine ALE_writeCoordinateFile( CS, GV, directory ) character(len=240) :: filepath - filepath = trim(directory) // trim("Vertical_coordinate") + filepath = trim(directory) // trim("Vertical_coordinate.nc") call write_regrid_file(CS%regridCS, GV, filepath) From ac11984fdb14f905e7a0cc70dc93bcc1443c12bf Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 26 Apr 2023 15:22:38 -0400 Subject: [PATCH 271/629] Reversion of MOM_mixed_layer_restrat growth_time Due to some machines reporting a regression in the mixed layer restratification code, this patch reverts the calculation of the growth time in a separate function. Most of the content related to comments and parameter setup have been retained, even if those parameters are no longer used. --- .../lateral/MOM_mixed_layer_restrat.F90 | 89 +++++++++++++++++-- 1 file changed, 81 insertions(+), 8 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index ffdf236152..fe31eb0de3 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -159,6 +159,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] @@ -194,6 +195,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var real :: dh ! Portion of the layer thickness that is in the mixed layer [H ~> m or kg m-2] real :: res_scaling_fac ! The resolution-dependent scaling factor [nondim] real :: I_LFront ! The inverse of the frontal length scale [L-1 ~> m-1] + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] logical :: line_is_empty, keep_going, res_upscale integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -205,6 +208,8 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var covTS(:) = 0.0 !!Functionality not implemented yet; in future, should be passed in tv varS(:) = 0.0 + vonKar_x_pi2 = CS%vonKar * 9.8696 + if (.not.associated(tv%eqn_of_state)) call MOM_error(FATAL, "MOM_mixedlayer_restrat: "// & "An equation of state must be used with this module.") if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & @@ -316,7 +321,7 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,timescale, & + !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & !$OMP line_is_empty, keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) @@ -379,21 +384,40 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$OMP do do j=js,je ; do I=is-1,ie u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( G%dxCu(I,j)**2 + G%dyCu(I,j)**2 ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i+1,j) ) ) + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef + if (res_upscale) timescale = timescale * res_scaling_fac uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) ! As above but using the slow filtered MLD h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef2 + if (res_upscale) timescale = timescale * res_scaling_fac uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) @@ -447,21 +471,40 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var !$OMP do do J=js-1,je ; do i=is,ie u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f if (res_upscale) res_scaling_fac = & ( sqrt( 0.5 * ( (G%dxCv(i,J))**2 + (G%dyCv(i,J))**2 ) ) * I_LFront ) & * min( 1., 0.5*( VarMix%Rd_dx_h(i,j) + VarMix%Rd_dx_h(i,j+1) ) ) + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef + if (res_upscale) timescale = timescale * res_scaling_fac vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) ! As above but using the slow filtered MLD h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + timescale = timescale * CS%ml_restrat_coef2 + if (res_upscale) timescale = timescale * res_scaling_fac vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) @@ -608,6 +651,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times + ! pi squared [nondim] + real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] @@ -642,6 +688,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt g_Rho0 = GV%g_Earth / GV%Rho0 + vonKar_x_pi2 = CS%vonKar * 9.8696 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff dz_neglect = GV%H_subroundoff*GV%H_to_Z @@ -657,7 +704,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,timescale, & + !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & !$OMP I2htot,z_topx2,hx2,a) & !$OMP firstprivate(uDml,vDml) !$OMP do @@ -689,8 +736,19 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & @@ -729,8 +787,19 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! NOTE: growth_time changes answers on some systems, see below. + ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + + ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + ! momentum mixing rate: pi^2*visc/h_ml^2 + mom_mixrate = vonKar_x_pi2*u_star**2 / & + (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) + + timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & @@ -799,6 +868,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) end subroutine mixedlayer_restrat_BML +! NOTE: This function appears to change answers on some platforms, so it is +! currently unused in the model, but we intend to introduce it in the future. + !> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) real, intent(in) :: u_star !< Surface friction velocity [Z T-1 ~> m s-1] @@ -945,6 +1017,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "used in the MLE scheme. This simply multiplies MLD wherever used.",& units="nondim", default=1.0) endif + call get_param(param_file, mdl, "KV_RESTRAT", CS%Kv_restrat, & "A small viscosity that sets a floor on the momentum mixing rate during "//& "restratification. If this is positive, it will prevent some possible "//& From 82f750e58a08543c5f9ce8eb7bb587533ae60ba4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 4 Apr 2023 08:51:41 -0400 Subject: [PATCH 272/629] +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 273/629] +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 274/629] +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 275/629] (*)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 276/629] (*)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 277/629] 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 278/629] 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 279/629] 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 280/629] 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 281/629] 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 282/629] +*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 283/629] +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 284/629] *+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 285/629] +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 286/629] +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 287/629] 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 288/629] 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 289/629] 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 290/629] 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 291/629] 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 292/629] 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 293/629] 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 294/629] 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 295/629] 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 296/629] 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 297/629] 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 298/629] 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 299/629] 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 300/629] 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 301/629] 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 302/629] 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 303/629] +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 304/629] 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 305/629] 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 306/629] +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 307/629] +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 308/629] *+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 309/629] 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 61baca8eaa02c77a98432445f00ac76db4f706cf Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 6 Jul 2023 15:21:48 -0600 Subject: [PATCH 310/629] Option to taper neutral diffusion This commit adds the option to apply a linear decay in the neutral diffusion fluxes within a transition zone defined by the boundary layer depths of adjacent columns. This option is controlled by a new parameter NDIFF_TAPERING, which is only available when NDIFF_INTERIOR_ONLY=True. By default NDIFF_TAPERING=False and answers are bitwise identical. --- src/tracer/MOM_neutral_diffusion.F90 | 165 ++++++++++++++++++++++++--- 1 file changed, 147 insertions(+), 18 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index d09c3e2870..a49af87a15 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -53,8 +53,16 @@ module MOM_neutral_diffusion !! density [R L2 T-2 ~> Pa] logical :: interior_only !< If true, only applies neutral diffusion in the ocean interior. !! That is, the algorithm will exclude the surface and bottom boundary layers. + logical :: tapering = .false. !< If true, neutral diffusion linearly decays towards zero within a + !! transition zone defined using boundary layer depths. Only available when + !! interior_only=true. logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. + ! Coefficients used to apply tapering from neutral to horizontal direction + real, allocatable, dimension(:) :: coeff_l !< Non-dimensional coefficient in the left column, + !! at cell interfaces + real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, + !! at cell interfaces ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point @@ -172,6 +180,12 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "If true, only applies neutral diffusion in the ocean interior."//& "That is, the algorithm will exclude the surface and bottom"//& "boundary layers.", default=.false.) + if (CS%interior_only) then + call get_param(param_file, mdl, "NDIFF_TAPERING", CS%tapering, & + "If true, neutral diffusion linearly decays to zero within "//& + "a transition zone defined using boundary layer depths. "//& + "Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.) + endif call get_param(param_file, mdl, "NDIFF_USE_UNMASKED_TRANSPORT_BUG", CS%use_unmasked_transport_bug, & "If true, use an older form for the accumulation of neutral-diffusion "//& "transports that were unmasked, as used prior to Jan 2018. This is not "//& @@ -257,6 +271,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then call MOM_error(FATAL,"NDIFF_INTERIOR_ONLY is true, but no valid boundary layer scheme was found") endif + + if (CS%tapering) then + allocate(CS%coeff_l(SZK_(GV)+1), source=0.) + allocate(CS%coeff_r(SZK_(GV)+1), source=0.) + endif endif ! Store a rescaling factor for use in diagnostic messages. CS%R_to_kg_m3 = US%R_to_kg_m3 @@ -585,7 +604,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion ! [H L2 conc ~> m3 conc or kg conc] - + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk @@ -594,6 +613,14 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + ! Check if hbl needs to be extracted + if (CS%tapering) then + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & + m_to_MLD_units=GV%m_to_H) + call pass_var(hbl,G%Domain) + endif + if (.not. CS%continuous_reconstruction) then if (CS%remap_answer_date < 20190101) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 @@ -619,24 +646,53 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! x-flux do j = G%jsc,G%jec ; do I = G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & - tracer%t(i,j,:), tracer%t(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + if (CS%tapering) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, hbl(I,j), hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), CS%coeff_r(:)) + else + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + endif endif enddo ; enddo ! y-flux do J = G%jsc-1,G%jec ; do i = G%isc,G%iec if (G%mask2dCv(i,J)>0.) then - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & - tracer%t(i,j,:), tracer%t(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + if (CS%tapering) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, hbl(i,J), hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), CS%coeff_r(:)) + else + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + endif endif enddo ; enddo @@ -736,6 +792,62 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) end subroutine neutral_diffusion +!> Computes linear tapering coefficients at interfaces of the left and right columns +!! within a region defined by the boundary layer depths in the two columns. +subroutine compute_tapering_coeffs(ne, bld_l, bld_r, coeff_l, coeff_r, h_l, h_r) + integer, intent(in) :: ne !< Number of interfaces + real, intent(in) :: bld_l !< Boundary layer depth, left column [H ~> m or kg m-2] + real, intent(in) :: bld_r !< Boundary layer depth, right column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_l !< Layer thickness, left column [H ~> m or kg m-2] + real, dimension(ne-1), intent(in) :: h_r !< Layer thickness, right column [H ~> m or kg m-2] + real, dimension(ne), intent(inout) :: coeff_l !< Tapering coefficient, left column [nondim] + real, dimension(ne), intent(inout) :: coeff_r !< Tapering coefficient, right column [nondim] + + ! Local variables + real :: min_bld, max_bld ! Min/Max boundary layer depth in two adjacent columns + integer :: dummy1 ! dummy integer + real :: dummy2 ! dummy real + integer :: k_min_l, k_min_r, k_max_l, k_max_r ! Min/max vertical indices in two adjacent columns + real :: zeta_l, zeta_r ! dummy variables + integer :: k ! vertical index + + ! initialize coeffs + coeff_l(:) = 1.0 + coeff_r(:) = 1.0 + + ! Calculate vertical indices containing the boundary layer depths + max_bld = MAX(bld_l, bld_r) + min_bld = MIN(bld_l, bld_r) + + ! k_min + call boundary_k_range(SURFACE, ne-1, h_l, min_bld, dummy1, dummy2, k_min_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, min_bld, dummy1, dummy2, k_min_r, & + zeta_r) + + ! k_max + call boundary_k_range(SURFACE, ne-1, h_l, max_bld, dummy1, dummy2, k_max_l, & + zeta_l) + call boundary_k_range(SURFACE, ne-1, h_r, max_bld, dummy1, dummy2, k_max_r, & + zeta_r) + ! left + do k=1,k_min_l + coeff_l(k) = 0.0 + enddo + do k=k_min_l+1,k_max_l+1 + coeff_l(k) = (real(k - k_min_l) + 1.0)/(real(k_max_l - k_min_l) + 2.0) + enddo + + ! right + do k=1,k_min_r + coeff_r(k) = 0.0 + enddo + do k=k_min_r+1,k_max_r+1 + coeff_r(k) = (real(k - k_min_r) + 1.0)/(real(k_max_r - k_min_r) + 2.0) + enddo + +end subroutine compute_tapering_coeffs + !> Returns interface scalar, Si, for a column of layer values, S. subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels @@ -1921,7 +2033,8 @@ end function absolute_positions !> Returns a single column of neutral diffusion fluxes of a tracer. subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, KoR, & - hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge) + hEff, Flx, continuous, h_neglect, remap_CS, h_neglect_edge, & + coeff_l, coeff_r) integer, intent(in) :: nk !< Number of levels integer, intent(in) :: nsurf !< Number of neutral surfaces integer, intent(in) :: deg !< Degree of polynomial reconstructions @@ -1945,11 +2058,14 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! to create sublayers real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for !! edge value calculations if continuous is false [H ~> m or kg m-2] + real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 T-1 ~> m2 s-1] + real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 T-1 ~> m2 s-1] + ! Local variables integer :: k_sublayer, klb, klt, krb, krt real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int real :: T_left_top, T_left_bottom, T_left_layer, T_left_sub, T_left_top_int, T_left_bot_int - real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int + real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int, khtr_ave real, dimension(nk+1) :: Til !< Left-column interface tracer (conc, e.g. degC) real, dimension(nk+1) :: Tir !< Right-column interface tracer (conc, e.g. degC) real, dimension(nk) :: aL_l !< Left-column left edge value of tracer (conc, e.g. degC) @@ -1964,7 +2080,12 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K real, dimension(nk,deg+1) :: ppoly_r_coeffs_r real, dimension(nk,deg+1) :: ppoly_r_S_l real, dimension(nk,deg+1) :: ppoly_r_S_r - logical :: down_flux + logical :: down_flux, tapering + + tapering = .false. + if (present(coeff_l) .and. present(coeff_r)) tapering = .true. + khtr_ave = 1.0 + ! Setup reconstruction edge values if (continuous) then call interface_scalar(nk, hl, Tl, Til, 2, h_neglect) @@ -1987,6 +2108,14 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K if (hEff(k_sublayer) == 0.) then Flx(k_sublayer) = 0. else + if (tapering) then + klb = KoL(k_sublayer+1) + klt = KoL(k_sublayer) + krb = KoR(k_sublayer+1) + krt = KoR(k_sublayer) + ! these are added in this order to preserve vertically-uniform diffusivity answers + khtr_ave = 0.25 * ((coeff_l(klb) + coeff_l(klt)) + (coeff_r(krb) + coeff_r(krt))) + endif if (continuous) then klb = KoL(k_sublayer+1) T_left_bottom = ( 1. - PiL(k_sublayer+1) ) * Til(klb) + PiL(k_sublayer+1) * Til(klb+1) @@ -2010,7 +2139,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K else dT_ave = dT_layer endif - Flx(k_sublayer) = dT_ave * hEff(k_sublayer) + Flx(k_sublayer) = dT_ave * hEff(k_sublayer) * khtr_ave else ! Discontinuous reconstruction ! Calculate tracer values on left and right side of the neutral surface call neutral_surface_T_eval(nk, nsurf, k_sublayer, KoL, PiL, Tl, Tid_l, deg, iMethod, & @@ -2036,7 +2165,7 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K dT_sublayer >= 0. .and. dT_top_int >= 0. .and. & dT_bot_int >= 0.) if (down_flux) then - Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) + Flx(k_sublayer) = dT_sublayer * hEff(k_sublayer) * khtr_ave else Flx(k_sublayer) = 0. endif From 620d9337a99a7cb21a2699ebbc60f23efb19a19b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 5 Jul 2023 14:09:46 -0400 Subject: [PATCH 311/629] Autoconf: Find Python, even if PYTHON is empty The autoconf Python interpreter search was slightly modified to search for Python even if $PYTHON is set to an empty string. This is done by unsetting PYTHON if it is set but empty, then following the usual macro. This was required since `export PYTHON` in a Makefile will create the `PYTHON` variable but will assign it no value (i.e. empty string). This causes issues in some build environments. The backup `configure~` script was also added to the developer `ac-clean` cleanup rule. --- ac/Makefile.in | 1 + ac/configure.ac | 5 +++++ 2 files changed, 6 insertions(+) diff --git a/ac/Makefile.in b/ac/Makefile.in index 43262027e6..64a60e70d1 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -56,3 +56,4 @@ ac-clean: distclean rm -f @srcdir@/ac/aclocal.m4 rm -rf @srcdir@/ac/autom4te.cache rm -f @srcdir@/ac/configure + rm -f @srcdir@/ac/configure~ diff --git a/ac/configure.ac b/ac/configure.ac index 7ea1870816..9d87240506 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -238,8 +238,13 @@ AC_COMPILE_IFELSE( # Python interpreter test +# Declare the Python interpreter variable AC_ARG_VAR([PYTHON], [Python interpreter command]) +# If PYTHON is set to an empty string, then unset it +AS_VAR_IF([PYTHON], [], [AS_UNSET([PYTHON])], []) + +# Now attempt to find a Python interpreter if PYTHON is unset AS_VAR_SET_IF([PYTHON], [ AC_PATH_PROGS([PYTHON], ["$PYTHON"], [none]) ], [ From 77b588199839fd9b626c3d2e52f7afcde2f109e9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 18 Jun 2023 16:26:55 -0400 Subject: [PATCH 312/629] +Refactor nominal depth in ALE code Refactored 6 files in the ALE directory to calculate the nominal depth in thickness units in a single place (it is done in regridding_main now) and pass it to the various places where it is used, in a preparatory step to modify how this calculation is done in non-Boussinesq mode. There are new arguments to several publicly visible routines, including: - Add non_depth_H arguments to hybgen_regrid, build_zstar_grid, build_sigma_grid, build_rho_grid, build_grid_HyCOM1, build_grid_adaptive, build_adapt_column and build_grid_arbitrary - Add optional zScale arguments to build_zstar_grid and build_grid_HyCOM1 - Add unit_scale_type arguments to regridding_main, ALE_regrid_accelerated and ALE_offline_inputs Also eliminated an incorrect rescaling GV%Z_to_H facto when calculating the total column thickness from the layer thicknesses when an ice shelf is used with a Hycom grid. This would have caused dimensional consistency testing to fail. Added the new runtime parameters HYBGEN_H_THIN, HYBGEN_FAR_FROM_SURFACE HYBGEN_FAR_FROM_BOTTOM, and HYBGEN_DENSITY_EPSILON to set previously hard-coded dimensional parameters used in the Hybgen regridding code and store these values in new variables in hybgen_regrid_CS. Two of these are no longer passed to hybgen_column_regrid as separate parameters. By default these new runtime parameters recover the previous hard-coded values. Also eliminated an unused block of code in build_rho_column. Several comments documenting variables or their units were also added. All answers are bitwise identical, but there are 4 new runtime parameters that would appear in some MOM_parameter_doc files and there are changes to the arguments to 11 routines. --- src/ALE/MOM_ALE.F90 | 12 +- src/ALE/MOM_hybgen_regrid.F90 | 102 +++++--- src/ALE/MOM_regridding.F90 | 231 ++++++++++++------ src/ALE/coord_adapt.F90 | 14 +- src/ALE/coord_hycom.F90 | 4 +- src/ALE/coord_rho.F90 | 16 +- .../MOM_state_initialization.F90 | 4 +- src/tracer/MOM_offline_main.F90 | 2 +- 8 files changed, 241 insertions(+), 144 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index a341fd1835..61ab6c93cf 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -483,7 +483,7 @@ subroutine ALE_regrid( G, GV, US, h, h_new, dzRegrid, tv, CS, frac_shelf_h, PCM_ ! Build the new grid and store it in h_new. The old grid is retained as h. ! Both are needed for the subsequent remapping of variables. dzRegrid(:,:,:) = 0.0 - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid, & + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid, & frac_shelf_h=frac_shelf_h, PCM_cell=PCM_cell) if (CS%id_dzRegrid>0) then ; if (query_averaging_enabled(CS%diag)) then @@ -497,10 +497,11 @@ end subroutine ALE_regrid !> Regrid/remap stored fields used for offline tracer integrations. These input fields are assumed to have !! the same layer thicknesses at the end of the last offline interval (which should be a Zstar grid). This !! routine builds a grid on the runtime specified vertical coordinate -subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) +subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in ) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure @@ -526,7 +527,7 @@ subroutine ALE_offline_inputs(CS, G, GV, h, tv, Reg, uhtr, vhtr, Kd, debug, OBC) ! Build new grid from the Zstar state onto the requested vertical coordinate. The new grid is stored ! in h_new. The old grid is h. Both are needed for the subsequent remapping of variables. Convective ! adjustment right now is not used because it is unclear what to do with vanished layers - call regridding_main( CS%remapCS, CS%regridCS, G, GV, h, tv, h_new, dzRegrid) + call regridding_main( CS%remapCS, CS%regridCS, G, GV, US, h, tv, h_new, dzRegrid) if (CS%show_call_tree) call callTree_waypoint("new grid generated (ALE_offline_inputs)") ! Remap all variables from old grid h onto new grid h_new @@ -576,10 +577,11 @@ end subroutine ALE_offline_inputs !> For a state-based coordinate, accelerate the process of regridding by !! repeatedly applying the grid calculation algorithm -subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) +subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, dt, dzRegrid, initial) type(ALE_CS), pointer :: CS !< ALE control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Vertical grid + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Original thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermo vars (T/S/EOS) @@ -651,7 +653,7 @@ subroutine ALE_regrid_accelerated(CS, G, GV, h, tv, n_itt, u, v, OBC, Reg, dt, d ! generate new grid if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) - call regridding_main(CS%remapCS, CS%regridCS, G, GV, h_loc, tv_local, h, dzInterface) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index dc7c90a079..524f9b8ff2 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -61,7 +61,21 @@ module MOM_hybgen_regrid !> Nominal density of interfaces [R ~> kg m-3] real, allocatable, dimension(:) :: target_density - real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2] + real :: dp_far_from_sfc !< A distance that determines when an interface is suffiently far from + !! the surface that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to tenm (nominally 10 m). + real :: dp_far_from_bot !< A distance that determines when an interface is suffiently far from + !! the bottom that certain adjustments can be made in the Hybgen regridding + !! code [H ~> m or kg m-2]. In Hycom, this is set to onem (nominally 1 m). + real :: h_thin !< A layer thickness below which a layer is considered to be too thin for + !! certain adjustments to be made in the Hybgen regridding code. + !! In Hycom, this is set to onemm (nominally 0.001 m). + + real :: rho_eps !< A small nonzero density that is used to prevent division by zero + !! in several expressions in the Hybgen regridding code [R ~> kg m-3]. + + real :: onem !< Nominally one m in thickness units [H ~> m or kg m-2], used only in + !! certain debugging tests. end type hybgen_regrid_CS @@ -166,6 +180,28 @@ subroutine init_hybgen_regrid(CS, GV, US, param_file) "A bottom boundary layer thickness within which Hybgen is able to move "//& "overlying layers upward to match a target density.", & units="m", default=0.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_SURFACE", CS%dp_far_from_sfc, & + "A distance that determines when an interface is suffiently far "//& + "from the surface that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to tenm (nominally 10 m).", & + units="m", default=10.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_FAR_FROM_BOTTOM", CS%dp_far_from_bot, & + "A distance that determines when an interface is suffiently far "//& + "from the bottom that certain adjustments can be made in the Hybgen "//& + "regridding code. In Hycom, this is set to onem (nominally 1 m).", & + units="m", default=1.0, scale=GV%m_to_H) + call get_param(param_file, mdl, "HYBGEN_H_THIN", CS%h_thin, & + "A layer thickness below which a layer is considered to be too thin for "//& + "certain adjustments to be made in the Hybgen regridding code. "//& + "In Hycom, this is set to onemm (nominally 0.001 m).", & + units="m", default=0.001, scale=GV%m_to_H) + + call get_param(param_file, mdl, "HYBGEN_DENSITY_EPSILON", CS%rho_eps, & + "A small nonzero density that is used to prevent division by zero "//& + "in several expressions in the Hybgen regridding code.", & + units="kg m-3", default=1e-11, scale=US%kg_m3_to_R) + + call get_param(param_file, mdl, "HYBGEN_REMAP_DENSITY_MATCH", CS%hybiso, & "A tolerance between the layer densities and their target, within which "//& "Hybgen determines that remapping uses PCM for a layer.", & @@ -300,12 +336,17 @@ end subroutine get_hybgen_regrid_params !> Modify the input grid to give a new vertical grid based on the HYCOM hybgen code. -subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) +subroutine hybgen_regrid(G, GV, US, dp, nom_depth_H, tv, CS, dzInterface, PCM_cell) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: dp !< Source grid layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(hybgen_regrid_CS), intent(in) :: CS !< hybgen control structure real, dimension(SZI_(G),SZJ_(G),CS%nk+1), & @@ -457,7 +498,7 @@ subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) enddo ! The following block of code is used to trigger z* stretching of the targets heights. - nominalDepth = (G%bathyT(i,j) + G%Z_ref)*GV%Z_to_H + nominalDepth = nom_depth_H(i,j) if (h_tot <= CS%min_dilate*nominalDepth) then dilate = CS%min_dilate elseif (h_tot >= CS%max_dilate*nominalDepth) then @@ -482,8 +523,7 @@ subroutine hybgen_regrid(G, GV, US, dp, tv, CS, dzInterface, PCM_cell) enddo !k ! Determine the new layer thicknesses. - call hybgen_column_regrid(CS, nk, CS%thkbot, CS%onem, & - 1.0e-11*US%kg_m3_to_R, Rcv_tgt, fixlay, qhrlx, dp0ij, & + call hybgen_column_regrid(CS, nk, CS%thkbot, Rcv_tgt, fixlay, qhrlx, dp0ij, & dp0cum, Rcv, h_col, dz_int) ! Store the output from hybgenaij_regrid in 3-d arrays. @@ -669,13 +709,11 @@ real function cushn(delp, dp0) end function cushn !> Create a new grid for a column of water using the Hybgen algorithm. -subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & +subroutine hybgen_column_regrid(CS, nk, thkbot, Rcv_tgt, & fixlay, qhrlx, dp0ij, dp0cum, Rcv, h_in, dp_int) type(hybgen_regrid_CS), intent(in) :: CS !< hybgen regridding control structure integer, intent(in) :: nk !< number of layers real, intent(in) :: thkbot !< thickness of bottom boundary layer [H ~> m or kg m-2] - real, intent(in) :: onem !< one m in pressure units [H ~> m or kg m-2] - real, intent(in) :: epsil !< small nonzero density to prevent division by zero [R ~> kg m-3] real, intent(in) :: Rcv_tgt(nk) !< Target potential density [R ~> kg m-3] integer, intent(in) :: fixlay !< deepest fixed coordinate layer real, intent(in) :: qhrlx( nk+1) !< relaxation coefficient per timestep [nondim] @@ -702,20 +740,14 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & real :: h_hat0 ! A first guess at thickness movement upward across the interface ! between layers k and k-1 [H ~> m or kg m-2] real :: dh_cor ! Thickness changes [H ~> m or kg m-2] - real :: tenm ! ten m in pressure units [H ~> m or kg m-2] - real :: onemm ! one mm in pressure units [H ~> m or kg m-2] logical :: trap_errors integer :: k character(len=256) :: mesg ! A string for output messages ! This line needs to be consistent with the parameters set in cushn(). - real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn -! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn -! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn - - !### These hard-coded parameters should be changed to run-time variables. - tenm = 10.0*onem - onemm = 0.001*onem + real, parameter :: qqmn=-4.0, qqmx=2.0 ! shifted range for cushn [nondim] +! real, parameter :: qqmn=-2.0, qqmx=4.0 ! traditional range for cushn [nondim] +! real, parameter :: qqmn=-4.0, qqmx=6.0 ! somewhat wider range for cushn [nondim] trap_errors = .true. @@ -769,26 +801,26 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! Remap the non-fixed layers. - ! In the Hycom version, this loop was fused the loop correcting water that is + ! In the Hycom version, this loop was fused with the loop correcting water that is ! too light, and it ran down the water column, but if there are a set of layers ! that are very dense, that structure can lead to all of the water being remapped ! into a single thick layer. Splitting the loops and running the loop upwards - ! (as is done here avoids that catastrophic problem for layers that are far from + ! (as is done here) avoids that catastrophic problem for layers that are far from ! their targets. However, this code is still prone to a thin-thick-thin null mode. do k=nk,fixlay+2,-1 ! This is how the Hycom code would do this loop: do k=fixlay+1,nk ; if (k>fixlay+1) then - if ((Rcv(k) > Rcv_tgt(k) + epsil)) then + if ((Rcv(k) > Rcv_tgt(k) + CS%rho_eps)) then ! Water in layer k is too dense, so try to dilute with water from layer k-1 ! Do not move interface if k = fixlay + 1 if ((Rcv(k-1) >= Rcv_tgt(k-1)) .or. & - (p_int(k) <= dp0cum(k) + onem) .or. & + (p_int(k) <= dp0cum(k) + CS%dp_far_from_bot) .or. & (h_col(k) <= h_col(k-1))) then ! If layer k-1 is too light, there is a conflict in the direction the ! inteface between them should move, so thicken the thinner of the two. - if ((Rcv_tgt(k) - Rcv(k-1)) <= epsil) then + if ((Rcv_tgt(k) - Rcv(k-1)) <= CS%rho_eps) then ! layer k-1 is far too dense, take the entire layer ! If this code is working downward and this branch is repeated in a series ! of successive layers, it can accumulate into a very thick homogenous layers. @@ -814,7 +846,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! layer (thinner than its minimum thickness) in the interior ocean, ! move interface k-1 (and k-2 if necessary) upward ! Only work on layers that are sufficiently far from the fixed near-surface layers. - if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + tenm)) then + if ((h_hat >= 0.0) .and. (k > fixlay+2) .and. (p_int(k-1) > dp0cum(k-1) + CS%dp_far_from_sfc)) then ! Only act if interface k-1 is near the bottom or layer k-2 could donate water. if ( (p_int(nk+1) - p_int(k-1) < thkbot) .or. & @@ -828,7 +860,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) endif !fixlay+3:else - if (h_hat2 < -onemm) then + if (h_hat2 < -CS%h_thin) then dh_cor = qhrlx(k-1) * max(h_hat2, -h_hat - h_col(k-1)) h_col(k-2) = h_col(k-2) + dh_cor h_col(k-1) = h_col(k-1) - dh_cor @@ -838,9 +870,9 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & h_hat = cushn(h_hat0 + h_col(k-1), dp0ij(k-1)) - h_col(k-1) elseif (k <= fixlay+3) then ! Do nothing. - elseif (p_int(k-2) > dp0cum(k-2) + tenm .and. & - (p_int(nk+1) - p_int(k-2) < thkbot .or. & - h_col(k-3) > qqmx*dp0ij(k-3))) then + elseif ( (p_int(k-2) > dp0cum(k-2) + CS%dp_far_from_sfc) .and. & + ( (p_int(nk+1) - p_int(k-2) < thkbot) .or. & + (h_col(k-3) > qqmx*dp0ij(k-3)) ) ) then ! Determine how much water layer k-3 could supply without becoming too thin. if (k == fixlay+4) then @@ -850,7 +882,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! Maintain minimum thickess of layer k-3. h_hat3 = cushn(h_col(k-3) + (h_hat0 - h_hat), dp0ij(k-3)) - h_col(k-3) endif !fixlay+4:else - if (h_hat3 < -onemm) then + if (h_hat3 < -CS%h_thin) then ! Water is moved from layer k-3 to k-2, but do not dilute layer k-2 too much. dh_cor = qhrlx(k-2) * max(h_hat3, -h_col(k-2)) h_col(k-3) = h_col(k-3) + dh_cor @@ -860,7 +892,7 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & ! Now layer k-2 might be able donate to layer k-1. h_hat2 = cushn(h_col(k-2) + (h_hat0 - h_hat), dp0ij(k-2)) - h_col(k-2) - if (h_hat2 < -onemm) then + if (h_hat2 < -CS%h_thin) then dh_cor = qhrlx(k-1) * (max(h_hat2, -h_hat - h_col(k-1)) ) h_col(k-2) = h_col(k-2) + dh_cor h_col(k-1) = h_col(k-1) - dh_cor @@ -890,17 +922,17 @@ subroutine hybgen_column_regrid(CS, nk, thkbot, onem, epsil, Rcv_tgt, & enddo do k=fixlay+1,nk - if (Rcv(k) < Rcv_tgt(k) - epsil) then ! layer too light + if (Rcv(k) < Rcv_tgt(k) - CS%rho_eps) then ! layer too light ! Water in layer k is too light, so try to dilute with water from layer k+1. ! Entrainment is not possible if layer k touches the bottom. if (p_int(k+1) < p_int(nk+1)) then ! k 1.0e-13*max(p_int(nk+1), onem)) then + if (abs((h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4," err ",es13.4)') & k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), (h_col(k) - h_in(k)) + (dp_int(K) - dp_int(K+1)) call MOM_error(FATAL, "Mismatched thickness changes in hybgen_regrid: "//trim(mesg)) endif - if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), onem)) then + if (h_col(k) < 0.0) then ! Could instead do: -1.0e-15*max(p_int(nk+1), CS%onem)) then write(mesg, '("k ",i4," h ",es13.4," h_in ",es13.4, " dp ",2es13.4, " fixlay ",i4)') & k, h_col(k), h_in(k), dp_int(K), dp_int(K+1), fixlay call MOM_error(FATAL, "Significantly negative final thickness in hybgen_regrid: "//trim(mesg)) endif enddo do K=1,nk+1 - if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), onem)) then + if (abs(dp_int(K) - (p_int(K) - pres_in(K))) > 1.0e-13*max(p_int(nk+1), CS%onem)) then call MOM_error(FATAL, "Mismatched interface height changes in hybgen_regrid.") endif enddo diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 9da4e95b24..c5f5807f66 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -175,7 +175,7 @@ module MOM_regridding character(len=*), parameter, public :: regriddingDefaultInterpScheme = "P1M_H2" !> Default mode for boundary extrapolation logical, parameter, public :: regriddingDefaultBoundaryExtrapolation = .false. -!> Default minimum thickness for some coordinate generation modes +!> Default minimum thickness for some coordinate generation modes [m] real, parameter, public :: regriddingDefaultMinThickness = 1.e-3 !> Maximum length of parameters @@ -213,7 +213,8 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m 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 :: tmpReal ! A temporary variable used in setting other variables [various] + real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] @@ -771,7 +772,7 @@ end subroutine end_regridding !------------------------------------------------------------------------------ !> Dispatching regridding routine for orchestrating regridding & remapping -subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & +subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & frac_shelf_h, PCM_cell) !------------------------------------------------------------------------------ ! This routine takes care of (1) building a new grid and (2) remapping between @@ -795,45 +796,60 @@ subroutine regridding_main( remapCS, CS, G, GV, h, tv, h_new, dzInterface, & type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Current 3D grid obtained after - !! the last time step + !! the last time step [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamical variables (T, S, ...) - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target coordinate - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each interface - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New 3D grid consistent with target + !! coordinate [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in position of each + !! interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in ) :: frac_shelf_h !< Fractional ice shelf coverage [nomdim] logical, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out ) :: PCM_cell !< Use PCM remapping in cells where true ! Local variables + real :: nom_depth_H(SZI_(G),SZJ_(G)) !< The nominal ocean depth at each point in thickness units [H ~> m or kg m-2] + real :: Z_to_H ! A conversion factor used by some routines to convert coordinate + ! parameters to depth units [H Z-1 ~> nondim or kg m-3] real :: trickGnuCompiler integer :: i, j if (present(PCM_cell)) PCM_cell(:,:,:) = .false. + Z_to_H = US%Z_to_m * GV%m_to_H ! Often this is equivalent to GV%Z_to_H. + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * Z_to_H + ! Consider using the following instead: + ! nom_depth_H(i,j) = max( (G%bathyT(i,j)+G%Z_ref) * Z_to_H , CS%min_nom_depth ) + ! if (G%mask2dT(i,j)==0.) nom_depth_H(i,j) = 0.0 + enddo ; enddo + select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR ) - call build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale=Z_to_H ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA_SHELF_ZSTAR) - call build_zstar_grid( CS, G, GV, h, dzInterface ) + call build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, zScale=Z_to_H ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_SIGMA ) - call build_sigma_grid( CS, G, GV, h, dzInterface ) + call build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_RHO ) - call build_rho_grid( G, GV, G%US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) + call build_rho_grid( G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ARBITRARY ) - call build_grid_arbitrary( G, GV, h, dzInterface, trickGnuCompiler, CS ) + call build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, trickGnuCompiler, CS ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) - call build_grid_HyCOM1( G, GV, G%US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) + call build_grid_HyCOM1( G, GV, G%US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & + frac_shelf_h, zScale=Z_to_H ) case ( REGRIDDING_HYBGEN ) - call hybgen_regrid(G, GV, G%US, h, tv, CS%hybgen_CS, dzInterface, PCM_cell) + call hybgen_regrid(G, GV, G%US, h, nom_depth_H, tv, CS%hybgen_CS, dzInterface, PCM_cell) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_ADAPTIVE ) - call build_grid_adaptive(G, GV, G%US, h, tv, dzInterface, remapCS, CS) + call build_grid_adaptive(G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case default @@ -896,9 +912,12 @@ subroutine calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses (arbitrary units) - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions (same as h) - real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses (same as h) + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Old layer thicknesses [H ~> m or kg m-2] + !! or other units + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(in) :: dzInterface !< Change in interface positions + !! in the same units as h [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses in the same + !! units as h [H ~> m or kg m-2] ! Local variables integer :: i, j, k, nki @@ -1121,21 +1140,29 @@ end subroutine filtered_grid_motion !> Builds a z*-coordinate grid with partial steps (Adcroft and Campin, 2004). !! z* is defined as !! z* = (z-eta)/(H+eta)*H s.t. z*=0 when z=eta and z*=-H when z=-H . -subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) +subroutine build_zstar_grid( CS, G, GV, h, nom_depth_H, dzInterface, frac_shelf_h, zScale) ! Arguments type(regridding_CS), intent(in) :: CS !< Regridding control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), optional,intent(in) :: frac_shelf_h !< Fractional !! ice shelf coverage [nondim]. + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] ! Local variables real :: nominalDepth, minThickness, totalThickness ! Depths and thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh ! [H ~> m or kg m-2] + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] @@ -1146,13 +1173,13 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) minThickness = CS%min_thickness ice_shelf = present(frac_shelf_h) -!$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & -!$OMP ice_shelf,minThickness) & -!$OMP private(nominalDepth,totalThickness, & + !$OMP parallel do default(none) shared(G,GV,dzInterface,CS,nz,h,frac_shelf_h, & + !$OMP ice_shelf,minThickness,zScale,nom_depth_H) & + !$OMP private(nominalDepth,totalThickness, & #ifdef __DO_SAFETY_CHECKS__ -!$OMP dh, & + !$OMP dh, & #endif -!$OMP zNew,zOld) + !$OMP zNew,zOld) do j = G%jsc-1,G%jec+1 do i = G%isc-1,G%iec+1 @@ -1161,8 +1188,8 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) cycle endif - ! Local depth (G%bathyT is positive downward) - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + ! Local depth (positive downward) + nominalDepth = nom_depth_H(i,j) ! Determine water column thickness totalThickness = 0.0 @@ -1170,23 +1197,26 @@ subroutine build_zstar_grid( CS, G, GV, h, dzInterface, frac_shelf_h) totalThickness = totalThickness + h(i,j,k) enddo + ! if (GV%Boussinesq) then zOld(nz+1) = - nominalDepth do k = nz,1,-1 zOld(k) = zOld(k+1) + h(i,j,k) enddo + ! else ! Work downward? + ! endif if (ice_shelf) then if (frac_shelf_h(i,j) > 0.) then ! under ice shelf call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, zNew, & - z_rigid_top = totalThickness-nominalDepth, & - eta_orig=zOld(1), zScale=GV%Z_to_H) + z_rigid_top=totalThickness-nominalDepth, & + eta_orig=zOld(1), zScale=zScale) else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%Z_to_H) + zNew, zScale=zScale) endif else call build_zstar_column(CS%zlike_CS, nominalDepth, totalThickness, & - zNew, zScale=GV%Z_to_H) + zNew, zScale=zScale) endif ! Calculate the final change in grid position after blending new and old grids @@ -1225,7 +1255,7 @@ end subroutine build_zstar_grid !------------------------------------------------------------------------------ ! Build sigma grid !> This routine builds a grid based on terrain-following coordinates. -subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) +subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) !------------------------------------------------------------------------------ ! This routine builds a grid based on terrain-following coordinates. ! The module parameter coordinateResolution(:) determines the resolution in @@ -1238,18 +1268,22 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth !! [H ~> m or kg m-2] ! Local variables - integer :: i, j, k - integer :: nz - real :: nominalDepth, totalThickness + real :: nominalDepth ! The nominal depth of the sea-floor in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif real, dimension(SZK_(GV)+1) :: zOld ! Previous coordinate interface heights [H ~> m or kg m-2] real, dimension(CS%nk+1) :: zNew ! New coordinate interface heights [H ~> m or kg m-2] + integer :: i, j, k, nz nz = GV%ke @@ -1261,28 +1295,35 @@ subroutine build_sigma_grid( CS, G, GV, h, dzInterface ) cycle endif - ! The rest of the model defines grids integrating up from the bottom - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - ! Determine water column height totalThickness = 0.0 do k = 1,nz totalThickness = totalThickness + h(i,j,k) enddo + ! In sigma coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq mode. + ! if (GV%Boussinesq) then + nominalDepth = nom_depth_H(i,j) + ! else + ! nominalDepth = totalThickness + ! endif + call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) ! Calculate the final change in grid position after blending new and old grids zOld(nz+1) = -nominalDepth do k = nz,1,-1 - zOld(k) = zOld(k+1) + h(i, j, k) + zOld(k) = zOld(k+1) + h(i,j,k) enddo call filtered_grid_motion( CS, nz, zOld, zNew, dzInterface(i,j,:) ) #ifdef __DO_SAFETY_CHECKS__ - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(CS%nk-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth,totalThickness) + if (abs(zNew(1)-zOld(1)) > (CS%nk-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'dzInterface(1) = ',dzInterface(i,j,1),epsilon(dh),nz,CS%nk @@ -1314,11 +1355,11 @@ end subroutine build_sigma_grid ! Build grid based on target interface densities !------------------------------------------------------------------------------ !> This routine builds a new grid based on a given set of target interface densities. -subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shelf_h ) +subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) !------------------------------------------------------------------------------ ! This routine builds a new grid based on a given set of target interface ! densities (these target densities are computed by taking the mean value -! of given layer densities). The algorithn operates as follows within each +! of given layer densities). The algorithm operates as follows within each ! column: ! 1. Given T & S within each layer, the layer densities are computed. ! 2. Based on these layer densities, a global density profile is reconstructed @@ -1331,17 +1372,21 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel !------------------------------------------------------------------------------ ! Arguments - type(regridding_CS), intent(in) :: CS !< Regridding control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - 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 !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth - !! [H ~> m or kg m-2] - type(remapping_CS), intent(in) :: remapCS !< The remapping control structure - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice - !! shelf coverage [nondim] + type(regridding_CS), intent(in) :: CS !< Regridding control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure + real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface depth + !! [H ~> m or kg m-2] + type(remapping_CS), intent(in) :: remapCS !< The remapping control structure + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice + !! shelf coverage [nondim] ! Local variables integer :: nz ! The number of layers in the input grid integer :: i, j, k @@ -1351,7 +1396,7 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] real :: totalThickness ! Total thicknesses [H ~> m or kg m-2] #ifdef __DO_SAFETY_CHECKS__ - real :: dh + real :: dh ! The larger of the total column thickness or bathymetric depth [H ~> m or kg m-2] #endif logical :: ice_shelf @@ -1378,15 +1423,22 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel cycle endif - - ! Local depth (G%bathyT is positive downward) - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - ! Determine total water column thickness totalThickness = 0.0 do k=1,nz totalThickness = totalThickness + h(i,j,k) enddo + + ! In rho coordinates, the bathymetric depth is only used as an arbitrary offset that + ! cancels out when determining coordinate motion, so referencing the column postions to + ! the surface is perfectly acceptable, but for preservation of previous answers the + ! referencing is done relative to the bottom when in Boussinesq mode. + ! if (GV%Boussinesq) then + nominalDepth = nom_depth_H(i,j) + ! else + ! nominalDepth = totalThickness + ! endif + ! Determine absolute interface positions zOld(nz+1) = - nominalDepth do k = nz,1,-1 @@ -1394,13 +1446,13 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel enddo if (ice_shelf) then - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & - z_rigid_top = totalThickness - nominalDepth, eta_orig = zOld(1), & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & + z_rigid_top=totalThickness - nominalDepth, eta_orig = zOld(1), & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) else - call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i, j, :), & - tv%T(i, j, :), tv%S(i, j, :), tv%eqn_of_state, zNew, & + call build_rho_column(CS%rho_CS, nz, nominalDepth, h(i,j,:), & + tv%T(i,j,:), tv%S(i,j,:), tv%eqn_of_state, zNew, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) endif @@ -1441,8 +1493,8 @@ subroutine build_rho_grid( G, GV, US, h, tv, dzInterface, remapCS, CS, frac_shel totalThickness = totalThickness + h(i,j,k) enddo - dh=max(nominalDepth,totalThickness) - if (abs(zNew(1)-zOld(1))>(nz-1)*0.5*epsilon(dh)*dh) then + dh = max(nominalDepth, totalThickness) + if (abs(zNew(1)-zOld(1)) > (nz-1)*0.5*epsilon(dh)*dh) then write(0,*) 'min_thickness=',CS%min_thickness write(0,*) 'nominalDepth=',nominalDepth,'totalThickness=',totalThickness write(0,*) 'zNew(1)-zOld(1) = ',zNew(1)-zOld(1),epsilon(dh),nz @@ -1475,11 +1527,15 @@ end subroutine build_rho_grid !! \remark { Based on Bleck, 2002: An ocean-ice general circulation model framed in !! hybrid isopycnic-Cartesian coordinates, Ocean Modelling 37, 55-88. !! http://dx.doi.org/10.1016/S1463-5003(01)00012-9 } -subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h ) +subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, frac_shelf_h, zScale ) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Existing model thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure type(remapping_CS), intent(in) :: remapCS !< The remapping control structure type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1487,6 +1543,10 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf !! coverage [nondim] + real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate + !! resolution in Z to desired units for zInterface, + !! usually Z_to_H in which case it is in + !! units of [H Z-1 ~> nondim or kg m-3] ! Local variables real, dimension(SZK_(GV)+1) :: z_col ! Source interface positions relative to the surface [H ~> m or kg m-2] @@ -1517,12 +1577,12 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then - nominalDepth = (G%bathyT(i,j)+G%Z_ref) * GV%Z_to_H + nominalDepth = nom_depth_H(i,j) if (ice_shelf) then totalThickness = 0.0 do k=1,GV%ke - totalThickness = totalThickness + h(i,j,k) * GV%Z_to_H + totalThickness = totalThickness + h(i,j,k) enddo z_top_col = max(nominalDepth-totalThickness,0.0) else @@ -1538,7 +1598,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, tv, h_new, dzInterface, remapCS, CS, call build_hycom1_column(CS%hycom_CS, remapCS, tv%eqn_of_state, GV%ke, nominalDepth, & h(i,j,:), tv%T(i,j,:), tv%S(i,j,:), p_col, & - z_col, z_col_new, zScale=GV%Z_to_H, & + z_col, z_col_new, zScale=zScale, & h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) ! Calculate the final change in grid position after blending new and old grids @@ -1562,11 +1622,15 @@ end subroutine build_grid_HyCOM1 !> This subroutine builds an adaptive grid that follows density surfaces where !! possible, subject to constraints on the smoothness of interface heights. -subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) +subroutine build_grid_adaptive(G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables type(regridding_CS), intent(in) :: CS !< Regridding control structure @@ -1576,8 +1640,8 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) ! local variables integer :: i, j, k, nz ! indices and dimension lengths - ! temperature [C ~> degC], salinity [S ~> ppt] and pressure on interfaces - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt, sInt + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: tInt ! Temperature on interfaces [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: sInt ! Salinity on interfaces [S ~> ppt] ! current interface positions and after tendency term is applied ! positive downward real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: zInt ! Interface depths [H ~> m or kg m-2] @@ -1614,7 +1678,7 @@ subroutine build_grid_adaptive(G, GV, US, h, tv, dzInterface, remapCS, CS) cycle endif - call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) + call build_adapt_column(CS%adapt_CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) call filtered_grid_motion(CS, nz, zInt(i,j,:), zNext, dzInterface(i,j,:)) ! convert from depth to z @@ -1685,7 +1749,7 @@ end subroutine adjust_interface_motion !------------------------------------------------------------------------------ ! Build arbitrary grid !------------------------------------------------------------------------------ -subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) +subroutine build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, h_new, CS ) !------------------------------------------------------------------------------ ! This routine builds a grid based on arbitrary rules !------------------------------------------------------------------------------ @@ -1694,6 +1758,10 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Original layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface !! depth [H ~> m or kg m-2] @@ -1718,7 +1786,7 @@ subroutine build_grid_arbitrary( G, GV, h, dzInterface, h_new, CS ) do i = G%isc-1,G%iec+1 ! Local depth - local_depth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + local_depth = nom_depth_H(i,j) ! Determine water column height total_height = 0.0 @@ -2373,7 +2441,7 @@ function getStaticThickness( CS, SSH, depth ) real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of depth ! Local integer :: k - real :: z, dz + real :: z, dz ! Vertical positions and grid spacing [Z ~> m] select case ( CS%regridding_scheme ) case ( REGRIDDING_ZSTAR, REGRIDDING_SIGMA_SHELF_ZSTAR, REGRIDDING_HYCOM1, REGRIDDING_HYBGEN, & @@ -2407,10 +2475,13 @@ end function getStaticThickness subroutine dz_function1( string, dz ) character(len=*), intent(in) :: string !< String with list of parameters in form !! dz_min, H_total, power, precision - real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses + real, dimension(:), intent(inout) :: dz !< Profile of nominal thicknesses [m] or other units ! Local variables integer :: nk, k - real :: dz_min, power, prec, H_total + real :: dz_min ! minimum grid spacing [m] or other units + real :: power ! A power to raise the relative position in index space [nondim] + real :: prec ! The precision with which positions are returned [m] or other units + real :: H_total ! The sum of the nominal thicknesses [m] or other units nk = size(dz) ! Number of cells prec = -1024. diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 91df78c021..ee612788c9 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -112,7 +112,7 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom if (present(adaptDoMin)) CS%adaptDoMin = adaptDoMin end subroutine set_adapt_params -subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNext) +subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_depth_H, zNext) type(adapt_CS), intent(in) :: CS !< The control structure for this module type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -125,6 +125,10 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: tInt !< Interface temperatures [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: sInt !< Interface salinities [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)), intent(in) :: nom_depth_H !< The bathymetric depth of this column + !! relative to mean sea level or another locally + !! valid reference height, converted to thickness + !! units [H ~> m or kg m-2] real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions ! Local variables @@ -144,7 +148,7 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex zNext(nz+1) = zInt(i,j,nz+1) ! local depth for scaling diffusivity - depth = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H + depth = nom_depth_H(i,j) ! initialize del2sigma and the thickness change response to it zero del2sigma(:) = 0.0 ; dh_d2s(:) = 0.0 @@ -244,9 +248,9 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, zNex ! set vertical grid diffusivity kGrid(k) = (CS%adaptTimeRatio * nz**2 * depth) * & - (CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & - (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & - max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) + ( CS%adaptZoomCoeff / (CS%adaptZoom + 0.5*(zNext(K) + zNext(K+1))) + & + (CS%adaptBuoyCoeff * drdz / CS%adaptDrho0) + & + max(1.0 - CS%adaptZoomCoeff - CS%adaptBuoyCoeff, 0.0) / depth) enddo ! initial denominator (first diagonal element) diff --git a/src/ALE/coord_hycom.F90 b/src/ALE/coord_hycom.F90 index aa2715eb42..ddc569e45e 100644 --- a/src/ALE/coord_hycom.F90 +++ b/src/ALE/coord_hycom.F90 @@ -117,7 +117,8 @@ subroutine build_hycom1_column(CS, remapCS, eqn_of_state, nz, depth, h, T, S, p_ real, dimension(nz+1), intent(in) :: z_col !< Interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1), intent(inout) :: z_col_new !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: zScale !< Scaling factor from the input coordinate thicknesses in [Z ~> m] - !! to desired units for zInterface, perhaps GV%Z_to_H. + !! to desired units for zInterface, perhaps GV%Z_to_H in which + !! case this has units of [H Z-1 ~> nondim or kg m-3] real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose of !! cell reconstruction [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose of @@ -220,7 +221,6 @@ subroutine build_hycom1_target_anomaly(CS, remapCS, eqn_of_state, nz, depth, h, real, dimension(nz), intent(in) :: S !< Salinity of column [S ~> ppt] real, dimension(nz), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] real, dimension(nz), intent(in) :: p_col !< Layer pressure [R L2 T-2 ~> Pa] - !! to desired units for zInterface, perhaps GV%Z_to_H. real, dimension(nz), intent(out) :: R !< Layer density [R ~> kg m-3] real, dimension(nz+1), intent(out) :: RiAnom !< The interface density anomaly !! w.r.t. the interface target diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 8454c4be1d..7b6c0e0f8c 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -102,9 +102,9 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(CS%nk+1), & intent(inout) :: z_interface !< Absolute positions of interfaces real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same - !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same - !! units as depth) [Z ~> m] or [H ~> m or kg m-2] + !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect !< A negligibly small width for the purpose !! of cell reconstructions [H ~> m or kg m-2] real, optional, intent(in) :: h_neglect_edge !< A negligibly small width for the purpose @@ -119,22 +119,10 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(nz+1) :: xTmp ! Temporary positions [H ~> m or kg m-2] real, dimension(CS%nk) :: h_new ! New thicknesses [H ~> m or kg m-2] real, dimension(CS%nk+1) :: x1 ! Interface heights [H ~> m or kg m-2] - real :: z0_top, eta ! Thicknesses or heights [Z ~> m] or [H ~> m or kg m-2] ! Construct source column with vanished layers removed (stored in h_nv) call copy_finite_thicknesses(nz, h, CS%min_thickness, count_nonzero_layers, h_nv, mapping) - z0_top = 0. - eta=0.0 - if (present(z_rigid_top)) then - z0_top = z_rigid_top - eta=z0_top - if (present(eta_orig)) then - eta=eta_orig - endif - endif - - if (count_nonzero_layers > 1) then xTmp(1) = 0.0 do k = 1,count_nonzero_layers diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0321d7511a..802fd33d0f 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -464,7 +464,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & if (new_sim .and. debug) & call hchksum(h, "Pre-ALE_regrid: h ", G%HI, haloshift=1, scale=GV%H_to_MKS) - call ALE_regrid_accelerated(ALE_CSp, G, GV, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & + call ALE_regrid_accelerated(ALE_CSp, G, GV, US, h, tv, regrid_iterations, u, v, OBC, tracer_Reg, & dt=dt, initial=.true.) endif endif @@ -2787,7 +2787,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just 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, & + call regridding_main( remapCS, regridCS, G, GV_loc, US, h1, tv_loc, h, dz_interface, & frac_shelf_h=frac_shelf_h ) deallocate( dz_interface ) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 40dced9b20..0577a12ac5 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -1069,7 +1069,7 @@ subroutine update_offline_fields(CS, G, GV, US, h, fluxes, do_ale) call pass_var(h, G%Domain) call pass_var(CS%tv%T, G%Domain) call pass_var(CS%tv%S, G%Domain) - call ALE_offline_inputs(CS%ALE_CSp, G, GV, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & + call ALE_offline_inputs(CS%ALE_CSp, G, GV, US, h, CS%tv, CS%tracer_Reg, CS%uhtr, CS%vhtr, CS%Kd, & CS%debug, CS%OBC) if (CS%id_temp_regrid>0) call post_data(CS%id_temp_regrid, CS%tv%T, CS%diag) if (CS%id_salt_regrid>0) call post_data(CS%id_salt_regrid, CS%tv%S, CS%diag) From 859ac15483f609249e839d206eb33da14df7d1ad Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 10 Jul 2023 18:26:30 -0400 Subject: [PATCH 313/629] *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 7970347eb3f36f80583ddaf74358bab9a0cb32ae Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 1 Jun 2023 10:58:40 -0400 Subject: [PATCH 314/629] Add restart subroutine to MOM.F90 As described in issue #372, I would like to be able to create restart files that contain information about the particle location. These files will be written at the same time as other restart files. I cannot add these calls directly to the driver, because the driver does not have information about the particle location. We have added save_MOM6_internal_state as a subroutine in MOM.F90, and we added calls to this subroutine from each of the drivers. We hope this will allow for more new packages to write restart files in the future. Co-authored by Spencer Jones --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 6 +++- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 5 +++- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 8 ++++- config_src/drivers/solo_driver/MOM_driver.F90 | 6 +++- src/core/MOM.F90 | 30 +++++++++++++++---- 5 files changed, 46 insertions(+), 9 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 005e3a6723..bd86a633c6 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -14,7 +14,7 @@ module ocean_model_mod use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline +use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type @@ -700,6 +700,7 @@ subroutine ocean_model_restart(OS, timestamp) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -709,6 +710,7 @@ subroutine ocean_model_restart(OS, timestamp) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif end subroutine ocean_model_restart @@ -764,6 +766,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) + end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index 1a15760d00..cdf93b1bef 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -14,7 +14,7 @@ module MOM_ocean_model_mct use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline +use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -697,6 +697,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -706,6 +707,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -715,6 +717,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 1283b98ba0..205dbdadcc 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -14,7 +14,7 @@ module MOM_ocean_model_nuopc use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline +use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -738,6 +738,8 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif + + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -747,6 +749,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & @@ -756,6 +759,7 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif if (present(stoch_restartname)) then @@ -818,6 +822,8 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif + call save_MOM6_internal_start(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) + end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 974843c10f..72981122f2 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -31,7 +31,7 @@ program MOM6 use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized - use MOM, only : step_offline + use MOM, only : step_offline, save_MOM6_internal_state use MOM_coms, only : Set_PElist use MOM_domains, only : MOM_infra_init, MOM_infra_end, set_MOM_thread_affinity use MOM_ensemble_manager, only : ensemble_manager_init, get_ensemble_size @@ -570,6 +570,7 @@ program MOM6 dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) + call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time, .true.) endif if (BTEST(Restart_control,0)) then call save_restart(dirs%restart_output_dir, Time, grid, & @@ -578,6 +579,7 @@ program MOM6 dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) + call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) endif restart_time = restart_time + restint endif @@ -601,6 +603,8 @@ program MOM6 call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) + call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) + ! Write the ocean solo restart file. call write_ocean_solo_res(Time, Start_time, calendar_type, & trim(dirs%restart_output_dir)//'ocean_solo.res') diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7b9f2f9d3f..ba04bf27dd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -438,7 +438,7 @@ module MOM end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end -public step_MOM, step_offline +public step_MOM, step_offline, save_MOM6_internal_state public extract_surface_state, get_ocean_stocks public get_MOM_state_elements, MOM_state_is_synchronized public allocate_surface_state, deallocate_surface_state @@ -3904,14 +3904,34 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) end subroutine get_ocean_stocks + +!> Trigger a writing of restarts for the MOM6 internal state +!! +!! Currently this applies to the state that does not take the form +!! of simple arrays for which the generic save_restart() function +!! can be used. +!! +!! Todo: +!! [ ] update particles to use Time and directories +!! [ ] move the call to generic save_restart() in here. +subroutine save_MOM6_internal_state(CS, dirs, time, stamp_time) + type(MOM_control_struct), intent(inout) :: CS !< MOM control structure + character(len=*), intent(in) :: dirs !< The directory where the restart + !! files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: stamp_time !< If present and true, add time-stamp + + ! Could call save_restart(CS%restart_CSp) here + + if (CS%use_particles) call particles_save_restart(CS%particles) + +end subroutine save_MOM6_internal_state + + !> End of ocean model, including memory deallocation subroutine MOM_end(CS) type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - if (CS%use_particles) then - call particles_save_restart(CS%particles) - endif - call MOM_sum_output_end(CS%sum_output_CSp) if (CS%use_ALE_algorithm) call ALE_end(CS%ALE_CSp) From 37ee5cc8a9dbdf2f746b7e7d36de8b6518cb84a9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 26 Jun 2023 17:24:41 -0400 Subject: [PATCH 315/629] +Add tv%valid_SpV_halo to debug non-Boussinesq mode Added the integer valid_SpV_halo to the thermo_var_ptrs type to indicate whether the SpV_array has been updated and its valid halo size, to facilitate error detection and debugging in non-Boussinesq mode. Tv%valid_SpV_halo is set to the halo size in calc_derived_thermo or after a halo update is done to tv%SpV_avg, and it is set to a negative value right after calls that change temperatures and salinities (such as by ALE remapping) unless there is a call to calc_derived_thermo. Tests for the validity of tv%SpV_avg are added to the routines behind thickness_to_dz, with fatal errors issued if invalid arrays would be used, but more tests could perhaps be used in any parameterization routines where tv%SpV_avg is used directly. Handling the updates to tv%SpV_avg this way helps to avoid unnecessary calls to calc_derived_thermo, which in turn has equation of state calls that can be expensive, while also providing essential verification of new code related to the non-Boussinesq code. These tests can probably be commented out or removed for efficiency once there is a full suite of regression tests for the fully non-Boussinesq mode of MOM6. In addition, a new optional debug argument was added to calc_derived_thermo which can be used to triggers checksums for the variables used to calculate tv%SpV_avg. One call to calc_derived_thermo was also added just before the initialization call to ALE_regrid that will be needed with the next commit, but does not change answers yet. All answers are bitwise identical, but there is a new element in a transparent and widely used type and a new optional argument to a public interface. --- src/ALE/MOM_ALE.F90 | 6 ++++ src/core/MOM.F90 | 24 ++++++++++---- src/core/MOM_interface_heights.F90 | 51 +++++++++++++++++++++++++----- src/core/MOM_variables.F90 | 2 ++ src/tracer/MOM_offline_main.F90 | 1 + 5 files changed, 70 insertions(+), 14 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 61ab6c93cf..4641747115 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -532,6 +532,7 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, ! Remap all variables from old grid h onto new grid h_new call ALE_remap_tracers(CS, G, GV, h, h_new, Reg, debug=CS%show_call_tree) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%show_call_tree) call callTree_waypoint("state remapped (ALE_inputs)") ! Reintegrate mass transports from Zstar to the offline vertical coordinate @@ -571,6 +572,8 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + if (CS%show_call_tree) call callTree_leave("ALE_offline_inputs()") end subroutine ALE_offline_inputs @@ -674,6 +677,9 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) + + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. + end subroutine ALE_regrid_accelerated !> This routine takes care of remapping all tracer variables between the old and the diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ba04bf27dd..703514fc52 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -671,8 +671,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt ; ntstep = 1 if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() - if (associated(fluxes%p_surf)) then - if (CS%use_p_surf_in_EOS) CS%tv%p_surf => fluxes%p_surf + if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then + CS%tv%p_surf => fluxes%p_surf + if (allocated(CS%tv%SpV_avg)) call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) endif if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif @@ -1110,6 +1111,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) call cpu_clock_begin(id_clock_int_filter) call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%CDp, CS%interface_filter_CSp) @@ -1245,6 +1248,8 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif if (CS%interface_filter) then + if (allocated(CS%tv%SpV_avg)) call pass_var(CS%tv%SpV_avg, G%Domain, clock=id_clock_pass) + CS%tv%valid_SpV_halo = min(G%Domain%nihalo, G%Domain%njhalo) call cpu_clock_begin(id_clock_int_filter) call interface_filter(h, CS%uhtr, CS%vhtr, CS%tv, dt_thermo, G, GV, US, & CS%CDp, CS%interface_filter_CSp) @@ -1392,6 +1397,8 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) if (associated(CS%tv%T)) then call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + ! The bottom boundary layer calculation may need halo values of SpV_avg, including the corners. + if (allocated(CS%tv%SpV_avg)) halo_sz = max(halo_sz, 1) if (halo_sz > 0) then call create_group_pass(pass_T_S, CS%tv%T, G%Domain, To_All, halo=halo_sz) call create_group_pass(pass_T_S, CS%tv%S, G%Domain, To_All, halo=halo_sz) @@ -1407,7 +1414,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) ! Update derived thermodynamic quantities. if (allocated(CS%tv%SpV_avg)) then - call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) endif endif @@ -1559,6 +1566,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) call ALE_remap_velocities(CS%ALE_CSp, G, GV, h, h_new, u, v, CS%OBC, dzRegrid, showCallTree, dtdia) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%remap_aux_vars) then if (CS%split) & @@ -1591,7 +1599,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Update derived thermodynamic quantities. if (allocated(tv%SpV_avg)) then - call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil) + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif if (CS%debug .and. CS%use_ALE_algorithm) then @@ -1647,7 +1655,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & ! Update derived thermodynamic quantities. if (allocated(tv%SpV_avg)) then - call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil) + call calc_derived_thermo(tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif endif @@ -1820,6 +1828,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! are used are intended to ensure that in the case where transports don't quite conserve, ! the offline layer thicknesses do not drift too far away from the online model. call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, debug=CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. ! Update the tracer grid. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 @@ -2847,6 +2856,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! 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) + CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. endif if (use_ice_shelf .and. CS%debug) then @@ -2895,6 +2905,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & endif call callTree_waypoint("Calling adjustGridForIntegrity() to remap initial conditions (initialize_MOM)") call adjustGridForIntegrity(CS%ALE_CSp, G, GV, CS%h ) + if (allocated(CS%tv%SpV_avg)) call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=1) call pre_ALE_adjustments(G, GV, US, CS%h, CS%tv, CS%tracer_Reg, CS%ALE_CSp, CS%u, CS%v) call callTree_waypoint("Calling ALE_regrid() to remap initial conditions (initialize_MOM)") @@ -2911,6 +2922,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, CS%debug, PCM_cell=PCM_cell) call ALE_remap_velocities(CS%ALE_CSp, G, GV, CS%h, h_new, CS%u, CS%v, CS%OBC, dzRegrid, debug=CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. ! Replace the old grid with new one. All remapping must be done at this point. !$OMP parallel do default(shared) @@ -3137,7 +3149,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! 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) + call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif if (associated(CS%visc%Kv_shear)) & diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index befeb1c2ad..dfd1048b82 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -4,13 +4,14 @@ 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, avg_specific_vol +use MOM_debugging, only : hchksum 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_EOS, only : calculate_density, average_specific_vol, 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 implicit none ; private @@ -262,7 +263,7 @@ end subroutine find_eta_2d !> Calculate derived thermodynamic quantities for re-use later. -subroutine calc_derived_thermo(tv, h, G, GV, US, halo) +subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) 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 @@ -271,13 +272,16 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo) !! 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 + integer, optional, intent(in) :: halo !< Width of halo within which to !! calculate thicknesses + logical, optional, intent(in) :: debug !< If present and true, write debugging checksums ! 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] + logical :: do_debug ! If true, write checksums for debugging. integer :: i, j, k, is, ie, js, je, halos, nz + do_debug = .false. ; if (present(debug)) do_debug = debug 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 @@ -296,6 +300,15 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo) p_t(i,j) = p_t(i,j) + dp(i,j) enddo ; enddo ; endif enddo + tv%valid_SpV_halo = halos + + if (do_debug) then + call hchksum(h, "derived_thermo h", G%HI, haloshift=halos, scale=GV%H_to_MKS) + if (associated(tv%p_surf)) call hchksum(tv%p_surf, "derived_thermo p_surf", G%HI, & + haloshift=halos, scale=US%RL2_T2_to_Pa) + call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, scale=US%C_to_degC) + call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, scale=US%S_to_ppt) + endif endif end subroutine calc_derived_thermo @@ -493,12 +506,23 @@ subroutine thickness_to_dz_3d(h, tv, dz, G, GV, US, halo_size) integer, optional, intent(in) :: halo_size !< Width of halo within which to !! calculate thicknesses ! Local variables + character(len=128) :: mesg ! A string for error messages 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 + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + 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 @@ -529,12 +553,23 @@ subroutine thickness_to_dz_jslice(h, tv, dz, j, G, GV, halo_size) integer, optional, intent(in) :: halo_size !< Width of halo within which to !! calculate thicknesses ! Local variables + character(len=128) :: mesg ! A string for error messages 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 + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "thickness_to_dz called in fully non-Boussinesq mode with "//trim(mesg)) + endif + 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 diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index bec93376af..0c4a42e8c6 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -95,6 +95,8 @@ module MOM_variables 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]. + integer :: valid_SpV_halo = -1 !< If positive, the valid halo size for SpV_avg, or if negative + !! SpV_avg is not currently set. ! These arrays are accumulated fluxes for communication with other components. real, dimension(:,:), pointer :: frazil => NULL() diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 0577a12ac5..dcce81ef73 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -364,6 +364,7 @@ subroutine offline_advection_ale(fluxes, Time_start, time_interval, G, GV, US, C ! Remap all variables from the old grid h_new onto the new grid h_post_remap call ALE_remap_tracers(CS%ALE_CSp, G, GV, h_new, h_post_remap, CS%tracer_Reg, & CS%debug, dt=CS%dt_offline) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 h_new(i,j,k) = h_post_remap(i,j,k) From b1210a08dbb84b4917c836c08b6c3a003e754b77 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 27 Jun 2023 06:09:12 -0400 Subject: [PATCH 316/629] (*)+Use RHO_KV_CONVERT to set nonBous GV%H_to_m Use RHO_KV_CONVERT instead of RHO_0 to set the non-Boussinesq version of GV%m_to_H, so that there is a mechanism for testing the independence of the fully non-Boussinesq mode from the Boussinesq reference density. With this change, GV%Z_to_H is not guaranteed to be equal to (GV%Z_to_m*GV%m_to_H), with the latter expression preferred when setting parameters. By default the two parameters are the same, and they will probably only ever differ in testing the code. All Boussinesq solutions are bitwise identical, but there are differences in the description of RHO_KV_CONVERT that will appear in MOM_parameter_doc files. --- src/core/MOM_verticalGrid.F90 | 24 ++++++++++++++++-------- 1 file changed, 16 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index 5e9b5c476c..b0b9fa9fcd 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -138,8 +138,12 @@ subroutine verticalGridInit( param_file, GV, US ) 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.", & + "The density used to convert input vertical distances into thickesses in "//& + "non-BOUSSINESQ mode, and to convert kinematic viscosities into dynamic "//& + "viscosities and similarly for vertical diffusivities. GV%m_to_H is set "//& + "using this value, whereas GV%Z_to_H is set using RHO_0. The default is "//& + "RHO_0, but this can be set separately to demonstrate the independence of the "//& + "non-Boussinesq solutions of the value of RHO_0.", & 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, & @@ -186,18 +190,22 @@ subroutine verticalGridInit( param_file, GV, US ) GV%m_to_H = 1.0 / GV%H_to_m 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 + + GV%H_to_Z = GV%H_to_m * US%m_to_Z + GV%Z_to_H = US%Z_to_m * GV%m_to_H 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%m_to_H = US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H + GV%m_to_H = US%R_to_kg_m3*rho_Kv * 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_to_m = 1.0 / GV%m_to_H - 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%H_to_Z = US%m_to_Z * ( GV%H_to_kg_m2 / (US%R_to_kg_m3*GV%Rho0) ) + GV%Z_to_H = US%Z_to_m * ( US%R_to_kg_m3*GV%Rho0 * GV%kg_m2_to_H ) + endif - GV%Angstrom_H = GV%Z_to_H * GV%Angstrom_Z + GV%Angstrom_H = (US%Z_to_m * GV%m_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) From 2342a5825b1d82f0d536c78796812411c7d591c9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 12 Jul 2023 16:35:50 -0400 Subject: [PATCH 317/629] +Add new (not yet used) arguments to 7 routines Add new arguments to 7 routines that will be needed for the non-Boussinesq capability, but do not use them yet, so that there will be fewer cross file dependencies as the various changes are being reviewed simultaneously. The impacted interfaces are MEKE_int, vertvisc_coef, sumSWoverBands, KPP_calculate, differential_diffuse_T_S, set_BBL_TKE, and apply_sponge In the three step_MOM_dyn_... routines and in calculateBuoyancyFlux1d, this change includes calls to thickness_to_dz to calculate the new vertical distance arrays that will be passed into vertvisc_coef or sumSWoverBands. The only place where the new arguments are actually used is in sumSWoverBands and set_opacity where the changes are particularly simple. All answers are bitwise identical, but there are new non-optional arguments to seven publicly visible routines. --- src/core/MOM.F90 | 2 +- src/core/MOM_dynamics_split_RK2.F90 | 12 ++++++---- src/core/MOM_dynamics_unsplit.F90 | 12 ++++++---- src/core/MOM_dynamics_unsplit_RK2.F90 | 10 ++++++--- src/core/MOM_forcing_type.F90 | 5 ++++- src/parameterizations/lateral/MOM_MEKE.F90 | 7 +++--- .../vertical/MOM_CVMix_KPP.F90 | 3 ++- .../vertical/MOM_diabatic_aux.F90 | 10 ++++++--- .../vertical/MOM_diabatic_driver.F90 | 22 +++++++++---------- .../vertical/MOM_opacity.F90 | 10 +++++---- .../vertical/MOM_set_diffusivity.F90 | 3 ++- src/parameterizations/vertical/MOM_sponge.F90 | 17 ++++++++------ .../vertical/MOM_vert_friction.F90 | 6 ++++- 13 files changed, 75 insertions(+), 44 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 703514fc52..df3a308e85 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3002,7 +3002,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call cpu_clock_end(id_clock_MOM_init) if (CS%use_dbclient) call database_comms_init(param_file, CS%dbcomms_CS) - CS%useMEKE = MEKE_init(Time, G, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, & + CS%useMEKE = MEKE_init(Time, G, GV, US, param_file, diag, CS%dbcomms_CS, CS%MEKE_CSp, CS%MEKE, & restart_CSp, CS%MEKE_in_dynamics) call VarMix_init(Time, G, GV, US, param_file, diag, CS%VarMix) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 9fb1a6b356..5ce9ec8962 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -50,7 +50,7 @@ module MOM_dynamics_split_RK2 use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds @@ -322,6 +322,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations @@ -567,7 +568,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2)") @@ -659,7 +661,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%debug) then call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - call vertvisc_coef(up, vp, h, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, & + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & CS%OBC, VarMix) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) @@ -880,7 +883,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u <- u + dt d/dz visc d/dz u ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (G%nonblocking_updates) then diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index e6f99cc9d8..80f7853744 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -79,7 +79,7 @@ module MOM_dynamics_unsplit use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type @@ -223,6 +223,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av, hp ! Predicted or averaged layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up, upp ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp, vpp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] @@ -345,7 +346,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & call disable_averaging(CS%diag) dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred - call vertvisc_coef(up, vp, h_av, forces, visc, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -405,7 +407,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! upp <- upp + dt/2 d/dz visc d/dz upp call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(upp, vpp, hp, forces, visc, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(hp, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(upp, vpp, hp, dz, forces, visc, tv, dt*0.5, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(upp, vpp, hp, forces, visc, dt*0.5, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) @@ -489,7 +492,8 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! u <- u + dt d/dz visc d/dz u call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(u, v, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u, v, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u, v, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, Waves=Waves) call cpu_clock_end(id_clock_vertvisc) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index fbf416d13d..d1afca51d9 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -78,6 +78,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_init, hor_visc_CS +use MOM_interface_heights, only : thickness_to_dz use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type @@ -234,6 +235,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! Averaged layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocities [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocities [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] @@ -341,7 +343,8 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - call vertvisc_coef(up, vp, h_av, forces, visc, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) @@ -392,10 +395,11 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n] <- up* + dt d/dz visc d/dz up ! u[n] <- u*[n] + dt d/dz visc d/dz u[n] call cpu_clock_begin(id_clock_vertvisc) - call vertvisc_coef(up, vp, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, & G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) - call vertvisc_coef(u_in, v_in, h_av, forces, visc, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc_coef(u_in, v_in, h_av, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u_in, v_in, h_av, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp,& G, GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot) call cpu_clock_end(id_clock_vertvisc) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a59c33d525..4897771100 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -15,6 +15,7 @@ module MOM_forcing_type use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_opacity, only : sumSWoverBands, optics_type, extract_optics_slice, optics_nbands use MOM_spatial_means, only : global_area_integral, global_area_mean use MOM_spatial_means, only : global_area_mean_u, global_area_mean_v @@ -974,6 +975,7 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(SZI_(G)) :: netEvap ! net FW flux leaving ocean via evaporation ! [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: netHeat ! net temp flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + real, dimension(SZI_(G), SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] real, dimension(max(nsw,1), SZI_(G)) :: penSWbnd ! penetrating SW radiation by band ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] @@ -1013,7 +1015,8 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt ! Sum over bands and attenuate as a function of depth ! netPen is the netSW as a function of depth - call sumSWoverBands(G, GV, US, h(:,j,:), optics_nbands(optics), optics, j, 1.0, & + call thickness_to_dz(h, tv, dz, j, G, GV) + call sumSWoverBands(G, GV, US, h(:,j,:), dz, optics_nbands(optics), optics, j, 1.0, & H_limit_fluxes, .true., penSWbnd, netPen) ! Density derivatives diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 6a439dfd22..02338fab96 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1088,12 +1088,13 @@ end subroutine MEKE_lengthScales_0d !> Initializes the MOM_MEKE module and reads parameters. !! Returns True if module is to be used, otherwise returns False. -logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, restart_CS, meke_in_dynamics) +logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, MEKE, restart_CS, meke_in_dynamics) type(time_type), intent(in) :: Time !< The current model time. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. - type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Database communications control structure + type(dbcomms_CS_type), intent(in) :: dbcomms_CS !< Database communications control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics structure. type(MEKE_CS), intent(inout) :: CS !< MEKE control structure. type(MEKE_type), intent(inout) :: MEKE !< MEKE fields @@ -1102,7 +1103,7 @@ logical function MEKE_init(Time, G, US, param_file, diag, dbcomms_CS, CS, MEKE, !! otherwise in tracer dynamics ! Local variables - real :: MEKE_restoring_timescale ! The timescale used to nudge MEKE toward its equilibrium value [T ~> s] + 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 character(len=16) :: eke_source_str diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 0127f8c556..32946021be 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -596,7 +596,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) end function KPP_init !> KPP vertical diffusivity/viscosity and non-local tracer transport -subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & +subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! Arguments @@ -605,6 +605,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3096fe72cd..ba265af5e2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -224,7 +224,7 @@ end subroutine make_frazil !> This subroutine applies double diffusion to T & S, assuming no diapycnal mass !! fluxes, using a simple tridiagonal solver. -subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) +subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -234,13 +234,15 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, dt, G, GV) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: S !< Salinity [PSU] or [gSalt/kg], generically [S ~> ppt]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd_T !< The extra diffusivity of temperature due to + intent(in) :: Kd_T !< The extra diffusivity of temperature due to !! double diffusion relative to the diffusivity of !! diffusivity of density [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_S !< The extra diffusivity of salinity due to !! double diffusion relative to the diffusivity of !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s]. ! local variables @@ -1555,7 +1557,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, ! in which case the values of dt, h, optics and H_limit_fluxes are irrelevant. Consider ! writing a shorter and simpler variant to handle this very limited case. - ! call sumSWoverBands(G, GV, US, h2d(:,:), optics_nbands(optics), optics, j, dt, & + ! Find the vertical distances across layers. + ! call thickness_to_dz(h, tv, dz, j, G, GV) + ! call sumSWoverBands(G, GV, US, h2d, dz, optics_nbands(optics), optics, j, dt, & ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1bc29ee16f..0c28c063ea 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -351,7 +351,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call diapyc_energy_req_test(h, dt, tv, G, GV, US, CS%diapyc_en_rec_CSp) call cpu_clock_begin(id_clock_set_diffusivity) - call set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) + call set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS%set_diff_CSp, OBC=OBC) call cpu_clock_end(id_clock_set_diffusivity) ! Frazil formation keeps the temperature above the freezing point. @@ -679,13 +679,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -751,7 +751,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%double_diffuse .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, dt, G, GV) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") @@ -1281,13 +1281,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -1889,13 +1889,13 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -1973,7 +1973,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%double_diffuse .and. associated(tv%T)) then call cpu_clock_begin(id_clock_differential_diff) - call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, dt, G, GV) + call differential_diffuse_T_S(h, tv%T, tv%S, Kd_extra_T, Kd_extra_S, tv, dt, G, GV) call cpu_clock_end(id_clock_differential_diff) if (showCallTree) call callTree_waypoint("done with differential_diffuse_T_S (diabatic)") if (CS%debugConservation) call MOM_state_stats('differential_diffuse_T_S', u, v, h, tv%T, tv%S, G, GV, US) @@ -2398,9 +2398,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call calculate_density(tv%T(:,j,1), tv%S(:,j,1), p_ref_cv, Rcv_ml(:,j), & tv%eqn_of_state, EOSdom) enddo - call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp, Rcv_ml) else - call apply_sponge(h, dt, G, GV, US, ea, eb, CS%sponge_CSp) + call apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS%sponge_CSp) endif call cpu_clock_end(id_clock_sponge) if (CS%debug) then diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index 77de5d13cd..a8029d031f 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -128,13 +128,13 @@ subroutine set_opacity(optics, sw_total, sw_vis_dir, sw_vis_dif, sw_nir_dir, sw_ ! Make sure there is no division by 0. inv_sw_pen_scale = 1.0 / max(CS%pen_sw_scale, 0.1*GV%Angstrom_Z, & - GV%H_to_Z*GV%H_subroundoff) + GV%dZ_subroundoff) if ( CS%Opacity_scheme == DOUBLE_EXP ) then !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do i=is,ie optics%opacity_band(1,i,j,k) = inv_sw_pen_scale optics%opacity_band(2,i,j,k) = 1.0 / max(CS%pen_sw_scale_2nd, & - 0.1*GV%Angstrom_Z, GV%H_to_Z*GV%H_subroundoff) + 0.1*GV%Angstrom_Z, GV%dZ_subroundoff) enddo ; enddo ; enddo if (.not.associated(sw_total) .or. (CS%pen_SW_scale <= 0.0)) then !$OMP parallel do default(shared) @@ -793,13 +793,15 @@ end subroutine absorbRemainingSW !> This subroutine calculates the total shortwave heat flux integrated over !! bands as a function of depth. This routine is only called for computing !! buoyancy fluxes for use in KPP. This routine does not update the state. -subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & +subroutine sumSWoverBands(G, GV, US, h, dz, nsw, optics, j, dt, & H_limit_fluxes, absorbAllSW, iPen_SW_bnd, netPen) 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),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Layer vertical extent [Z ~> m]. integer, intent(in) :: nsw !< The number of bands of penetrating shortwave !! radiation, perhaps from optics_nbands(optics), type(optics_type), intent(in) :: optics !< An optics structure that has values @@ -877,7 +879,7 @@ subroutine sumSWoverBands(G, GV, US, h, nsw, optics, j, dt, & if (h(i,k) > 0.0) then do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then ! SW_trans is the SW that is transmitted THROUGH the layer - opt_depth = h(i,k)*GV%H_to_Z * optics%opacity_band(n,i,j,k) + opt_depth = dz(i,k) * optics%opacity_band(n,i,j,k) exp_OD = exp(-opt_depth) SW_trans = exp_OD diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 0dec7a40c0..9dc7b81c46 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -1656,7 +1656,7 @@ end subroutine add_MLrad_diffusivity !> This subroutine calculates several properties related to bottom !! boundary layer turbulence. -subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) +subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) 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 @@ -1666,6 +1666,7 @@ subroutine set_BBL_TKE(u, v, h, fluxes, visc, G, GV, US, CS, OBC) intent(in) :: v !< The meridional velocity [L T-1 ~> m s-1] 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 !< Structure with pointers to thermodynamic fields type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes type(vertvisc_type), intent(inout) :: visc !< Structure containing vertical viscosities, bottom !! boundary layer properties and related fields. diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index 0ef732a024..fce1eb493d 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -3,16 +3,17 @@ module MOM_sponge ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_coms, only : sum_across_PEs +use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type use MOM_spatial_means, only : global_i_mean -use MOM_time_manager, only : time_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_time_manager, only : time_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type ! Planned extension: Support for time varying sponge targets. @@ -301,12 +302,14 @@ end subroutine set_up_sponge_ML_density !> This subroutine applies damping to the layers thicknesses, mixed layer buoyancy, and a variety of !! tracers for every column where there is damping. -subroutine apply_sponge(h, dt, G, GV, US, ea, eb, CS, Rcv_ml) +subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ea !< An array to which the amount of fluid entrained diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 80fff62f21..0ab283a90e 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -938,7 +938,7 @@ end subroutine vertvisc_remnant !> Calculate the coupling coefficients (CS%a_u, CS%a_v, CS%a_u_gl90, CS%a_v_gl90) !! and effective layer thicknesses (CS%h_u and CS%h_v) for later use in the !! applying the implicit vertical viscosity via vertvisc(). -subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) +subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, VarMix) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -948,8 +948,12 @@ subroutine vertvisc_coef(u, v, h, forces, visc, dt, G, GV, US, CS, OBC, VarMix) intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] 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) :: dz !< Vertical distance across layers [Z ~> m] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces type(vertvisc_type), intent(in) :: visc !< Viscosities and bottom drag + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure From b4bd223222b893097880a30452a4b09996feb1c7 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 19 Jul 2023 14:31:06 -0600 Subject: [PATCH 318/629] Output relevant fields when diff or visc < 0 Writes useful fields when the diffusivity of viscosity is less than zero. The should help understanding the root cause of such cases and facilitate the necessary adjustments. --- src/parameterizations/vertical/MOM_CVMix_KPP.F90 | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 0127f8c556..44b1d720b1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -787,6 +787,22 @@ subroutine KPP_calculate(CS, G, GV, US, h, uStar, buoyFlux, Kt, Ks, Kv, & ! safety check, Kviscosity and Kdiffusivity must be >= 0 do k=1, GV%ke+1 if (Kviscosity(k) < 0. .or. Kdiffusivity(k,1) < 0.) then + write(*,'(a,3i3)') 'interface, i, j, k = ',j, j, k + write(*,'(a,2f12.5)') 'lon,lat=', G%geoLonT(i,j), G%geoLatT(i,j) + write(*,'(a,es12.4)') 'depth, z_inter(k) =',z_inter(k) + write(*,'(a,es12.4)') 'Kviscosity(k) =',Kviscosity(k) + write(*,'(a,es12.4)') 'Kdiffusivity(k,1) =',Kdiffusivity(k,1) + write(*,'(a,es12.4)') 'Kdiffusivity(k,2) =',Kdiffusivity(k,2) + write(*,'(a,es12.4)') 'OBLdepth =',US%Z_to_m*CS%OBLdepth(i,j) + write(*,'(a,f8.4)') 'kOBL =',CS%kOBL(i,j) + write(*,'(a,es12.4)') 'u* =',surfFricVel + write(*,'(a,es12.4)') 'bottom, z_inter(GV%ke+1) =',z_inter(GV%ke+1) + write(*,'(a,es12.4)') 'CS%La_SL(i,j) =',CS%La_SL(i,j) + write(*,'(a,es12.4)') 'LangEnhK =',LangEnhK + if (present(lamult)) write(*,'(a,es12.4)') 'lamult(i,j) =',lamult(i,j) + write(*,*) 'Kviscosity(:) =',Kviscosity(:) + write(*,*) 'Kdiffusivity(:,1) =',Kdiffusivity(:,1) + call MOM_error(FATAL,"KPP_calculate, after CVMix_coeffs_kpp: "// & "Negative vertical viscosity or diffusivity has been detected. " // & "This is likely related to the choice of MATCH_TECHNIQUE and INTERP_TYPE2." //& From df0eaf0c608d40c8ef45adc91991490bfc21111e Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 19 Jul 2023 21:15:57 -0400 Subject: [PATCH 319/629] 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 0bcf0312391992f63ee28f98bb2571c3a675be93 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Wed, 19 Jul 2023 21:15:57 -0400 Subject: [PATCH 320/629] 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 25feaf2ce017c087a06980ee8106f17f1ea605f2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 18 Jul 2023 09:44:17 -0400 Subject: [PATCH 321/629] Fix logic for setting KV_ML_INVZ2 from KVML - We were reading KV_ML_INVZ2 without logging, then checking for KVML and finally logging based on a combination of the two. This had the side affect that we get warnings about not using KVML even if KVML was not present. - The fix checks for KVML first, and then changes the default so that when KVML=1e-4 is replaced by KV_ML_INVZ2=1e-4 we end up with no warnings and KVML can be obsoleted safely. Note: this commit alone does not remove all warnings from the MOM6-examples suite because we still need to fix the MOM_input that still use KVML - KVML needs to be unscaled since it is the default for KV_ML_INVZ2 - tc3 used KVML and has been corrected. --- .testing/tc3/MOM_input | 8 +++--- .../vertical/MOM_vert_friction.F90 | 25 +++++++------------ 2 files changed, 13 insertions(+), 20 deletions(-) diff --git a/.testing/tc3/MOM_input b/.testing/tc3/MOM_input index a034960d1e..6963feee98 100644 --- a/.testing/tc3/MOM_input +++ b/.testing/tc3/MOM_input @@ -283,10 +283,10 @@ HMIX_FIXED = 20.0 ! [m] KV = 1.0E-04 ! [m2 s-1] ! The background kinematic viscosity in the interior. ! The molecular value, ~1e-6 m2 s-1, may be used. -KVML = 0.01 ! [m2 s-1] default = 1.0E-04 - ! The kinematic viscosity in the mixed layer. A typical - ! value is ~1e-2 m2 s-1. KVML is not used if - ! BULKMIXEDLAYER is true. The default is set by KV. +KV_ML_INVZ2 = 0.01 ! [m2 s-1] default = 0.0 + ! An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, with + ! the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the distance + ! from the surface, to allow for finite wind stresses to be transmitted through. HBBL = 10.0 ! [m] ! The thickness of a bottom boundary layer with a ! viscosity of KVBBL if BOTTOMDRAGLAW is not defined, or diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 0ab283a90e..496012c3d9 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2156,6 +2156,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & # include "version_variable.h" character(len=40) :: mdl = "MOM_vert_friction" ! This module's name. character(len=40) :: thickness_units + real :: Kv_mks ! KVML in MKS if (associated(CS)) then call MOM_error(WARNING, "vertvisc_init called with an associated "// & @@ -2339,30 +2340,22 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%Kvml_invZ2 = 0.0 if (GV%nkml < 1) then - call get_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & - "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& - "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& - "distance from the surface, to allow for finite wind stresses to be "//& - "transmitted through infinitesimally thin surface layers. This is an "//& - "older option for numerical convenience without a strong physical basis, "//& - "and its use is now discouraged.", & - units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) - if (CS%Kvml_invZ2 < 0.0) then - call get_param(param_file, mdl, "KVML", CS%Kvml_invZ2, & + call get_param(param_file, mdl, "KVML", Kv_mks, & "The scale for an extra kinematic viscosity in the mixed layer", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) - if (CS%Kvml_invZ2 >= 0.0) & - call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") + units="m2 s-1", default=-1.0, do_not_log=.true.) + if (Kv_mks >= 0.0) then + call MOM_error(WARNING, "KVML is a deprecated parameter. Use KV_ML_INVZ2 instead.") + else + Kv_mks = 0.0 endif - if (CS%Kvml_invZ2 < 0.0) CS%Kvml_invZ2 = 0.0 - call log_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & + call get_param(param_file, mdl, "KV_ML_INVZ2", CS%Kvml_invZ2, & "An extra kinematic viscosity in a mixed layer of thickness HMIX_FIXED, "//& "with the actual viscosity scaling as 1/(z*HMIX_FIXED)^2, where z is the "//& "distance from the surface, to allow for finite wind stresses to be "//& "transmitted through infinitesimally thin surface layers. This is an "//& "older option for numerical convenience without a strong physical basis, "//& "and its use is now discouraged.", & - units="m2 s-1", default=0.0, unscale=US%Z2_T_to_m2_s) + units="m2 s-1", default=Kv_mks, scale=US%m2_s_to_Z2_T) endif if (.not.CS%bottomdraglaw) then From a5129ca3772d461b8bcb12b1aa23b2b942a734bd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 10:07:18 -0400 Subject: [PATCH 322/629] +Use RHO_PGF_REF for the pressure gradient forces Use the new runtime parameter RHO_PGF_REF instead of RHO_0 to set the reference density that is subtracted off from the other densities when calculating the finite volume pressure gradient forces. Although the answers are mathematically equivalent for any value of this parameter, a judicious choice can reduce the impacts of roundoff errors by about 2 orders of magnitude. By default, RHO_PGF_REF is set to RHO_0, and all answers are bitwise identical. However, there is a new runtime parameter that appears in many of the MOM_parameter_doc.all files. --- src/core/MOM_PressureForce_FV.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 14c9b2e6dc..281623ae84 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -519,7 +519,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (associated(ALE_CSp)) use_ALE = CS%reconstruct .and. use_EOS h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0 / GV%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 @@ -827,12 +827,11 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RHO_PGF_REF", CS%Rho0, & + "The reference density that is subtracted off when calculating pressure "//& + "gradient forces. Its inverse is subtracted off of specific volumes when "//& + "in non-Boussinesq mode. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & From bb71c346ac4dc1d9c87f2d4e265ecfc1bed90403 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 20 Jul 2023 09:18:21 -0400 Subject: [PATCH 323/629] Converted warning about depth_list to a note The message that a file is being created was issued as a WARNING when we all agree it should really be a NOTE. Depth_list.nc is read if it is present to avoid recomputing a sorted list, but the absence of the file is not an error and does not warrant a warning. Changes: - Changed WARNING to NOTE. - Removed MOM_mesg from imports since it wasn't being used. --- src/diagnostics/MOM_sum_output.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index fd957d0a44..aae32a7862 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -8,7 +8,7 @@ module MOM_sum_output use MOM_coms, only : sum_across_PEs, PE_here, root_PE, num_PEs, max_across_PEs, field_chksum use MOM_coms, only : reproducing_sum, reproducing_sum_EFP, EFP_to_real, real_to_EFP use MOM_coms, only : EFP_type, operator(+), operator(-), assignment(=), EFP_sum_across_PEs -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, MOM_mesg +use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type @@ -1077,7 +1077,7 @@ subroutine depth_list_setup(G, GV, US, DL, CS) valid_DL_read = .true. ! Otherwise there would have been a fatal error. endif else - if (is_root_pe()) call MOM_error(WARNING, "depth_list_setup: "// & + if (is_root_pe()) call MOM_error(NOTE, "depth_list_setup: "// & trim(CS%depth_list_file)//" does not exist. Creating a new file.") valid_DL_read = .false. endif From b9c7c8689707b0a4e6c9d1d95fa9c57fcd5202f6 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 19 Jul 2023 09:32:28 -0400 Subject: [PATCH 324/629] Correct diagnostic coordinate interpolation scheme The interpolation scheme for state-dependent diagnostic coordinates was incorrectly registering as the same parameter as the main model. This meant it was never possible to change the interpolation scheme from the default (which was not the same as the main model). Fix registers the generated parameter name which was always computed but not used. A typical example of the generated parameter is "DIAG_COORD_INTERP_SCHEME_RHO2". --- src/ALE/MOM_regridding.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index c5f5807f66..4cc60d16b2 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -263,7 +263,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m param_name = create_coord_param(param_prefix, "INTERP_SCHEME", param_suffix) string2 = 'PPM_H4' ! Default for diagnostics endif - call get_param(param_file, mdl, "INTERPOLATION_SCHEME", string, & + call get_param(param_file, mdl, param_name, string, & "This sets the interpolation scheme to use to "//& "determine the new grid. These parameters are "//& "only relevant when REGRIDDING_COORDINATE_MODE is "//& From ccd3ded7b6279f433115e16f183cf29a1c38063e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Jul 2023 07:23:09 -0400 Subject: [PATCH 325/629] +(*)Fix wave_speed_init mono_N2_depth bug Fixed a bug in which wave_speed_init was effectively discarding any values of mono_N2_depth passed to it via the optional argument mono_N2_depth, but also changed the default value of RESOLN_N2_FILTER_DEPTH, which was previously being discarded, to disable the monotonization and replicate the previous results. There were also clarifying additions made to the description how to disable RESOLN_N2_FILTER_DEPTH. This will change some entries in MOM_parameter_doc files, and it will change solutions in cases that set RESOLN_N2_FILTER_DEPTH to a non-default value and have parameter settings that use the resolution function to scale their horizontal mixing. There are, however, no known active simulations where the answers are expected to change. --- src/diagnostics/MOM_wave_speed.F90 | 4 +++- src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 | 5 +++-- 2 files changed, 6 insertions(+), 3 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index bb1b381c15..5757e25cd1 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -39,6 +39,7 @@ module MOM_wave_speed !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! If this parameter is negative, this limiting does not occur. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. real :: min_speed2 = 0. !< The minimum mode 1 internal wave speed squared [L2 T-2 ~> m2 s-2] @@ -1465,7 +1466,8 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de call log_version(mdl, version) call wave_speed_set_param(CS, use_ebt_mode=use_ebt_mode, mono_N2_column_fraction=mono_N2_column_fraction, & - better_speed_est=better_speed_est, min_speed=min_speed, wave_speed_tol=wave_speed_tol, & + mono_N2_depth=mono_N2_depth, better_speed_est=better_speed_est, & + min_speed=min_speed, wave_speed_tol=wave_speed_tol, & remap_answers_2018=remap_answers_2018, remap_answer_date=remap_answer_date, & c1_thresh=c1_thresh) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 7d71a62e25..8f0aa02b12 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1239,8 +1239,9 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) in_use = .true. call get_param(param_file, mdl, "RESOLN_N2_FILTER_DEPTH", N2_filter_depth, & "The depth below which N2 is monotonized to avoid stratification "//& - "artifacts from altering the equivalent barotropic mode structure.",& - units="m", default=2000., scale=US%m_to_Z) + "artifacts from altering the equivalent barotropic mode structure. "//& + "This monotonzization is disabled if this parameter is negative.", & + units="m", default=-1.0, scale=US%m_to_Z) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif From 6102be250c7ad59ffb3afe8816058a0d29f2cae7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 10:35:09 -0400 Subject: [PATCH 326/629] *+Revise non-Boussinesq gprime expressions Revised the calculation of gprime and the coordinate densities (GV%Rlay) in fully non-Boussinesq mode to use the arithmetic mean of adjacent coordinate densities in the denominator of the expression for g_prime in place of RHO_0. Also use LIGHTEST_DENSITY in place of RHO_0 to specify the top-level coordinate density in certain coordinate modes. Also made corresponding changes to the fully non-Boussinesq APE calculation when CALCULATE_APE is true, and eliminated an incorrect calculation of the layer volumes in non-Boussinesq mode using the Boussinesq reference density that was never actually being used when CALCULATE_APE is false. This commit will change answers in some fully non-Boussinesq calculations, and an existing runtime parameter is used and logged in some new cases, changing the MOM_parameter_doc file in those cases. --- src/diagnostics/MOM_sum_output.F90 | 38 +++++--- .../MOM_coord_initialization.F90 | 94 +++++++++++++++---- 2 files changed, 101 insertions(+), 31 deletions(-) diff --git a/src/diagnostics/MOM_sum_output.F90 b/src/diagnostics/MOM_sum_output.F90 index aae32a7862..fb95b79a91 100644 --- a/src/diagnostics/MOM_sum_output.F90 +++ b/src/diagnostics/MOM_sum_output.F90 @@ -510,24 +510,18 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci do k=1,nz ; vol_lay(k) = (US%m_to_L**2*GV%H_to_Z/GV%H_to_kg_m2)*mass_lay(k) ; enddo else tmp1(:,:,:) = 0.0 - if (CS%do_APE_calc) then - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) - enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) + do k=1,nz ; do j=js,je ; do i=is,ie + tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) + enddo ; enddo ; enddo + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) + if (CS%do_APE_calc) then call find_eta(h, tv, G, GV, US, eta, dZref=G%Z_ref) do k=1,nz ; do j=js,je ; do i=is,ie tmp1(i,j,k) = US%Z_to_m*US%L_to_m**2*(eta(i,j,K)-eta(i,j,K+1)) * areaTm(i,j) enddo ; enddo ; enddo vol_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=vol_lay) do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2 * vol_lay(k) ; enddo - else - do k=1,nz ; do j=js,je ; do i=is,ie - tmp1(i,j,k) = HL2_to_kg * h(i,j,k) * areaTm(i,j) - enddo ; enddo ; enddo - mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer, sums=mass_lay, EFP_sum=mass_EFP) - do k=1,nz ; vol_lay(k) = US%m_to_Z*US%m_to_L**2*US%kg_m3_to_R * (mass_lay(k) / GV%Rho0) ; enddo endif endif ! Boussinesq @@ -643,7 +637,7 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci if (GV%Boussinesq) then do j=js,je ; do i=is,ie hbelow = 0.0 - do k=nz,1,-1 + do K=nz,1,-1 hbelow = hbelow + h(i,j,k) * GV%H_to_Z hint = Z_0APE(K) + (hbelow - (G%bathyT(i,j) + G%Z_ref)) hbot = Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref) @@ -652,14 +646,28 @@ subroutine write_energy(u, v, h, tv, day, n, G, GV, US, CS, tracer_CSp, dt_forci (hint * hint - hbot * hbot) enddo enddo ; enddo - else + elseif (GV%semi_Boussinesq) then do j=js,je ; do i=is,ie - do k=nz,1,-1 + do K=nz,1,-1 hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) PE_pt(i,j,K) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rho0*GV%g_prime(K))) * & - (hint * hint - hbot * hbot) + (hint * hint - hbot * hbot) + enddo + enddo ; enddo + else + do j=js,je ; do i=is,ie + do K=nz,2,-1 + hint = Z_0APE(K) + eta(i,j,K) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(K) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,K) = (0.25 * PE_scale_factor * areaTm(i,j) * & + ((GV%Rlay(k)+GV%Rlay(k-1))*GV%g_prime(K))) * & + (hint * hint - hbot * hbot) enddo + hint = Z_0APE(1) + eta(i,j,1) ! eta and H_0 have opposite signs. + hbot = max(Z_0APE(1) - (G%bathyT(i,j) + G%Z_ref), 0.0) + PE_pt(i,j,1) = (0.5 * PE_scale_factor * areaTm(i,j) * (GV%Rlay(1)*GV%g_prime(1))) * & + (hint * hint - hbot * hbot) enddo ; enddo endif diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 8af8cd3bc6..37c719209b 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -126,6 +126,7 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) ! Local variables real :: g_int ! Reduced gravities across the internal interfaces [L2 Z-1 T-2 ~> m s-2]. real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_from_gprime" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -138,11 +139,20 @@ subroutine set_coord_from_gprime(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GINT", g_int, & "The reduced gravity across internal interfaces.", & units="m s-2", fail_if_missing=.true., scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = g_int ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') @@ -184,9 +194,15 @@ subroutine set_coord_from_layer_density(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. ! g_prime(1) = g_fs - do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_layer_density @@ -237,7 +253,13 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state call calculate_density(T_ref, S_ref, P_ref, Rlay(1), eqn_of_state) ! These statements set the layer densities. ! - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_ref @@ -294,7 +316,15 @@ subroutine set_coord_from_TS_profile(Rlay, g_prime, GV, US, param_file, eqn_of_s g_prime(1) = g_fs do k=1,nz ; Pref(k) = P_Ref ; enddo call calculate_density(T0, S0, Pref, Rlay, eqn_of_state, (/1,nz/) ) - do k=2,nz; g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_profile @@ -387,7 +417,15 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta do k=k_light-1,1,-1 Rlay(k) = 2.0*Rlay(k+1) - Rlay(k+2) enddo - do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_from_TS_range @@ -429,7 +467,15 @@ subroutine set_coord_from_file(Rlay, g_prime, GV, US, param_file) call MOM_read_data(filename, coord_var, Rlay, scale=US%kg_m3_to_R) g_prime(1) = g_fs - do k=2,nz ; g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif do k=1,nz ; if (g_prime(k) <= 0.0) then call MOM_error(FATAL, "MOM_initialization set_coord_from_file: "//& "Zero or negative g_primes read from variable "//"Layer"//" in file "//& @@ -479,9 +525,15 @@ subroutine set_coord_linear(Rlay, g_prime, GV, US, param_file) enddo ! These statements set the interface reduced gravities. g_prime(1) = g_fs - do k=2,nz - g_prime(k) = (GV%g_Earth/(GV%Rho0)) * (Rlay(k) - Rlay(k-1)) - enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz + g_prime(k) = (GV%g_Earth/GV%Rho0) * (Rlay(k) - Rlay(k-1)) + enddo + else + do k=2,nz + g_prime(k) = 2.0*GV%g_Earth * (Rlay(k) - Rlay(k-1)) / (Rlay(k) + Rlay(k-1)) + enddo + endif call callTree_leave(trim(mdl)//'()') end subroutine set_coord_linear @@ -498,6 +550,7 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters ! Local variables real :: g_fs ! Reduced gravity across the free surface [L2 Z-1 T-2 ~> m s-2]. + real :: Rlay_Ref ! The target density of the surface layer [R ~> kg m-3]. character(len=40) :: mdl = "set_coord_to_none" ! This subroutine's name. integer :: k, nz nz = GV%ke @@ -507,11 +560,20 @@ subroutine set_coord_to_none(Rlay, g_prime, GV, US, param_file) call get_param(param_file, mdl, "GFS" , g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) + call get_param(param_file, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) g_prime(1) = g_fs do k=2,nz ; g_prime(k) = 0. ; enddo - Rlay(1) = GV%Rho0 - do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + Rlay(1) = Rlay_Ref + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do k=2,nz ; Rlay(k) = Rlay(k-1) + g_prime(k)*(GV%Rho0/GV%g_Earth) ; enddo + else + do k=2,nz + Rlay(k) = Rlay(k-1) * ((GV%g_Earth + 0.5*g_prime(k)) / (GV%g_Earth - 0.5*g_prime(k))) + enddo + endif call callTree_leave(trim(mdl)//'()') @@ -522,8 +584,8 @@ end subroutine set_coord_to_none subroutine write_vertgrid_file(GV, US, param_file, directory) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=*), intent(in) :: directory !< The directory into which to place the file. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=*), intent(in) :: directory !< The directory into which to place the file. ! Local variables character(len=240) :: filepath type(vardesc) :: vars(2) From 2f6e86e342608f07f5cc3fb478a22cc6089075b3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 21 Jul 2023 12:00:14 -0400 Subject: [PATCH 327/629] *Non-Boussinesq revision of MOM_thickness_diffuse Refactored thickness_diffuse when in non-Boussinesq mode to avoid any dependencies on the Boussinesq reference density, and to translate the volume streamfunction into the mass streamfunction using an appropriately defined in-situ density averaged to the interfaces at velocity points. This form follows the suggestions of Appendix A.3.2 of Griffies and Greatbatch (Ocean Modelling, 2012) when in non-Boussinesq mode. Thickness_diffuse_full was also revised to work properly in non-Boussinesq mode (and not depend on the Boussinesq reference density) when no equation of state is used. As a part of these changes, the code now uses thickness-based streamfunctions and other thickness-based internal calculations in MOM_thickness_diffuse. For example, the overturning streamfunctions with this change are now in m3/s in Boussinesq mode, but kg/s in non-Boussinesq mode. These changes use a call to thickness_to_dz to set up a separate variable with the vertical distance across layers, and in non-Boussinesq mode they use tv%SpV_avg to estimate in situ densities. Additional debugging checksums were added to thickness_diffuse. The code changes are extensive with 15 new or renamed internal variables, and changes to the units of 9 other internal variables and 3 arguments to the private routine streamfn_solver. After this change, GV%Rho, GV%Z_to_H and GV%H_to_Z are no longer used in any non-Boussinesq calculations (12 such instances having been elimated). Because some calculations have to be redone with the separate thickness and dz variables, this will be more expensive than the original version. No public interfaces are changed, and all answers are bitwise identical in Boussinesq or semiBoussinesq mode, but they will change in non-Boussinesq mode when the isopycnal height diffusion parameterization is used. --- .../lateral/MOM_thickness_diffuse.F90 | 286 ++++++++++++------ 1 file changed, 195 insertions(+), 91 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index a7ff2f1c0a..8617795e16 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -14,7 +14,7 @@ module MOM_thickness_diffuse use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, slasher -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type @@ -439,7 +439,6 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp endif endif - !$OMP do do K=1,nz+1 ; do j=js,je ; do I=is-1,ie ; int_slope_u(I,j,K) = 0.0 ; enddo ; enddo ; enddo !$OMP do @@ -458,6 +457,12 @@ subroutine thickness_diffuse(h, uhtr, vhtr, tv, dt, G, GV, US, MEKE, VarMix, CDp if (CS%debug) then call uvchksum("Kh_[uv]", Kh_u, Kh_v, G%HI, haloshift=0, & scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + call uvchksum("Kh_[uv]_CFL", Kh_u_CFL, Kh_v_CFL, G%HI, haloshift=0, & + scale=(US%L_to_m**2)*US%s_to_T, scalar_pair=.true.) + if (Resoln_scaled) then + call uvchksum("Res_fn_[uv]", VarMix%Res_fn_u, VarMix%Res_fn_v, G%HI, haloshift=0, & + scale=1.0, scalar_pair=.true.) + endif call uvchksum("int_slope_[uv]", int_slope_u, int_slope_v, G%HI, haloshift=0) call hchksum(h, "thickness_diffuse_1 h", G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(e, "thickness_diffuse_1 e", G%HI, haloshift=1, scale=US%Z_to_m) @@ -628,14 +633,17 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. h_frac ! The fraction of the mass in the column above the bottom ! interface of a layer that is within a layer [nondim]. 0 m] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [nondim] hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency - ! at v-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + ! at v-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [nondim] hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency - ! at u-points [L2 Z-1 T-2 ~> m s-2], used for calculating PE release + ! at u-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], + ! used for calculating the potential energy release real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & pres, & ! The pressure at an interface [R L2 T-2 ~> Pa]. h_avail_rsum ! The running sum of h_avail above an interface [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -670,8 +678,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV real :: Work_v(SZI_(G),SZJB_(G)) ! The work done by the isopycnal height diffusion ! integrated over v-point water columns [R Z L4 T-3 ~> W] real :: Work_h ! The work averaged over an h-cell [R Z L2 T-3 ~> W m-2]. - real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell [L4 Z-1 T-3 ~> m3 s-3] - ! The calculation is equal to h * S^2 * N^2 * kappa_GM. + real :: PE_release_h ! The amount of potential energy released by GM averaged over an h-cell + ! [R Z L2 T-3 ~> W m-2]. The calculation equals rho0 * h * S^2 * N^2 * kappa_GM. real :: I4dt ! 1 / 4 dt [T-1 ~> s-1]. real :: drdiA, drdiB ! Along layer zonal potential density gradients in the layers above (A) ! and below (B) the interface times the grid spacing [R ~> kg m-3]. @@ -686,57 +694,71 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! [Z R ~> kg m-2]. real :: hg2A, hg2B, hg2L, hg2R ! Squares of geometric mean thicknesses [H2 ~> m2 or kg2 m-4]. real :: haA, haB, haL, haR ! Arithmetic mean thicknesses [H ~> m or kg m-2]. - real :: dzaL, dzaR ! Temporary thicknesses [Z ~> m] + real :: dzg2A, dzg2B ! Squares of geometric mean vertical layer extents [Z2 ~> m2]. + real :: dzaA, dzaB ! Arithmetic mean vertical layer extents [Z ~> m]. + real :: dzaL, dzaR ! Temporary vertical layer extents [Z ~> m] real :: wtA, wtB ! Unnormalized weights of the slopes above and below [H3 ~> m3 or kg3 m-6] real :: wtL, wtR ! Unnormalized weights of the slopes to the left and right [H3 Z ~> m4 or kg3 m-5] real :: drdx, drdy ! Zonal and meridional density gradients [R L-1 ~> kg m-4]. real :: drdz ! Vertical density gradient [R Z-1 ~> kg m-4]. - real :: h_harm ! Harmonic mean layer thickness [H ~> m or kg m-2]. - real :: c2_h_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by h at u-points [L2 Z-1 T-2 ~> m s-2]. - real :: c2_h_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by h at v-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_u(SZIB_(G),SZK_(GV)+1) ! Thickness in m times N2 at interfaces above u-points [L2 Z-1 T-2 ~> m s-2]. - real :: hN2_v(SZI_(G),SZK_(GV)+1) ! Thickness in m times N2 at interfaces above v-points [L2 Z-1 T-2 ~> m s-2]. + real :: dz_harm ! Harmonic mean layer vertical extent [Z ~> m]. + real :: c2_dz_u(SZIB_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at u-points times rescaling + ! factors from depths to thicknesses [H2 L2 Z-3 T-2 ~> m s-2 or kg m-2 s-2] + real :: c2_dz_v(SZI_(G),SZK_(GV)+1) ! Wave speed squared divided by dz at v-points times rescaling + ! factors from depths to thicknesses [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: dzN2_u(SZIB_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above u-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] + real :: dzN2_v(SZI_(G),SZK_(GV)+1) ! Vertical extent times N2 at interfaces above v-points times + ! rescaling factors from vertical to horizontal distances [L2 Z-1 T-2 ~> m s-2] real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning - ! streamfunction [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Streamfunction for u-points [Z L2 T-1 ~> m3 s-1]. - real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Streamfunction for v-points [Z L2 T-1 ~> m3 s-1]. + ! streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: Sfn_unlim_u(SZIB_(G),SZK_(GV)+1) ! Volume streamfunction for u-points [Z L2 T-1 ~> m3 s-1] + real :: Sfn_unlim_v(SZI_(G),SZK_(GV)+1) ! Volume streamfunction for v-points [Z L2 T-1 ~> m3 s-1] real :: slope2_Ratio_u(SZIB_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: slope2_Ratio_v(SZI_(G),SZK_(GV)+1) ! The ratio of the slope squared to slope_max squared [nondim] real :: Sfn_in_h ! The overturning streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] (note that ! the units are different from other Sfn vars). - real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface. This is a - ! good thing to use when the slope is so large as to be meaningless [Z L2 T-1 ~> m3 s-1]. + real :: Sfn_safe ! The streamfunction that goes linearly back to 0 at the surface + ! [H L2 T-1 ~> m3 s-1 or kg s-1]. This is a good value to use when the + ! slope is so large as to be meaningless, usually due to weak stratification. real :: Slope ! The slope of density surfaces, calculated in a way that is always ! between -1 and 1 after undoing dimensional scaling, [Z L-1 ~> nondim] real :: mag_grad2 ! The squared magnitude of the 3-d density gradient [R2 L-2 ~> kg2 m-8]. real :: I_slope_max2 ! The inverse of slope_max squared [L2 Z-2 ~> nondim]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4]. real :: dz_neglect ! A thickness [Z ~> m], that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: G_scale ! The gravitational acceleration times a unit conversion ! factor [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. logical :: find_work ! If true, find the change in energy due to the fluxes. integer :: nk_linear ! The number of layers over which the streamfunction goes to 0. real :: G_rho0 ! g/Rho0 [L2 R-1 Z-1 T-2 ~> m4 kg-1 s-2]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] real :: N2_floor ! A floor for N2 to avoid degeneracy in the elliptic solver ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] + real :: N2_unlim ! An unlimited estimate of the buoyancy frequency + ! times unit conversion factors [L2 Z-2 T-2 ~> s-2] real :: Tl(5) ! copy of T in local stencil [C ~> degC] real :: mn_T ! mean of T in local stencil [C ~> degC] real :: mn_T2 ! mean of T**2 in local stencil [C2 ~> degC2] real :: hl(5) ! Copy of local stencil of H [H ~> m] real :: r_sm_H ! Reciprocal of sum of H in local stencil [H-1 ~> m-1] + real :: Z_to_H ! A conversion factor from heights to thicknesses, perhaps based on + ! a spatially variable local density [H Z-1 ~> nondim or kg m-3] real :: Tsgs2(SZI_(G),SZJ_(G),SZK_(GV)) ! Sub-grid temperature variance [C2 ~> degC2] real :: diag_sfn_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction ! [H L2 T-1 ~> m3 s-1 or kg s-1] real :: diag_sfn_unlim_x(SZIB_(G),SZJ_(G),SZK_(GV)+1) ! Diagnostic of the x-face streamfunction before - ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + ! applying limiters [Z L2 T-1 ~> m3 s-1] real :: diag_sfn_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction ! [H L2 T-1 ~> m3 s-1 or kg s-1] real :: diag_sfn_unlim_y(SZI_(G),SZJB_(G),SZK_(GV)+1) ! Diagnostic of the y-face streamfunction before - ! applying limiters [H L2 T-1 ~> m3 s-1 or kg s-1] + ! applying limiters [Z L2 T-1 ~> m3 s-1] logical :: present_slope_x, present_slope_y, calc_derivatives integer, dimension(2) :: EOSdom_u ! The shifted I-computational domain to use for equation of ! state calculations at u-points. @@ -753,10 +775,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV I_slope_max2 = 1.0 / (CS%slope_max**2) G_scale = GV%g_Earth * GV%H_to_Z - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff*GV%H_to_Z + h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 ; hn_2 = 0.5*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect**2 G_rho0 = GV%g_Earth / GV%Rho0 - N2_floor = CS%N2_floor*US%Z_to_L**2 + N2_floor = CS%N2_floor * US%Z_to_L**2 use_EOS = associated(tv%eqn_of_state) present_slope_x = PRESENT(slope_x) @@ -779,6 +801,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) endif + ! Rescale the thicknesses, perhaps using the specific volume. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + if (CS%use_FGNV_streamfn .and. .not. associated(cg1)) call MOM_error(FATAL, & "cg1 must be associated when using FGNV streamfunction.") @@ -824,20 +849,21 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV EOSdom_h1(:) = EOS_domain(G%HI, halo=1) !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & - !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & - !$OMP h_neglect2,int_slope_u,KH_u,uhtot,h_frac,h_avail_rsum, & - !$OMP uhD,h_avail,G_scale,Work_u,CS,slope_x,cg1,diag_sfn_x, & - !$OMP diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1,use_stanley,Tsgs2, & - !$OMP present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & - !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz,dz_neglect,dz_neglect2, & + !$OMP h_neglect2,hn_2,I_slope_max2,int_slope_u,KH_u,uhtot, & + !$OMP h_frac,h_avail_rsum,uhD,h_avail,Work_u,CS,slope_x,cg1, & + !$OMP diag_sfn_x,diag_sfn_unlim_x,N2_floor,EOSdom_u,EOSdom_h1, & + !$OMP use_stanley,Tsgs2,present_slope_x,G_rho0,Slope_x_PE,hN2_x_PE) & + !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u,G_scale, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,N2_unlim, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & - !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,hN2_u, & - !$OMP Sfn_unlim_u,drdi_u,drdkDe_u,h_harm,c2_h_u, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdx,mag_grad2,Slope,slope2_Ratio_u,dzN2_u, & + !$OMP Sfn_unlim_u,Rho_avg,drdi_u,drdkDe_u,c2_dz_u, & !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do j=js,je - do I=is-1,ie ; hN2_u(I,1) = 0. ; hN2_u(I,nz+1) = 0. ; enddo + do I=is-1,ie ; dzN2_u(I,1) = 0. ; dzN2_u(I,nz+1) = 0. ; enddo do K=nz,2,-1 if (find_work .and. .not.(use_EOS)) then drdiA = 0.0 ; drdiB = 0.0 @@ -907,9 +933,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haR = 0.5*(h(i+1,j,k-1) + h(i+1,j,k)) + h_neglect if (GV%Boussinesq) then dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z - else + elseif (GV%semi_Boussinesq) then dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i+1,j,K-1) - e(i+1,j,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i+1,j,k-1) + dz(i+1,j,k)) + dz_neglect endif ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. @@ -924,10 +953,23 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haA = 0.5*(h(i,j,k-1) + h(i+1,j,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i+1,j,k)) + h_neglect - ! hN2_u is used with the FGNV streamfunction formulation - hN2_u(I,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0, N2_floor) + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR)) + endif + + dzg2A = dz(i,j,k-1)*dz(i+1,j,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i+1,j,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i+1,j,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i+1,j,k)) + dz_neglect + ! dzN2_u is used with the FGNV streamfunction formulation + dzN2_u(I,K) = (0.5 * ( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_x_PE(I,j,k) = (0.5 * ( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) endif + if (present_slope_x) then Slope = slope_x(I,j,k) slope2_Ratio_u(I,K) = Slope**2 * I_slope_max2 @@ -958,11 +1000,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) Slope_x_PE(I,j,k) = MIN(Slope,CS%slope_max) - hN2_x_PE(I,j,k) = hN2_u(I,K) if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope - ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. - Sfn_unlim_u(I,K) = -((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) + ! Estimate the streamfunction at each interface [H L2 T-1 ~> m3 s-1 or kg s-1]. + Sfn_unlim_u(I,K) = -(KH_u(I,j,K)*G%dy_Cu(I,j))*Slope ! Avoid moving dense water upslope from below the level of ! the bottom on the receiving side. @@ -992,10 +1033,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope Sfn_unlim_u(I,K) = ((KH_u(I,j,K)*G%dy_Cu(I,j))*Slope) - hN2_u(I,K) = GV%g_prime(K) + dzN2_u(I,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_u(I,K) = N2_floor * dz_neglect + dzN2_u(I,K) = N2_floor * dz_neglect Sfn_unlim_u(I,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_x>0) diag_sfn_unlim_x(I,j,K) = Sfn_unlim_u(I,K) @@ -1004,10 +1045,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn) then do k=1,nz ; do I=is-1,ie ; if (G%OBCmaskCu(I,j)>0.) then - h_harm = max( h_neglect, & - 2. * h(i,j,k) * h(i+1,j,k) / ( ( h(i,j,k) + h(i+1,j,k) ) + h_neglect ) ) - c2_h_u(I,k) = CS%FGNV_scale * & - ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / (GV%H_to_Z*h_harm) + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i+1,j,k) / ( ( dz(i,j,k) + dz(i+1,j,k) ) + dz_neglect ) ) + c2_dz_u(I,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i+1,j) ) )**2 / dz_harm endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. @@ -1016,7 +1056,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=2,nz Sfn_unlim_u(I,K) = (1. + CS%FGNV_scale) * Sfn_unlim_u(I,K) enddo - call streamfn_solver(nz, c2_h_u(I,:), hN2_u(I,:), Sfn_unlim_u(I,:)) + call streamfn_solver(nz, c2_dz_u(I,:), dzN2_u(I,:), Sfn_unlim_u(I,:)) else do K=2,nz Sfn_unlim_u(I,K) = 0. @@ -1027,25 +1067,36 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=nz,2,-1 do I=is-1,ie + + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = (GV%RZ_to_H*Rho_avg) + else + Z_to_H = GV%Z_to_H + endif + if (k > nk_linear) then if (use_EOS) then if (uhtot(I,j) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i,j,k)) else ! (uhtot(I,j) > 0.0) - Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) * GV%H_to_Z + Sfn_safe = uhtot(I,j) * (1.0 - h_frac(i+1,j,k)) endif - ! The actual streamfunction at each interface. - Sfn_est = (Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) - else ! With .not.use_EOS, the layers are constant density. - Sfn_est = Sfn_unlim_u(I,K) + ! Determine the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_u(I,K) + slope2_Ratio_u(I,K)*Sfn_safe) / (1.0 + slope2_Ratio_u(I,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_u(I,K) endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_H = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i+1,j,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1076,6 +1127,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! else ! sfn_slope_x(I,j,K) = sfn_slope_x(I,j,K+1) * (1.0 - h_frac(i+1,j,k)) ! endif + endif uhtot(I,j) = uhtot(I,j) + uhD(I,j,k) @@ -1087,6 +1139,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! A second order centered estimate is used for the density transferred ! between water columns. + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + Work_u(I,j) = Work_u(I,j) + G_scale * & ( uhtot(I,j) * drdkDe_u(I,K) - & (uhD(I,j,k) * drdi_u(I,k)) * 0.25 * & @@ -1099,18 +1157,19 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! Calculate the meridional fluxes and gradients. - !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S, & - !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,I_slope_max2, & + !$OMP parallel do default(none) shared(nz,is,ie,js,je,find_work,use_EOS,G,GV,US,pres,T,S,dz, & + !$OMP nk_linear,IsdB,tv,h,h_neglect,e,dz_neglect,dz_neglect2, & !$OMP h_neglect2,int_slope_v,KH_v,vhtot,h_frac,h_avail_rsum, & - !$OMP vhD,h_avail,G_scale,Work_v,CS,slope_y,cg1,diag_sfn_y, & - !$OMP diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,Tsgs2, & - !$OMP present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & + !$OMP I_slope_max2,vhD,h_avail,Work_v,CS,slope_y,cg1,hn_2,& + !$OMP diag_sfn_y,diag_sfn_unlim_y,N2_floor,EOSdom_v,use_stanley,& + !$OMP Tsgs2, present_slope_y,G_rho0,Slope_y_PE,hN2_y_PE) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v,S_h,S_hr, & - !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,drho_dT_dT_hr, scrap,pres_h,T_h,T_hr, & + !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA,G_scale, & + !$OMP drho_dT_dT_h,drho_dT_dT_hr,scrap,pres_h,T_h,T_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz,pres_hr, & - !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,hN2_v, & - !$OMP Sfn_unlim_v,drdj_v,drdkDe_v,h_harm,c2_h_v, & + !$OMP dzg2A,dzg2B,dzaA,dzaB,dz_harm,Z_to_H, & + !$OMP drdy,mag_grad2,Slope,slope2_Ratio_v,dzN2_v,N2_unlim, & + !$OMP Sfn_unlim_v,Rho_avg,drdj_v,drdkDe_v,c2_dz_v, & !$OMP Sfn_safe,Sfn_est,Sfn_in_h,calc_derivatives) do J=js-1,je do K=nz,2,-1 @@ -1186,11 +1245,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV hg2R = h(i,j+1,k-1)*h(i,j+1,k) + h_neglect2 haL = 0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect haR = 0.5*(h(i,j+1,k-1) + h(i,j+1,k)) + h_neglect + if (GV%Boussinesq) then dzaL = haL * GV%H_to_Z ; dzaR = haR * GV%H_to_Z - else + elseif (GV%semi_Boussinesq) then dzaL = 0.5*(e(i,j,K-1) - e(i,j,K+1)) + dz_neglect dzaR = 0.5*(e(i,j+1,K-1) - e(i,j+1,K+1)) + dz_neglect + else + dzaL = 0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect + dzaR = 0.5*(dz(i,j+1,k-1) + dz(i,j+1,k)) + dz_neglect endif ! Use the harmonic mean thicknesses to weight the horizontal gradients. ! These unnormalized weights have been rearranged to minimize divisions. @@ -1205,9 +1268,22 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV haA = 0.5*(h(i,j,k-1) + h(i,j+1,k-1)) + h_neglect haB = 0.5*(h(i,j,k) + h(i,j+1,k)) + h_neglect - ! hN2_v is used with the FGNV streamfunction formulation - hN2_v(i,K) = (0.5 * GV%H_to_Z * ( hg2A / haA + hg2B / haB )) * & - max(drdz*G_rho0, N2_floor) + if (GV%Boussinesq) then + N2_unlim = drdz*G_rho0 + else + N2_unlim = (GV%g_Earth*GV%RZ_to_H) * & + ((wtL * drdkL + wtR * drdkR) / (haL*wtL + haR*wtR)) + endif + + dzg2A = dz(i,j,k-1)*dz(i,j+1,k-1) + dz_neglect2 + dzg2B = dz(i,j,k)*dz(i,j+1,k) + dz_neglect2 + dzaA = 0.5*(dz(i,j,k-1) + dz(i,j+1,k-1)) + dz_neglect + dzaB = 0.5*(dz(i,j,k) + dz(i,j+1,k)) + dz_neglect + + ! dzN2_v is used with the FGNV streamfunction formulation + dzN2_v(i,K) = (0.5*( dzg2A / dzaA + dzg2B / dzaB )) * max(N2_unlim, N2_floor) + if (find_work .and. CS%GM_src_alt) & + hN2_y_PE(i,J,k) = (0.5*( hg2A / haA + hg2B / haB )) * max(N2_unlim, N2_floor) endif if (present_slope_y) then Slope = slope_y(i,J,k) @@ -1239,10 +1315,8 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) Slope_y_PE(i,J,k) = MIN(Slope,CS%slope_max) - hN2_y_PE(i,J,k) = hN2_v(i,K) if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope - ! Estimate the streamfunction at each interface [Z L2 T-1 ~> m3 s-1]. Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) ! Avoid moving dense water upslope from below the level of @@ -1273,10 +1347,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope Sfn_unlim_v(i,K) = ((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) - hN2_v(i,K) = GV%g_prime(K) + dzN2_v(i,K) = GV%g_prime(K) endif ! if (use_EOS) else ! if (k > nk_linear) - hN2_v(i,K) = N2_floor * dz_neglect + dzN2_v(i,K) = N2_floor * dz_neglect Sfn_unlim_v(i,K) = 0. endif ! if (k > nk_linear) if (CS%id_sfn_unlim_y>0) diag_sfn_unlim_y(i,J,K) = Sfn_unlim_v(i,K) @@ -1285,10 +1359,9 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (CS%use_FGNV_streamfn) then do k=1,nz ; do i=is,ie ; if (G%OBCmaskCv(i,J)>0.) then - h_harm = max( h_neglect, & - 2. * h(i,j,k) * h(i,j+1,k) / ( ( h(i,j,k) + h(i,j+1,k) ) + h_neglect ) ) - c2_h_v(i,k) = CS%FGNV_scale * & - ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / (GV%H_to_Z*h_harm) + dz_harm = max( dz_neglect, & + 2. * dz(i,j,k) * dz(i,j+1,k) / ( ( dz(i,j,k) + dz(i,j+1,k) ) + dz_neglect ) ) + c2_dz_v(i,k) = CS%FGNV_scale * ( 0.5*( cg1(i,j) + cg1(i,j+1) ) )**2 / dz_harm endif ; enddo ; enddo ! Solve an elliptic equation for the streamfunction following Ferrari et al., 2010. @@ -1297,7 +1370,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=2,nz Sfn_unlim_v(i,K) = (1. + CS%FGNV_scale) * Sfn_unlim_v(i,K) enddo - call streamfn_solver(nz, c2_h_v(i,:), hN2_v(i,:), Sfn_unlim_v(i,:)) + call streamfn_solver(nz, c2_dz_v(i,:), dzN2_v(i,:), Sfn_unlim_v(i,:)) else do K=2,nz Sfn_unlim_v(i,K) = 0. @@ -1308,25 +1381,35 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do K=nz,2,-1 do i=is,ie + if (allocated(tv%SpV_avg) .and. (find_work .or. (k > nk_linear)) ) then + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + ! Use an average density to convert the volume streamfunction estimate into a mass streamfunction. + Z_to_H = (GV%RZ_to_H*Rho_avg) + else + Z_to_H = GV%Z_to_H + endif + if (k > nk_linear) then if (use_EOS) then if (vhtot(i,J) <= 0.0) then ! The transport that must balance the transport below is positive. - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) * GV%H_to_Z + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j,k)) else ! (vhtot(I,j) > 0.0) - Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) * GV%H_to_Z + Sfn_safe = vhtot(i,J) * (1.0 - h_frac(i,j+1,k)) endif - ! The actual streamfunction at each interface. - Sfn_est = (Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) - else ! With .not.use_EOS, the layers are constant density. - Sfn_est = Sfn_unlim_v(i,K) + ! Find the actual streamfunction at each interface. + Sfn_est = (Z_to_H*Sfn_unlim_v(i,K) + slope2_Ratio_v(i,K)*Sfn_safe) / (1.0 + slope2_Ratio_v(i,K)) + else ! When use_EOS is false, the layers are constant density. + Sfn_est = Z_to_H*Sfn_unlim_v(i,K) endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. - Sfn_in_H = min(max(Sfn_est * GV%Z_to_H, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) + Sfn_in_H = min(max(Sfn_est, -h_avail_rsum(i,j,K)), h_avail_rsum(i,j+1,K)) ! The actual transport is limited by the mass available in the two ! neighboring grid cells. @@ -1367,6 +1450,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! A second order centered estimate is used for the density transferred ! between water columns. + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth / Rho_avg + else + G_scale = GV%g_Earth * GV%H_to_Z + endif + Work_v(i,J) = Work_v(i,J) + G_scale * & ( vhtot(i,J) * drdkDe_v(i,K) - & (vhD(i,J,k) * drdj_v(i,k)) * 0.25 * & @@ -1383,7 +1472,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do J=js-1,je ; do i=is,ie ; vhD(i,J,1) = -vhtot(i,J) ; enddo ; enddo else EOSdom_u(1) = (is-1) - (G%IsdB-1) ; EOSdom_u(2) = ie - (G%IsdB-1) - !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB) + !$OMP parallel do default(shared) private(pres_u,T_u,S_u,drho_dT_u,drho_dS_u,drdiB,G_scale) do j=js,je if (use_EOS) then do I=is-1,ie @@ -1397,9 +1486,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do I=is-1,ie uhD(I,j,1) = -uhtot(I,j) + G_scale = GV%g_Earth * GV%H_to_Z if (use_EOS) then drdiB = drho_dT_u(I) * (T(i+1,j,1)-T(i,j,1)) + & drho_dS_u(I) * (S(i+1,j,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i+1,j,1)+hn_2) * tv%SpV_avg(i+1,j,1)) / & + ( (h(i,j,1) + h(i+1,j,1)) + 2.0*hn_2 ) ) + endif endif if (CS%use_GM_work_bug) then Work_u(I,j) = Work_u(I,j) + G_scale * & @@ -1414,7 +1509,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo EOSdom_v(:) = EOS_domain(G%HI) - !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB) + !$OMP parallel do default(shared) private(pres_v,T_v,S_v,drho_dT_v,drho_dS_v,drdjB,G_scale) do J=js-1,je if (use_EOS) then do i=is,ie @@ -1428,9 +1523,15 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV do i=is,ie vhD(i,J,1) = -vhtot(i,J) + G_scale = GV%g_Earth * GV%H_to_Z if (use_EOS) then drdjB = drho_dT_v(i) * (T(i,j+1,1)-T(i,j,1)) + & drho_dS_v(i) * (S(i,j+1,1)-S(i,j,1)) + if (allocated(tv%SpV_avg)) then + G_scale = GV%H_to_RZ * GV%g_Earth * & + ( ((h(i,j,1)+hn_2) * tv%SpV_avg(i,j,1) + (h(i,j+1,1)+hn_2) * tv%SpV_avg(i,j+1,1)) / & + ( (h(i,j,1) + h(i,j+1,1)) + 2.0*hn_2 ) ) + endif endif Work_v(i,J) = Work_v(i,J) - G_scale * & ( (vhD(i,J,1) * drdjB) * 0.25 * & @@ -1451,11 +1552,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then do j=js,je ; do i=is,ie ; do k=nz,1,-1 - PE_release_h = -0.25*(KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & + PE_release_h = -0.25 * (GV%H_to_RZ*US%L_to_Z**2) * & + (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) - MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + US%L_to_Z**2 * GV%Rho0 * PE_release_h + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h enddo ; enddo ; enddo endif ; endif @@ -1471,16 +1573,18 @@ end subroutine thickness_diffuse_full !> Tridiagonal solver for streamfunction at interfaces subroutine streamfn_solver(nk, c2_h, hN2, sfn) integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers [L2 Z-1 T-2 ~> m s-2] - real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces [L2 Z-1 T-2 ~> m s-2] - real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [Z L2 T-1 ~> m3 s-1] or arbitrary units + real, dimension(nk), intent(in) :: c2_h !< Wave speed squared over thickness in layers, rescaled to + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(in) :: hN2 !< Thickness times N2 at interfaces times rescaling factors + !! [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real, dimension(nk+1), intent(inout) :: sfn !< Streamfunction [H L2 T-1 ~> m3 s-1 or kg s-1] or arbitrary units !! On entry, equals diffusivity times slope. !! On exit, equals the streamfunction. ! Local variables real :: c1(nk) ! The dependence of the final streamfunction on the values below [nondim] real :: d1 ! The complement of c1(k) (i.e., 1 - c1(k)) [nondim] - real :: b_denom ! A term in the denominator of beta [L2 Z-1 T-2 ~> m s-2] - real :: beta ! The normalization for the pivot [Z T2 L-2 ~> s2 m-1] + real :: b_denom ! A term in the denominator of beta [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2] + real :: beta ! The normalization for the pivot [Z2 T2 H-1 L-2 ~> s2 m-1 or m2 s2 kg-1] integer :: k sfn(1) = 0. From 147ddf1d5707e79f3268c430d396f33e7d9956c3 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 25 Jul 2023 08:17:15 -0800 Subject: [PATCH 328/629] Brine plume (#401) * Salt data structures * First steps at brine plume: pass info from SIS2 * The brine plume parameterization, - including now passing the dimensional scaling tests. * Fix problem when running Tidal_bay case with gnu. * Avoiding visc_rem issues inside land mask. Tweaking the brine plume code. * Using the proper MLD in the brine plumes - it now works better on restart * Always including MLD in call to applyBoundary... - I could move it up and make it not optional. * Adding some OpenMP directives to brine plumes --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 13 ++- docs/zotero.bib | 9 ++ src/core/MOM_continuity_PPM.F90 | 8 +- src/core/MOM_forcing_type.F90 | 16 ++-- .../vertical/MOM_diabatic_aux.F90 | 82 +++++++++++++++++-- .../vertical/MOM_diabatic_driver.F90 | 8 +- .../vertical/MOM_set_viscosity.F90 | 34 ++++---- 7 files changed, 132 insertions(+), 38 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 251f37290d..a8398c3cc8 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -62,7 +62,7 @@ module MOM_surface_forcing_gfdl !! from MOM_domains) to indicate the staggering of !! the winds that are being provided in calls to !! update_ocean_model. - logical :: use_temperature !< If true, temp and saln used as state variables + logical :: use_temperature !< If true, temp and saln used as state variables. real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] @@ -175,6 +175,7 @@ module MOM_surface_forcing_gfdl real, pointer, dimension(:,:) :: t_flux =>NULL() !< sensible heat flux [W m-2] real, pointer, dimension(:,:) :: q_flux =>NULL() !< specific humidity flux [kg m-2 s-1] real, pointer, dimension(:,:) :: salt_flux =>NULL() !< salt flux [kg m-2 s-1] + real, pointer, dimension(:,:) :: excess_salt =>NULL() !< salt left behind by brine rejection [kg m-2 s-1] real, pointer, dimension(:,:) :: lw_flux =>NULL() !< long wave radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dir =>NULL() !< direct visible sw radiation [W m-2] real, pointer, dimension(:,:) :: sw_flux_vis_dif =>NULL() !< diffuse visible sw radiation [W m-2] @@ -304,6 +305,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call safe_alloc_ptr(fluxes%heat_added,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%salt_flux_added,isd,ied,jsd,jed) + if (associated(IOB%excess_salt)) call safe_alloc_ptr(fluxes%salt_left_behind,isd,ied,jsd,jed) + do j=js-2,je+2 ; do i=is-2,ie+2 fluxes%TKE_tidal(i,j) = CS%TKE_tidal(i,j) fluxes%ustar_tidal(i,j) = CS%ustar_tidal(i,j) @@ -576,6 +579,11 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call check_mask_val_consistency(IOB%salt_flux(i-i0,j-j0), G%mask2dT(i,j), i, j, 'salt_flux', G) enddo ; enddo endif + if (associated(IOB%excess_salt)) then + do j=js,je ; do i=is,ie + fluxes%salt_left_behind(i,j) = G%mask2dT(i,j)*(kg_m2_s_conversion*IOB%excess_salt(i-i0,j-j0)) + enddo ; enddo + endif !#CTRL# if (associated(CS%ctrl_forcing_CSp)) then !#CTRL# do j=js,je ; do i=is,ie @@ -1729,6 +1737,9 @@ subroutine ice_ocn_bnd_type_chksum(id, timestep, iobt) if (associated(iobt%mass_berg)) then chks = field_chksum( iobt%mass_berg ) ; if (root) write(outunit,100) 'iobt%mass_berg ', chks endif + if (associated(iobt%excess_salt)) then + chks = field_chksum( iobt%excess_salt ) ; if (root) write(outunit,100) 'iobt%excess_salt ', chks + endif 100 FORMAT(" CHECKSUM::",A20," = ",Z20) call coupler_type_write_chksums(iobt%fluxes, outunit, 'iobt%') diff --git a/docs/zotero.bib b/docs/zotero.bib index c0c7ee3bd9..5acaee968a 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2738,3 +2738,12 @@ @article{kraus1967 journal = {Tellus} } +@article{Nguyen2009, + doi = {10.1029/2008JC005121}, + year = {2009}, + journal = {JGR Oceans}, + volume = {114}, + author = {A. T. Nguyen and D. Menemenlis and R. Kwok}, + title = {Improved modeling of the Arctic halocline with a subgrid-scale brine rejection parameterization}, + pages = {C11014} +} diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 090d1ee0fb..73c6503242 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -378,9 +378,9 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are dx_E = ratio_max(G%areaT(i+1,j), G%dy_Cu(I,j), 1000.0*G%dxT(i+1,j)) else ; dx_W = G%dxT(i,j) ; dx_E = G%dxT(i+1,j) ; endif - if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)) & + if (du_max_CFL(I) * visc_rem(I,k) > dx_W*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & du_max_CFL(I) = (dx_W*CFL_dt - u(I,j,k)) / visc_rem(I,k) - if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)) & + if (du_min_CFL(I) * visc_rem(I,k) < -dx_E*CFL_dt - u(I,j,k)*G%mask2dCu(I,j)) & du_min_CFL(I) = -(dx_E*CFL_dt + u(I,j,k)) / visc_rem(I,k) enddo ; enddo endif @@ -1201,9 +1201,9 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac dy_S = ratio_max(G%areaT(i,j), G%dx_Cv(I,j), 1000.0*G%dyT(i,j)) dy_N = ratio_max(G%areaT(i,j+1), G%dx_Cv(I,j), 1000.0*G%dyT(i,j+1)) else ; dy_S = G%dyT(i,j) ; dy_N = G%dyT(i,j+1) ; endif - if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)) & + if (dv_max_CFL(i) * visc_rem(i,k) > dy_S*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & dv_max_CFL(i) = (dy_S*CFL_dt - v(i,J,k)) / visc_rem(i,k) - if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)) & + if (dv_min_CFL(i) * visc_rem(i,k) < -dy_N*CFL_dt - v(i,J,k)*G%mask2dCv(i,J)) & dv_min_CFL(i) = -(dy_N*CFL_dt + v(i,J,k)) / visc_rem(i,k) enddo ; enddo endif diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 4897771100..9623256b88 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -135,8 +135,10 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & salt_flux => NULL(), & !< net salt flux into the ocean [R Z T-1 ~> kgSalt m-2 s-1] salt_flux_in => NULL(), & !< salt flux provided to the ocean from coupler [R Z T-1 ~> kgSalt m-2 s-1] - salt_flux_added => NULL() !< additional salt flux from restoring or flux adjustment before adjustment + salt_flux_added => NULL(), & !< additional salt flux from restoring or flux adjustment before adjustment !! to net zero [R Z T-1 ~> kgSalt m-2 s-1] + salt_left_behind => NULL() !< salt left in ocean at the surface from brine rejection + !! [R Z T-1 ~> kgSalt m-2 s-1] ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) real, pointer, dimension(:,:) :: p_surf_full => NULL() @@ -746,15 +748,15 @@ subroutine extractFluxes1d(G, GV, US, fluxes, optics, nsw, j, dt, & endif ! Salt fluxes - Net_salt(i) = 0.0 - if (do_NSR) Net_salt_rate(i) = 0.0 + net_salt(i) = 0.0 + if (do_NSR) net_salt_rate(i) = 0.0 ! Convert salt_flux from kg (salt)/(m^2 * s) to ! Boussinesq: (ppt * m) ! non-Bouss: (g/m^2) if (associated(fluxes%salt_flux)) then - Net_salt(i) = (scale * dt * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H + net_salt(i) = (scale * dt * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H !Repeat above code for 'rate' term - if (do_NSR) Net_salt_rate(i) = (scale * 1. * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H + if (do_NSR) net_salt_rate(i) = (scale * 1. * (1000.0*US%ppt_to_S * fluxes%salt_flux(i,j))) * GV%RZ_to_H endif ! Diagnostics follow... @@ -1947,6 +1949,10 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_left_behind', & + diag%axesT1,Time,'Salt left in ocean at surface due to ice formation', & + units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) + handles%id_saltFluxGlobalAdj = register_scalar_field('ocean_model', & 'salt_flux_global_restoring_adjustment', Time, diag, & 'Adjustment needed to balance net global salt flux into ocean at surface', & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index ba265af5e2..3742e93229 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -67,7 +67,10 @@ module MOM_diabatic_aux !! e-folding depth of incoming shortwave radiation. 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. + logical :: chl_from_file !< If true, chl_a is read from a file. + logical :: do_brine_plume !< If true, insert salt flux below the surface according to + !! a parameterization by \cite Nguyen2009. + integer :: brine_plume_n !< The exponent in the brine plume parameterization. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -1034,7 +1037,7 @@ end subroutine diagnoseMLDbyEnergy subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & - SkinBuoyFlux ) + SkinBuoyFlux, MLD) type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1064,6 +1067,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. + real, pointer, dimension(:,:), optional :: MLD!< Mixed layer depth for brine plumes [Z ~> m] ! Local variables integer, parameter :: maxGroundings = 5 @@ -1102,7 +1106,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] - netMassInOut_rate! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] + mixing_depth ! Mixed layer depth [Z -> m] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] T2d, & ! A 2-d copy of the layer temperatures [C ~> degC] @@ -1132,6 +1137,11 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! and rejected brine are initially applied in vanishingly thin layers at the ! top of the layer before being mixed throughout the layer. logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. + real, dimension(SZI_(G)) :: dK ! Depth [Z ~> m]. + real, dimension(SZI_(G)) :: A_brine ! Constant [Z-(n+1) ~> m-(n+1)]. + real :: fraction_left_brine ! Sum for keeping track of the fraction of brine so far (in depth) + real :: plume_fraction ! Sum for keeping track of the fraction of brine so far (in depth) + real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, nb character(len=45) :: mesg @@ -1139,6 +1149,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke Idt = 1.0 / dt + plume_flux = 0.0 calculate_energetics = (present(cTKE) .and. present(dSV_dT) .and. present(dSV_dS)) calculate_buoyancy = present(SkinBuoyFlux) @@ -1158,6 +1169,17 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 endif + if (CS%do_brine_plume .and. .not. associated(MLD)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires a mixed-layer depth,\n"//& + "currently coming from the energetic PBL scheme.") + endif + if (CS%do_brine_plume .and. .not. associated(fluxes%salt_left_behind)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires DO_BRINE_PLUME\n"//& + "to be turned on in SIS2 as well as MOM6.") + endif + ! H_limit_fluxes is used by extractFluxes1d to scale down fluxes if the total ! depth of the ocean is vanishing. It does not (yet) handle a value of zero. ! To accommodate vanishing upper layers, we need to allow for an instantaneous @@ -1173,9 +1195,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP H_limit_fluxes,numberOfGroundings,iGround,jGround,& !$OMP nonPenSW,hGrounding,CS,Idt,aggregate_FW_forcing, & !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & - !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho, & + !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho,& !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2, & - !$OMP EnthalpyConst) & + !$OMP EnthalpyConst,MLD) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & !$OMP IforcingDepthScale, & @@ -1183,7 +1205,9 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & !$OMP drhodt,drhods,pen_sw_bnd_rate, & - !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst) & + !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & + !$OMP mixing_depth,A_brine,fraction_left_brine, & + !$OMP plume_flux,plume_fraction,dK) & !$OMP firstprivate(SurfPressure) do j=js,je ! Work in vertical slices for efficiency @@ -1300,6 +1324,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! ocean (and corresponding outward heat content), and ignoring penetrative SW. ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW + if (CS%do_brine_plume) then + do i=is,ie + mixing_depth(i) = max(MLD(i,j) - minimum_forcing_depth * GV%H_to_Z, minimum_forcing_depth * GV%H_to_Z) + mixing_depth(i) = min(mixing_depth(i), max(sum(h(i,j,:)), GV%angstrom_h) * GV%H_to_Z) + A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) + enddo + endif + do i=is,ie if (G%mask2dT(i,j) > 0.) then @@ -1372,8 +1404,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t enddo ! k=1,1 ! B/ Update mass, salt, temp from mass leaving ocean and other fluxes of heat and salt. + fraction_left_brine = 1.0 do k=1,nz - ! Place forcing into this layer if this layer has nontrivial thickness. ! For layers thin relative to 1/IforcingDepthScale, then distribute ! forcing into deeper layers. @@ -1388,6 +1420,33 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t fractionOfForcing = -evap_CFL_limit*h2d(i,k)/netMassOut(i) endif + if (CS%do_brine_plume .and. associated(fluxes%salt_left_behind)) then + if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then + ! Place forcing into this layer by depth for brine plume parameterization. + if (k == 1) then + dK(i) = 0.5 * h(i,j,k) * GV%H_to_Z ! Depth of center of layer K + plume_flux = - (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) * GV%RZ_to_H + plume_fraction = 1.0 + else + dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K + plume_flux = 0.0 + endif + if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then + plume_fraction = min(fraction_left_brine, A_brine(i) * dK(i) ** CS%brine_plume_n & + * h(i,j,k) * GV%H_to_Z) + else + IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) + ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. + plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) + endif + fraction_left_brine = fraction_left_brine - plume_fraction + plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) & + * GV%RZ_to_H + else + plume_flux = 0.0 + endif + endif + ! Change in state due to forcing dThickness = max( fractionOfForcing*netMassOut(i), -h2d(i,k) ) @@ -1432,7 +1491,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t endif Ithickness = 1.0/h2d(i,k) ! Inverse of new thickness T2d(i,k) = (hOld*T2d(i,k) + dTemp)*Ithickness - tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt)*Ithickness + tv%S(i,j,k) = (hOld*tv%S(i,j,k) + dSalt + plume_flux)*Ithickness elseif (h2d(i,k) < 0.0) then ! h2d==0 is a special limit that needs no extra handling call forcing_SinglePointPrint(fluxes,G,i,j,'applyBoundaryFluxesInOut (h<0)') write(0,*) 'applyBoundaryFluxesInOut(): lon,lat=',G%geoLonT(i,j),G%geoLatT(i,j) @@ -1702,6 +1761,13 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori CS%use_calving_heat_content = .false. endif + call get_param(param_file, mdl, "DO_BRINE_PLUME", CS%do_brine_plume, & + "If true, use a brine plume parameterization from "//& + "Nguyen et al., 2009.", default=.false.) + call get_param(param_file, mdl, "BRINE_PLUME_EXPONENT", CS%brine_plume_n, & + "If using the brine plume parameterization, set the integer exponent.", & + default=5, do_not_log=.not.CS%do_brine_plume) + if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & Time, "The volume flux added to stop the ocean from drying out and becoming negative in depth", & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 0c28c063ea..466ebbabca 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -815,7 +815,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) @@ -875,7 +875,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) endif ! endif for CS%use_energetic_PBL @@ -1360,7 +1360,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) @@ -1414,7 +1414,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) endif ! endif for CS%use_energetic_PBL diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 47d4dffef6..481aa5e9fc 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1027,22 +1027,24 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif endif - if (CS%body_force_drag .and. (h_bbl_drag(i) > 0.0)) then - ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. - h_sum = 0.0 - I_hwtot = 1.0 / h_bbl_drag(i) - do k=nz,1,-1 - h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot - if (m==1) then - visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr - else - visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr - endif - h_sum = h_sum + h_at_vel(i,k) - if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. - enddo - ! Do not enhance the near-bottom viscosity in this case. - Kv_bbl = CS%Kv_BBL_min + if (CS%body_force_drag) then + if (h_bbl_drag(i) > 0.0) then + ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. + h_sum = 0.0 + I_hwtot = 1.0 / h_bbl_drag(i) + do k=nz,1,-1 + h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (m==1) then + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr + else + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr + endif + h_sum = h_sum + h_at_vel(i,k) + if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. + enddo + ! Do not enhance the near-bottom viscosity in this case. + Kv_bbl = CS%Kv_BBL_min + endif endif kv_bbl = max(CS%Kv_BBL_min, kv_bbl) From d5ba107af21757390fb82d123ae1bf9c236ec0e4 Mon Sep 17 00:00:00 2001 From: Spencer Jones <41342785+cspencerjones@users.noreply.github.com> Date: Tue, 25 Jul 2023 13:14:17 -0500 Subject: [PATCH 329/629] +add h to drifters interface (#408) This commit brings the drifters interface up-to-date with the current version of the drifters package, which requires h (layer thickness) to calculate the vertical movement of particles. The interfaces in the code and in config_src/external are updated to pass this information to the drifters package. --- .../external/drifters/MOM_particles.F90 | 44 +++++++++++++------ src/core/MOM.F90 | 17 +++++-- 2 files changed, 44 insertions(+), 17 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index aad918e5a4..fa3840c6c2 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -11,19 +11,20 @@ module MOM_particles_mod implicit none ; private public particles, particles_run, particles_init, particles_save_restart, particles_end +public particles_to_k_space, particles_to_z_space contains !> Initializes particles container "parts" -subroutine particles_init(parts, Grid, Time, dt, u, v) +subroutine particles_init(parts, Grid, Time, dt, u, v, h) ! Arguments type(particles), pointer, intent(out) :: parts !< Container for all types and memory type(ocean_grid_type), target, intent(in) :: Grid !< Grid type from parent model type(time_type), intent(in) :: Time !< Time type from parent model - real, intent(in) :: dt !< particle timestep [s] - real, dimension(:,:,:), intent(in) :: u !< Zonal velocity field [m s-1] - real, dimension(:,:,:), intent(in) :: v !< Meridional velocity field [m s-1] - + real, intent(in) :: dt !< particle timestep in seconds [T ~> s] + real, dimension(:,:,:),intent(in) :: u !< Zonal velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: v !< Meridional velocity field [L T-1 ~> m s-1] + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] end subroutine particles_init !> The main driver the steps updates particles @@ -31,8 +32,8 @@ subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [m s-1] - real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [m s-1] + real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [L T-1 ~>m s-1] + real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [L T-1~> m s-1] real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered @@ -41,21 +42,38 @@ end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts, temp, salt) +subroutine particles_save_restart(parts, h, temp, salt) ! Arguments type(particles), pointer :: parts !< Container for all types and memory - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] end subroutine particles_save_restart !> Deallocate all memory and disassociated pointer -subroutine particles_end(parts, temp, salt) +subroutine particles_end(parts, h, temp, salt) ! Arguments type(particles), pointer :: parts !< Container for all types and memory - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity + real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] + real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] + real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] end subroutine particles_end +subroutine particles_to_k_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_k_space + + +subroutine particles_to_z_space(parts, h) + ! Arguments + type(particles), pointer :: parts !< Container for all types and memory + real, dimension(:,:,:),intent(in) :: h !< Thickness of layers [H ~> m or kg m-2] + +end subroutine particles_to_z_space + end module MOM_particles_mod diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index df3a308e85..d2df26524d 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -162,7 +162,7 @@ module MOM use MOM_offline_main, only : offline_advection_layer, offline_transport_end use MOM_ice_shelf, only : ice_shelf_CS, ice_shelf_query, initialize_ice_shelf use MOM_particles_mod, only : particles, particles_init, particles_run, particles_save_restart, particles_end - +use MOM_particles_mod, only : particles_to_k_space, particles_to_z_space implicit none ; private #include @@ -1541,6 +1541,10 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call preAle_tracer_diagnostics(CS%tracer_Reg, G, GV) + if (CS%use_particles) then + call particles_to_z_space(CS%particles, h) + endif + if (CS%debug) then call MOM_state_chksum("Pre-ALE ", u, v, h, CS%uh, CS%vh, G, GV, US, omit_corners=.true.) call hchksum(tv%T,"Pre-ALE T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) @@ -1588,6 +1592,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call cpu_clock_end(id_clock_ALE) endif ! endif for the block "if ( CS%use_ALE_algorithm )" + + if (CS%use_particles) then + call particles_to_k_space(CS%particles, h) + endif + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) call create_group_pass(pass_uv_T_S_h, u, v, G%Domain, halo=dynamics_stencil) if (associated(tv%T)) & @@ -3232,7 +3241,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) G => CS%G ; GV => CS%GV ; US => CS%US if (CS%use_particles) then - call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v) + call particles_init(CS%particles, G, CS%Time, CS%dt_therm, CS%u, CS%v, CS%h) endif ! Write initial conditions @@ -3935,7 +3944,7 @@ subroutine save_MOM6_internal_state(CS, dirs, time, stamp_time) ! Could call save_restart(CS%restart_CSp) here - if (CS%use_particles) call particles_save_restart(CS%particles) + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) end subroutine save_MOM6_internal_state @@ -3978,7 +3987,7 @@ subroutine MOM_end(CS) endif if (CS%use_particles) then - call particles_end(CS%particles) + call particles_end(CS%particles, CS%h) deallocate(CS%particles) endif From 249a0788d8a041cd7a4cef497aa1c5b2cf75931d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 11 Jul 2023 17:40:32 -0400 Subject: [PATCH 330/629] +*Revise units of arguments to vert_fill_TS Pass dt_kappa_smooth to calc_isoneutral_slopes and vert_fill_TS in units of [H Z ~> m2 or kg m-1] instead of [Z2 ~> m2] for consistency with the units of other diffusivities in the code and to reduce the depenency on the Boussinesq reference density in non-Boussinesq configurations. In addition to the changes to the units of these two arguments, there is a new unit_scale_type argument to vert_fill_TS and MOM_calc_varT and a new verticalGrid_type argument to MOM_stoch_eos_init. The units of 4 vertical diffusivities in the control structures in 4 different modules are also changed accordingly. All answers are bitwise identical in Boussinesq mode, but they can change for some non-Boussinesq configurations. There are new mandatory arguments to three publicly visible routines. --- src/core/MOM.F90 | 4 +-- src/core/MOM_isopycnal_slopes.F90 | 34 +++++++++++-------- src/core/MOM_stoch_eos.F90 | 12 ++++--- src/parameterizations/lateral/MOM_MEKE.F90 | 3 +- .../lateral/MOM_lateral_mixing_coeffs.F90 | 4 +-- .../lateral/MOM_thickness_diffuse.F90 | 10 +++--- .../vertical/MOM_internal_tide_input.F90 | 6 ++-- .../vertical/MOM_set_diffusivity.F90 | 12 +++---- 8 files changed, 46 insertions(+), 39 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d2df26524d..d7e2d74735 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1090,7 +1090,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & call cpu_clock_end(id_clock_stoch) call cpu_clock_begin(id_clock_varT) if (CS%use_stochastic_EOS) then - call MOM_calc_varT(G, GV, h, CS%tv, CS%stoch_eos_CS, dt) + call MOM_calc_varT(G, GV, US, h, CS%tv, CS%stoch_eos_CS, dt) if (associated(CS%tv%varT)) call pass_var(CS%tv%varT, G%Domain, clock=id_clock_pass, halo=1) endif call cpu_clock_end(id_clock_varT) @@ -3022,7 +3022,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & new_sim = is_new_run(restart_CSp) if (use_temperature) then - CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) + CS%use_stochastic_EOS = MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS%stoch_eos_CS, restart_CSp) else CS%use_stochastic_EOS = .false. endif diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 07dd19b0a6..73ae8a9816 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -36,8 +36,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface heights [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, intent(in) :: dt_kappa_smooth !< A smoothing vertical diffusivity - !! times a smoothing timescale [Z2 ~> m2]. + real, intent(in) :: dt_kappa_smooth !< A smoothing vertical + !! diffusivity times a smoothing + !! timescale [H Z ~> m2 or kg m-1] logical, intent(in) :: use_stanley !< turn on stanley param in slope real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] @@ -142,7 +143,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff local_open_u_BC = .false. local_open_v_BC = .false. @@ -195,9 +196,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan if (use_EOS) then if (present(halo)) then - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, halo+1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, halo+1) else - call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, 1) + call vert_fill_TS(h, tv%T, tv%S, dt_kappa_smooth, T, S, G, GV, US, 1) endif endif @@ -341,9 +342,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = slope * max(g%mask2dT(i,j),g%mask2dT(i+1,j)) endif slope_x(I,j,K) = slope - if (present(dzSxN)) dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N - * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 + if (present(dzSxN)) & + dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I enddo ; enddo ! end of j-loop @@ -477,9 +479,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan slope = slope * max(g%mask2dT(i,j),g%mask2dT(i,j+1)) endif slope_y(i,J,K) = slope - if (present(dzSyN)) dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N - * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 + if (present(dzSyN)) & + dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i enddo ; enddo ! end of j-loop @@ -488,14 +491,15 @@ end subroutine calc_isoneutral_slopes !> Returns tracer arrays (nominally T and S) with massless layers filled with !! sensible values, by diffusing vertically with a small but constant diffusivity. -subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, larger_h_denom) +subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, US, halo_here, larger_h_denom) 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] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: T_in !< Input temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S_in !< Input salinity [S ~> ppt] real, intent(in) :: kappa_dt !< A vertical diffusivity to use for smoothing - !! times a smoothing timescale [Z2 ~> m2]. + !! times a smoothing timescale [H Z ~> m2 or kg m-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: T_f !< Filled temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: S_f !< Filled salinity [S ~> ppt] integer, optional, intent(in) :: halo_here !< Number of halo points to work on, @@ -525,10 +529,10 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, halo_here, lar is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke h_neglect = GV%H_subroundoff - kap_dt_x2 = (2.0*kappa_dt)*GV%Z_to_H**2 + kap_dt_x2 = (2.0*kappa_dt) * (US%Z_to_m*GV%m_to_H) ! Usually the latter term is GV%Z_to_H. h0 = h_neglect if (present(larger_h_denom)) then - if (larger_h_denom) h0 = 1.0e-16*sqrt(kappa_dt)*GV%Z_to_H + if (larger_h_denom) h0 = 1.0e-16*sqrt(0.5*kap_dt_x2) endif if (kap_dt_x2 <= 0.0) then diff --git a/src/core/MOM_stoch_eos.F90 b/src/core/MOM_stoch_eos.F90 index deb878e99c..2bd742be6d 100644 --- a/src/core/MOM_stoch_eos.F90 +++ b/src/core/MOM_stoch_eos.F90 @@ -40,7 +40,7 @@ module MOM_stoch_eos real :: stanley_coeff !< Coefficient correlating the temperature gradient !! and SGS T variance [nondim]; if <0, turn off scheme in all codes real :: stanley_a !< a in exp(aX) in stochastic coefficient [nondim] - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !>@{ Diagnostic IDs integer :: id_stoch_eos = -1, id_stoch_phi = -1, id_tvar_sgs = -1 @@ -51,9 +51,10 @@ module MOM_stoch_eos contains !> Initializes MOM_stoch_eos module, returning a logical indicating whether this module will be used. -logical function MOM_stoch_eos_init(Time, G, US, param_file, diag, CS, restart_CS) +logical function MOM_stoch_eos_init(Time, G, GV, US, param_file, diag, CS, restart_CS) type(time_type), intent(in) :: Time !< Time for stochastic process type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse type(diag_ctrl), target, intent(inout) :: diag !< Structure used to control diagnostics @@ -80,7 +81,7 @@ logical function MOM_stoch_eos_init(Time, G, US, param_file, diag, CS, restart_C call get_param(param_file, "MOM_stoch_eos", "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s, & + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T, & do_not_log=(CS%stanley_coeff<0.0)) ! Don't run anything if STANLEY_COEFF < 0 @@ -193,9 +194,10 @@ subroutine post_stoch_EOS_diags(CS, tv, diag) end subroutine post_stoch_EOS_diags !> Computes a parameterization of the SGS temperature variance -subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) +subroutine MOM_calc_varT(G, GV, US, h, tv, CS, dt) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & intent(in) :: h !< Layer thickness [H ~> m] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure @@ -219,7 +221,7 @@ subroutine MOM_calc_varT(G, GV, h, tv, CS, dt) ! extreme gradients along layers which are vanished against topography. It is ! still a poor approximation in the interior when coordinates are strongly tilted. if (.not. associated(tv%varT)) allocate(tv%varT(G%isd:G%ied, G%jsd:G%jed, GV%ke), source=0.0) - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo_here=1, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo_here=1, larger_h_denom=.true.) do k=1,G%ke do j=G%jsc,G%jec diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 02338fab96..0ef261a956 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -1578,7 +1578,8 @@ subroutine ML_MEKE_calculate_features(G, GV, US, CS, Rd_dx_h, u, v, tv, h, dt, f h_v(i,J,k) = 0.5*(h(i,j,k)*G%mask2dT(i,j) + h(i,j+1,k)*G%mask2dT(i,j+1)) + GV%Angstrom_H enddo; enddo; enddo; call find_eta(h, tv, G, GV, US, e, halo_size=2) - call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7, .false., slope_x, slope_y) + ! Note the hard-coded dimenisional constant in the following line. + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*1.e-7*GV%m2_s_to_HZ_T, .false., slope_x, slope_y) call pass_vector(slope_x, slope_y, G%Domain) do j=js-1,je+1; do i=is-1,ie+1 slope_x_vert_avg(I,j) = vertical_average_interface(slope_x(i,j,:), h_u(i,j,:), GV%H_subroundoff) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 8f0aa02b12..e74e48055a 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -135,7 +135,7 @@ module MOM_lateral_mixing_coeffs !! F = 1 / (1 + (Res_coef_visc*Ld/dx)^Res_fn_power) real :: depth_scaled_khth_h0 !< The depth above which KHTH is linearly scaled away [Z ~> m] real :: depth_scaled_khth_exp !< The exponent used in the depth dependent scaling function for KHTH [nondim] - real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [Z2 T-1 ~> m2 s-1] + real :: kappa_smooth !< A diffusivity for smoothing T/S in vanished layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] integer :: Res_fn_power_khth !< The power of dx/Ld in the KhTh resolution function. Any !! positive integer power may be used, but even powers !! and especially 2 are coded to be more efficient. @@ -1265,7 +1265,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) endif if (CS%calculate_Eady_growth_rate) then diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 8617795e16..f24f790d06 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -44,9 +44,9 @@ module MOM_thickness_diffuse real :: Kh_eta_bg !< Background isopycnal height diffusivity [L2 T-1 ~> m2 s-1] real :: Kh_eta_vel !< Velocity scale that is multiplied by the grid spacing to give !! the isopycnal height diffusivity [L T-1 ~> m s-1] - real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim]. - real :: kappa_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + real :: slope_max !< Slopes steeper than slope_max are limited in some way [Z L-1 ~> nondim] + real :: kappa_smooth !< Vertical diffusivity used to interpolate more sensible values + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: thickness_diffuse !< If true, interfaces heights are diffused. logical :: use_FGNV_streamfn !< If true, use the streamfunction formulation of !! Ferrari et al., 2010, which effectively emphasizes @@ -798,7 +798,7 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV if (use_EOS) then halo = 1 ! Default halo to fill is 1 - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, halo, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_smooth*dt, T, S, G, GV, US, halo, larger_h_denom=.true.) endif ! Rescale the thicknesses, perhaps using the specific volume. @@ -2191,7 +2191,7 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m_to_Z**2*US%T_to_s) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KHTH_USE_FGNV_STREAMFUNCTION", CS%use_FGNV_streamfn, & "If true, use the streamfunction formulation of "//& "Ferrari et al., 2010, which effectively emphasizes "//& diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 7ec612f141..95e33929df 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -41,7 +41,7 @@ module MOM_int_tide_input real :: TKE_itide_max !< Maximum Internal tide conversion !! available to mix above the BBL [R Z3 T-3 ~> W m-2] real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values - !! of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable, dimension(:,:) :: TKE_itidal_coef !< The time-invariant field that enters the TKE_itidal input calculation [R Z3 T-2 ~> J m-2]. @@ -118,7 +118,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) ! Smooth the properties through massless layers. if (use_EOS) then - call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) @@ -352,7 +352,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) call get_param(param_file, mdl, "KD_SMOOTH", CS%kappa_fill, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "UTIDE", utide, & "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 9dc7b81c46..dfd264c92a 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -87,7 +87,7 @@ module MOM_set_diffusivity real :: Kd_add !< uniform diffusivity added everywhere without !! filtering or scaling [Z2 T-1 ~> m2 s-1]. real :: Kd_smooth !< Vertical diffusivity used to interpolate more - !! sensible values of T & S into thin layers [Z2 T-1 ~> m2 s-1]. + !! sensible values of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing logical :: limit_dissipation !< If enabled, dissipation is limited to be larger @@ -274,7 +274,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i integer :: i, j, k, is, ie, js, je, nz, isd, ied, jsd, jed - real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [Z2 ~> m2] + real :: kappa_dt_fill ! diffusivity times a timestep used to fill massless layers [H Z ~> m2 or kg m-1] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -289,7 +289,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%answer_date < 20190101) then ! These hard-coded dimensional parameters are being replaced. - kappa_dt_fill = US%m_to_Z**2 * 1.e-3 * 7200. + kappa_dt_fill = 1.e-3*GV%m2_s_to_HZ_T * 7200.*US%s_to_T else kappa_dt_fill = CS%Kd_smooth * dt endif @@ -340,7 +340,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, US, h, tv, T_f, S_f, fluxes%p_surf, & - (GV%Z_to_H**2)*kappa_dt_fill, halo=1) + GV%Z_to_H*kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_f, S_f, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) @@ -380,7 +380,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call hchksum(tv%S, "before vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) call hchksum(h, "before vert_fill_TS h",G%HI, scale=GV%H_to_m) endif - call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, larger_h_denom=.true.) + call vert_fill_TS(h, tv%T, tv%S, kappa_dt_fill, T_f, S_f, G, GV, US, larger_h_denom=.true.) if (CS%debug) then call hchksum(tv%T, "after vert_fill_TS tv%T", G%HI, scale=US%C_to_degC) call hchksum(tv%S, "after vert_fill_TS tv%S", G%HI, scale=US%S_to_ppt) @@ -2212,7 +2212,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_SMOOTH", CS%Kd_smooth, & "A diapycnal diffusivity that is used to interpolate "//& "more sensible values of T & S into thin layers.", & - units="m2 s-1", default=1.0e-6, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-6, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & From e465b1f6f913c97905b9d8aa9d9aec1110154a01 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 26 Jul 2023 04:55:19 -0400 Subject: [PATCH 331/629] Add comment justifying rescaling in vert_fill_TS Added a comment justifying the use of a fixed rescaling factor for the diffusivity used in vert_fill_TS. All answers and output are identical. --- src/core/MOM_isopycnal_slopes.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 73ae8a9816..29c547148d 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -529,6 +529,11 @@ subroutine vert_fill_TS(h, T_in, S_in, kappa_dt, T_f, S_f, G, GV, US, halo_here, is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo ; nz = GV%ke h_neglect = GV%H_subroundoff + ! The use of the fixed rescaling factor in the next line avoids an extra call to thickness_to_dz() + ! and the use of an extra 3-d array of vertical distnaces across layers (dz). This would be more + ! physically consistent, but it would also be more expensive, and given that this routine applies + ! a small (but arbitrary) amount of mixing to clean up the properties of nearly massless layers, + ! the added expense is hard to justify. kap_dt_x2 = (2.0*kappa_dt) * (US%Z_to_m*GV%m_to_H) ! Usually the latter term is GV%Z_to_H. h0 = h_neglect if (present(larger_h_denom)) then From 636d6109b9c14f7c5479dc5514913159d7cd97e3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 18 Jul 2023 05:27:01 -0400 Subject: [PATCH 332/629] +*Add and use find_ustar Added the new public interface find_ustar to extract the friction velocity from either a forcing type argument, or a mech_forcing_type argument, either directly or from tau_mag, and in non-Boussinesq mode by using the time-evolving surface specific volume. Find_ustar is an overloaded interface to find_ustar_fluxes or find_ustar_mech_forcing, which are the same but for the type of one of their arguments. For now, the subroutines bulkmixedlayer, mixedlayer_restrajt_OM4, mixedlayer_restrat_Bodner and mixedlayer_restrat_BML are calling find_ustar to avoid code duplication during the transition to work in fully non-Boussinesq mode, but it will eventually be used in about another half dozen other places. All Boussinesq answers are bitwise identical, but non-Boussinesq answers will change and become less dependent on the Boussinesq reference density, and there is a new publicly visible interface wrapping two subroutines. --- src/core/MOM_forcing_type.F90 | 141 +++++++++++++++++- .../lateral/MOM_mixed_layer_restrat.F90 | 36 +++-- .../vertical/MOM_bulk_mixed_layer.F90 | 19 ++- 3 files changed, 182 insertions(+), 14 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 9623256b88..a6d35903ee 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -29,7 +29,7 @@ module MOM_forcing_type public extractFluxes1d, extractFluxes2d, optics_type public MOM_forcing_chksum, MOM_mech_forcing_chksum -public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d +public calculateBuoyancyFlux1d, calculateBuoyancyFlux2d, find_ustar public forcing_accumulate, fluxes_accumulate public forcing_SinglePointPrint, mech_forcing_diags, forcing_diagnostics public register_forcing_type_diags, allocate_forcing_type, deallocate_forcing_type @@ -53,6 +53,12 @@ module MOM_forcing_type module procedure allocate_mech_forcing_from_ref end interface allocate_mech_forcing +!> Determine the friction velocity from a forcing type or a mechanical forcing type. +interface find_ustar + module procedure find_ustar_fluxes + module procedure find_ustar_mech_forcing +end interface find_ustar + ! 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 @@ -1077,6 +1083,139 @@ subroutine calculateBuoyancyFlux2d(G, GV, US, fluxes, optics, h, Temp, Salt, tv, end subroutine calculateBuoyancyFlux2d +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_fluxes(fluxes, tv, U_star, G, GV, US, halo, H_T_units) + 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(forcing), intent(in) :: fluxes !< Surface fluxes container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] or + !! [H T-1 ~> m s-1 or kg m-2 s-1], depending on H_T_units. + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) & + call MOM_error(FATAL, "find_ustar_fluxes requires that either ustar or tau_mag be associated.") + + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = fluxes%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * fluxes%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_fluxes called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(fluxes%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_fluxes + + +!> Determine the friction velocity from the contenxts of a forcing type, perhaps +!! using the evolving surface density. +subroutine find_ustar_mech_forcing(forces, tv, U_star, G, GV, US, halo, H_T_units) + 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(mech_forcing), intent(in) :: forces !< Surface forces container + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any + !! available thermodynamic fields. + real, dimension(SZI_(G),SZJ_(G)), & + intent(out) :: U_star !< The surface friction velocity [Z T-1 ~> m s-1] + integer, optional, intent(in) :: halo !< The extra halo size to fill in, 0 by default + logical, optional, intent(in) :: H_T_units !< If present and true, return U_star in units + !! of [H T-1 ~> m s-1 or kg m-2 s-1] + + ! Local variables + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] or in some semi-Boussinesq cases + ! the rescaled reference density [H2 Z-1 L-1 R-1 ~> m3 kg-1 or kg m-3] + logical :: Z_T_units ! If true, U_star is returned in units of [Z T-1 ~> m s-1], otherwise it is + ! returned in [H T-1 ~> m s-1 or kg m-2 s-1] + integer :: i, j, k, is, ie, js, je, hs + + hs = 0 ; if (present(halo)) hs = max(halo, 0) + is = G%isc - hs ; ie = G%iec + hs ; js = G%jsc - hs ; je = G%jec + hs + + Z_T_units = .true. ; if (present(H_T_units)) Z_T_units = .not.H_T_units + + if (.not.(associated(forces%ustar) .or. associated(forces%tau_mag))) & + call MOM_error(FATAL, "find_ustar_mech requires that either ustar or tau_mag be associated.") + + if (associated(forces%ustar) .and. (GV%Boussinesq .or. .not.associated(forces%tau_mag))) then + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = forces%ustar(i,j) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%Z_to_H * forces%ustar(i,j) + enddo ; enddo + endif + elseif (allocated(tv%SpV_avg)) then + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with invalid values of SpV_avg.") + if (tv%valid_SpV_halo < hs) call MOM_error(FATAL, & + "find_ustar_mech called in non-Boussinesq mode with insufficient valid values of SpV_avg.") + if (Z_T_units) then + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(US%L_to_Z*forces%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js,je ; do i=is,ie + U_star(i,j) = GV%RZ_to_H * sqrt(US%L_to_Z*forces%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + enddo ; enddo + endif + else + I_rho = US%L_to_Z * GV%Z_to_H * GV%RZ_to_H + if (Z_T_units) I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 + do j=js,je ; do i=is,ie + U_star(i,j) = sqrt(forces%tau_mag(i,j) * I_rho) + enddo ; enddo + endif + +end subroutine find_ustar_mech_forcing + + !> Write out chksums for thermodynamic fluxes. subroutine MOM_forcing_chksum(mesg, fluxes, G, US, haloshift) character(len=*), intent(in) :: mesg !< message diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 206773ecb0..5b7ec60dee 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -11,7 +11,7 @@ module MOM_mixed_layer_restrat 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_forcing_type, only : mech_forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_lateral_mixing_coeffs, only : VarMix_CS @@ -184,6 +184,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [Z T-1 ~> m s-1] MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] Rml_av_fast, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] @@ -254,6 +257,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "The resolution argument, Rd/dx, was not associated.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA pRef_MLD(:) = 0. @@ -408,7 +414,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, if (CS%debug) then call hchksum(h,'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(forces%ustar,'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & scale=US%m_to_Z*US%L_T_to_m_s**2) @@ -421,7 +427,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! U - Component !$OMP do do j=js,je ; do I=is-1,ie - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f @@ -508,7 +514,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! V- component !$OMP do do J=js-1,je ; do i=is,ie - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! If needed, res_scaling_fac = min( ds, L_d ) / l_f @@ -711,6 +717,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq + ! reference density or the time-evolving surface density in non-Boussinesq + ! mode [Z T-1 ~> m 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] @@ -762,12 +771,15 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d call pass_var(bflux, G%domain, halo=1) + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, 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(U_star_2d, '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', & @@ -793,7 +805,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 + u_star3 = ( US%Z_to_m * US%s_to_T * U_star_2d(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 @@ -965,7 +977,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! 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_ustar > 0) call post_data(CS%id_ustar, U_star_2d, 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) @@ -1053,6 +1065,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d, & ! The wind friction velocity, calculated using + ! the Boussinesq reference density or the time-evolving surface density + ! in non-Boussinesq mode [Z T-1 ~> m s-1] htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] @@ -1110,6 +1125,9 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) if (CS%use_Stanley_ML) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "The Stanley parameterization is not available with the BML.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + ! Fix this later for nkml >= 3. p0(:) = 0.0 @@ -1145,7 +1163,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do j=js,je ; do I=is-1,ie h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) @@ -1196,7 +1214,7 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) do J=js-1,je ; do i=is,ie h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z - u_star = max(CS%ustar_min, 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1))) + u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index 66e2dfa6b2..ceba8dad1a 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -9,7 +9,7 @@ module MOM_bulk_mixed_layer use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : extractFluxes1d, forcing +use MOM_forcing_type, only : extractFluxes1d, forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_opacity, only : absorbRemainingSW, optics_type, extract_optics_slice use MOM_unit_scaling, only : unit_scale_type @@ -235,6 +235,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ksort ! The sorted k-index that each original layer goes to. real, dimension(SZI_(G),SZJ_(G)) :: & h_miss ! The summed absolute mismatch [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + U_star_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)) :: & TKE, & ! The turbulent kinetic energy available for mixing over a ! time step [Z L2 T-2 ~> m3 s-2]. @@ -412,6 +415,9 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C max_BL_det(:) = -1 EOSdom(:) = EOS_domain(G%HI) + ! Extract the friction velocity from the forcing type. + call find_ustar(fluxes, tv, U_star_2d, G, GV, US) + !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & @@ -513,7 +519,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. - call find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & + call find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & j, ksort, G, GV, US, CS) @@ -1252,7 +1258,7 @@ end subroutine mixedlayer_convection !> This subroutine determines the TKE available at the depth of free !! convection to drive mechanical entrainment. -subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, & +subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1265,6 +1271,10 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, type(forcing), intent(in) :: fluxes !< A structure containing pointers to any !! possible forcing fields. Unused fields !! have NULL pointers. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: U_star_2d !< The wind friction velocity, calculated + !! using the Boussinesq reference density or + !! the time-evolving surface density in + !! non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source !! due to free convection [Z L2 T-2 ~> m3 s-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in @@ -1325,7 +1335,8 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, Conv_En, cTKE, dKE_FC, dKE_CA, if (CS%omega_frac >= 1.0) absf = 2.0*CS%omega do i=is,ie - U_star = fluxes%ustar(i,j) + U_star = U_star_2d(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & From 878fd1ef671456a804c598df606e4cf7c803c203 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 24 Jul 2023 14:14:29 -0400 Subject: [PATCH 333/629] +wave_speed arg mono_N2_depth in thickness units Changed the units of the optional mono_N2_depth argument to wave_speed, wave_speed_init and wave_speed_set_param in thickness units instead of height units. Accordingly, the units of one element each in the diagnostics_CS and wave_speed_CS and a local variable in VarMix_init are also changed to thickness units. The unit descriptions of some comments describing diagnostics were also amended to also describe the non-Boussinesq versions. Because this is essentially just changing when the unit conversion occurs, all answers are bitwise identical, but there are changes to the units of an optional argument in 3 publicly visible routines. --- src/diagnostics/MOM_diagnostics.F90 | 24 +++---- src/diagnostics/MOM_wave_speed.F90 | 64 ++++++++++--------- .../lateral/MOM_lateral_mixing_coeffs.F90 | 4 +- 3 files changed, 49 insertions(+), 43 deletions(-) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index cf8b042c14..157c7268bf 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -56,7 +56,7 @@ module MOM_diagnostics !! monotonic for the purposes of calculating the equivalent !! barotropic wave speed [nondim]. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. @@ -984,7 +984,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_dKEdt > 0) then - ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3]. + ! Calculate the time derivative of the layer KE [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * CS%du_dt(I,j,k) @@ -1006,7 +1006,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_PE_to_KE > 0) then - ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3]. + ! Calculate the potential energy to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%PFu(I,j,k) @@ -1025,7 +1025,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_BT > 0) then - ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3]. + ! Calculate the barotropic contribution to KE term [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%u_accel_bt(I,j,k) @@ -1044,7 +1044,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_Coradv > 0) then - ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from the combined Coriolis and advection terms [H L2 T-3 ~> m3 s-3 or W m-2]. ! The Coriolis source should be zero, but is not due to truncation errors. There should be ! near-cancellation of the global integral of this spurious Coriolis source. do k=1,nz @@ -1069,7 +1069,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_adv > 0) then - ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from along-layer advection [H L2 T-3 ~> m3 s-3 or W m-2]. ! NOTE: All terms in KE_adv are multiplied by -1, which can easily produce ! negative zeros and may signal a reproducibility issue over land. ! We resolve this by re-initializing and only evaluating over water points. @@ -1098,7 +1098,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_visc > 0) then - ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc(I,j,k) @@ -1117,7 +1117,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_visc_gl90 > 0) then - ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from GL90 vertical viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_visc_gl90(I,j,k) @@ -1136,7 +1136,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_stress > 0) then - ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from surface stress (included in KE_visc) [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_str(I,j,k) @@ -1155,7 +1155,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_horvisc > 0) then - ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from horizontal viscosity [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%diffu(I,j,k) @@ -1174,7 +1174,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS endif if (CS%id_KE_dia > 0) then - ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3]. + ! Calculate the KE source from diapycnal diffusion [H L2 T-3 ~> m3 s-3 or W m-2]. do k=1,nz do j=js,je ; do I=Isq,Ieq KE_u(I,j) = uh(I,j,k) * G%dxCu(I,j) * ADp%du_dt_dia(I,j,k) @@ -1594,7 +1594,7 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DIAG_EBT_MONO_N2_DEPTH", CS%mono_N2_depth, & "The depth below which N2 is limited as monotonic for the "// & "purposes of calculating the equivalent barotropic wave speed.", & - units='m', scale=US%m_to_Z, default=-1.) + units='m', scale=GV%m_to_H, default=-1.) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & units="nondim", default=0.001) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 5757e25cd1..c2b671f1c6 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -38,7 +38,7 @@ module MOM_wave_speed !! wave speed [nondim]. This parameter controls the default behavior of !! wave_speed() which can be overridden by optional arguments. real :: mono_N2_depth = -1. !< The depth below which N2 is limited as monotonic for the purposes of - !! calculating the equivalent barotropic wave speed [Z ~> m]. + !! calculating the equivalent barotropic wave speed [H ~> m or kg m-2]. !! If this parameter is negative, this limiting does not occur. !! This parameter controls the default behavior of wave_speed() which !! can be overridden by optional arguments. @@ -81,7 +81,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ !! for the purposes of calculating vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< A depth below which N2 is limited as !! monotonic for the purposes of calculating vertical - !! modal structure [Z ~> m]. + !! modal structure [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: modal_structure !< Normalized model structure [nondim] @@ -157,9 +157,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: sum_hc ! The sum of the layer thicknesses [Z ~> m] real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 Z-2 T-2 ~> s-2] + logical :: below_mono_N2_frac ! True if an interface is below the fractional depth where N2 should not increase. + logical :: below_mono_N2_depth ! True if an interface is below the absolute depth where N2 should not increase. logical :: l_use_ebt_mode, calc_modal_structure real :: l_mono_N2_column_fraction ! A local value of mono_N2_column_fraction [nondim] - real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [Z ~> m] + real :: l_mono_N2_depth ! A local value of mono_N2_column_depth [H ~> m or kg m-2] real :: mode_struct(SZK_(GV)) ! 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 :: ms_min, ms_max ! The minimum and maximum mode structure values returned from tdma6 [L2 T-2 ~> m2 s-2] @@ -214,18 +216,11 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. min_h_frac = tol_Hfrac / real(nz) -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h,G,GV,US,min_h_frac,use_EOS,tv,& -!$OMP calc_modal_structure,l_use_ebt_mode,modal_structure, & -!$OMP l_mono_N2_column_fraction,l_mono_N2_depth,CS, & -!$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale, & -!$OMP better_est,cg1_min2,tol_merge,tol_solve,c2_scale) & -!$OMP private(htot,hmin,kf,H_here,HxT_here,HxS_here,HxR_here, & -!$OMP Hf,Tf,Sf,Rf,pres,T_int,S_int,drho_dT,drho_dS, & -!$OMP drxh_sum,kc,Hc,Hc_H,Tc,Sc,I_Hnew,gprime,& -!$OMP Rc,speed2_tot,Igl,Igu,lam0,lam,lam_it,dlam, & -!$OMP mode_struct,sum_hc,N2min,gp,hw, & -!$OMP ms_min,ms_max,ms_sq,H_top,H_bot,I_Htot,merge, & -!$OMP det,ddet,det_it,ddet_it) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS, & + !$OMP CS,min_h_frac,calc_modal_structure,l_use_ebt_mode, & + !$OMP modal_structure,l_mono_N2_column_fraction,l_mono_N2_depth, & + !$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) 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 @@ -335,7 +330,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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 - endif + endif ! use_EOS ! Find gprime across each internal interface, taking care of convective instabilities by ! merging layers. If the estimated wave speed is too small, simply return zero. @@ -452,24 +447,34 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Igu(1) = 0. ! Neumann condition for pressure modes sum_hc = Hc(1) N2min = gprime(2)/Hc(1) + + below_mono_N2_frac = .false. + below_mono_N2_depth = .false. do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then - !### Change to: if ( ((htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) .or. & ) ) - if ( (((G%bathyT(i,j)+G%Z_ref) - sum_hc < l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) .or. & - ((l_mono_N2_depth >= 0.) .and. (sum_hc > l_mono_N2_depth))) .and. & - (gp > N2min*hw) ) then - ! Filters out regions where N2 increases with depth but only in a lower fraction + ! Determine whether N2 estimates should not be allowed to increase with depth. + if (l_mono_N2_column_fraction>0.) then + !### Change to: (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) + below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & + l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + endif + if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > GV%H_to_Z*l_mono_N2_depth) + + if ( (gp > N2min*hw) .and. (below_mono_N2_frac .or. below_mono_N2_depth) ) then + ! Filters out regions where N2 increases with depth, but only in a lower fraction ! of the water column or below a certain depth. gp = N2min * hw else N2min = gp / hw endif endif + Igu(k) = 1.0/(gp*Hc(k)) Igl(k-1) = 1.0/(gp*Hc(k-1)) sum_hc = sum_hc + Hc(k) + if (better_est) then ! Estimate that the ebt_mode is sqrt(2) times the speed of the flat bottom modes. speed2_tot = speed2_tot + 2.0 * gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) @@ -690,7 +695,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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]. - N2 ! The Brunt Vaissalla freqency squared [T-2 ~> s-2] + N2 ! The buoyancy 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] @@ -704,7 +709,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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] 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 :: I_Htot ! The inverse of the total filtered thicknesses [Z-1 ~> m-1] real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -797,6 +802,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! Simplifying the following could change answers at roundoff. Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) use_EOS = associated(tv%eqn_of_state) + if (CS%c1_thresh < 0.0) & call MOM_error(FATAL, "INTERNAL_WAVE_CG1_THRESH must be set to a non-negative "//& "value via wave_speed_init for wave_speeds to be used.") @@ -978,7 +984,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) kc = kc - 1 else ; exit ; endif enddo @@ -1006,7 +1012,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (merge) 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)) + 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. @@ -1019,7 +1025,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (merge) 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)) + Hc(kc-1) = Hc(kc) + Hc(kc-1) kc = kc - 1 else ; exit ; endif enddo @@ -1109,7 +1115,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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] + renorm = sqrt(htot(i)*a_int/w2avg) ! [T2 L-2] do K=1,kc+1 ; mode_struct(K) = renorm * mode_struct(K) ; enddo ! after renorm, mode_struct is again [nondim] @@ -1437,7 +1443,7 @@ subroutine wave_speed_init(CS, use_ebt_mode, mono_N2_column_fraction, mono_N2_de !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure [Z ~> m]. + !! vertical modal structure [H ~> m or kg m-2]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. @@ -1489,7 +1495,7 @@ subroutine wave_speed_set_param(CS, use_ebt_mode, mono_N2_column_fraction, mono_ !! calculating the vertical modal structure [nondim]. real, optional, intent(in) :: mono_N2_depth !< The depth below which N2 is limited !! as monotonic for the purposes of calculating the - !! vertical modal structure [Z ~> m]. + !! vertical modal structure [H ~> m or kg m-2]. logical, optional, intent(in) :: remap_answers_2018 !< If true, use the order of arithmetic and expressions !! that recover the remapping answers from 2018. Otherwise !! use more robust but mathematically equivalent expressions. diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index e74e48055a..df26f3f6a4 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1103,7 +1103,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) real :: oneOrTwo ! A variable that may be 1 or 2, depending on which form ! of the equatorial deformation radius us used [nondim] real :: N2_filter_depth ! A depth below which stratification is treated as monotonic when - ! calculating the first-mode wave speed [Z ~> m] + ! calculating the first-mode wave speed [H ~> m or kg m-2] real :: KhTr_passivity_coeff ! Coefficient setting the ratio between along-isopycnal tracer ! mixing and interface height mixing [nondim] real :: absurdly_small_freq ! A miniscule frequency that is used to avoid division by 0 [T-1 ~> s-1]. The @@ -1241,7 +1241,7 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The depth below which N2 is monotonized to avoid stratification "//& "artifacts from altering the equivalent barotropic mode structure. "//& "This monotonzization is disabled if this parameter is negative.", & - units="m", default=-1.0, scale=US%m_to_Z) + units="m", default=-1.0, scale=GV%m_to_H) allocate(CS%ebt_struct(isd:ied,jsd:jed,GV%ke), source=0.0) endif From be5602e1b91b0d4772b1619ac5be6df6020ab921 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 19 Jul 2023 09:23:57 -0400 Subject: [PATCH 334/629] *+Add BT_RHO_LINEARIZED to MOM_barotropic.F90 Added the new runtime parameter BT_RHO_LINEARIZED to specify the density that is used to convert total water column thicknesses into mass in non-Boussinesq mode with linearized options in the barotropic solver or when estimating the stable barotropic timestep without access to the full baroclinic model state. The default is set to RHO_0 and answers do not change by default. This new parameter is used in non-Boussinesq mode with some options in btcalc and find_face_areas, when LINEARIZED_BT_CORIOLIS = True or BT_NONLIN_STRESS = False, and in the unit conversion of the ice strength with dynamic pressure. Also cancelled out factors of GV%Z_to_H in MOM_barotropic.F90 to simplify the code and reduce the dependence on the value of GV%Rho_0 in non-Boussinesq mode. This involved changing the units of 4 variables in the barotropic_CS type, 3 internal variables in btstep and an internal variable in barotropic_init to use thickness units. The rescaled internal variable mass_to_Z was also replaced with the equivalent GV%RZ_to_H. There are also 4 new debugging messages. Also modified the units of the gtot_est argument to match those of pbce. There is a new element in barotropic_CS. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode. Additionally there is a new runtime parameter that will appear in some MOM_parameter_doc files. --- src/core/MOM_barotropic.F90 | 193 ++++++++++++++++++++++-------------- 1 file changed, 118 insertions(+), 75 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 40f759f4b8..adbbd3b4dd 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3,8 +3,9 @@ module MOM_barotropic ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum, uvchksum +use MOM_checksums, only : chksum0 use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl, enable_averaging, enable_averages use MOM_domains, only : min_across_PEs, clone_MOM_domain, deallocate_MOM_domain @@ -105,7 +106,7 @@ module MOM_barotropic real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: frhatv !< The fraction of the total column thickness interpolated to v grid points in each layer [nondim]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: IDatu - !< Inverse of the basin depth at u grid points [Z-1 ~> m-1]. + !< Inverse of the total thickness at u grid points [H-1 ~> m-1 or m2 kg-1]. real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: lin_drag_u !< A spatially varying linear drag coefficient acting on the zonal barotropic flow !! [H T-1 ~> m s-1 or kg m-2 s-1]. @@ -139,11 +140,11 @@ module MOM_barotropic !< This is a copy of G%IareaT with wide halos, but will !! still utilize the macro IareaT when referenced, [L-2 ~> m-2]. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMW_) :: & - D_u_Cor, & !< A simply averaged depth at u points [Z ~> m]. + D_u_Cor, & !< A simply averaged depth at u points recast as a thickness [H ~> m or kg m-2] dy_Cu, & !< A copy of G%dy_Cu with wide halos [L ~> m]. IdxCu !< A copy of G%IdxCu with wide halos [L-1 ~> m-1]. real ALLOCABLE_, dimension(NIMEMW_,NJMEMBW_) :: & - D_v_Cor, & !< A simply averaged depth at v points [Z ~> m]. + D_v_Cor, & !< A simply averaged depth at v points recast as a thickness [H ~> m or kg m-2] dx_Cv, & !< A copy of G%dx_Cv with wide halos [L ~> m]. IdyCv !< A copy of G%IdyCv with wide halos [L-1 ~> m-1]. real ALLOCABLE_, dimension(NIMEMBW_,NJMEMBW_) :: & @@ -170,6 +171,10 @@ module MOM_barotropic !! 0.0 gives a forward-backward scheme, while 1.0 !! give backward Euler. In practice, bebt should be !! of order 0.2 or greater. + real :: Rho_BT_lin !< A density that is used to convert total water column thicknesses + !! into mass in non-Boussinesq mode with linearized options in the + !! barotropic solver or when estimating the stable barotropic timestep + !! without access to the full baroclinic model state [R ~> kg m-3] logical :: split !< If true, use the split time stepping scheme. logical :: bound_BT_corr !< If true, the magnitude of the fake mass source !! in the barotropic equation that drives the two @@ -216,8 +221,8 @@ module MOM_barotropic logical :: dynamic_psurf !< If true, add a dynamic pressure due to a viscous !! ice shelf, for instance. - real :: Dmin_dyn_psurf !< The minimum depth to use in limiting the size - !! of the dynamic surface pressure for stability [Z ~> m]. + real :: Dmin_dyn_psurf !< The minimum total thickness to use in limiting the size + !! of the dynamic surface pressure for stability [H ~> m or kg m-2]. real :: ice_strength_length !< The length scale at which the damping rate !! due to the ice strength should be the same as if !! a Laplacian were applied [L ~> m]. @@ -511,8 +516,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! relative to eta_PF, with SAL effects included [H ~> m or kg m-2]. ! These are always allocated with symmetric memory and wide halos. - real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 Z-1 ~> s-1 m-1] - ! or [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] + real :: q(SZIBW_(CS),SZJBW_(CS)) ! A pseudo potential vorticity [T-1 H-1 ~> s-1 m-1 or m2 s-1 kg-1] real, dimension(SZIBW_(CS),SZJW_(CS)) :: & ubt, & ! The zonal barotropic velocity [L T-1 ~> m s-1]. bt_rem_u, & ! The fraction of the barotropic zonal velocity that remains @@ -545,7 +549,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Rayleigh_u, & ! A Rayleigh drag timescale operating at u-points [T-1 ~> s-1]. PFu_bt_sum, & ! The summed zonal barotropic pressure gradient force [L T-2 ~> m s-2]. Coru_bt_sum, & ! The summed zonal barotropic Coriolis acceleration [L T-2 ~> m s-2]. - DCor_u, & ! An averaged depth or total thickness at u points [Z ~> m] or [H ~> m or kg m-2]. + DCor_u, & ! An averaged total thickness at u points [H ~> m or kg m-2]. Datu ! Basin depth at u-velocity grid points times the y-grid ! spacing [H L ~> m2 or kg m-1]. real, dimension(SZIW_(CS),SZJBW_(CS)) :: & @@ -578,7 +582,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! [L T-2 ~> m s-2]. Corv_bt_sum, & ! The summed meridional barotropic Coriolis acceleration, ! [L T-2 ~> m s-2]. - DCor_v, & ! An averaged depth or total thickness at v points [Z ~> m] or [H ~> m or kg m-2]. + DCor_v, & ! An averaged total thickness at v points [H ~> m or kg m-2]. Datv ! Basin depth at v-velocity grid points times the x-grid ! spacing [H L ~> m2 or kg m-1]. real, target, dimension(SZIW_(CS),SZJW_(CS)) :: & @@ -626,7 +630,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, vhbt_prev, vhbt_sum_prev, & ! Previous transports stored for OBCs [L2 H T-1 ~> m3 s-1] vbt_int_prev, & ! Previous value of time-integrated velocity stored for OBCs [L ~> m] vhbt_int_prev ! Previous value of time-integrated transport stored for OBCs [L2 H ~> m3] - real :: mass_to_Z ! The inverse of the the mean density (Rho0) [R-1 ~> m3 kg-1] real :: visc_rem ! A work variable that may equal visc_rem_[uv] [nondim] real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: dtbt ! The barotropic time step [T ~> s]. @@ -664,6 +667,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, real :: dyn_coef_max ! The maximum stable value of dyn_coef_eta ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. real :: ice_strength = 0.0 ! The effective strength of the ice [L2 Z-1 T-2 ~> m s-2]. + real :: H_to_Z ! A local unit conversion factor used with rigid ice [Z H-1 ~> nondim or m3 kg-1] real :: Idt_max2 ! The squared inverse of the local maximum stable ! barotropic time step [T-2 ~> s-2]. real :: H_min_dyn ! The minimum depth to use in limiting the size of the @@ -778,7 +782,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, jsvf = js - (num_cycles-1)*stencil ; jevf = je + (num_cycles-1)*stencil nstep = CEILING(dt/CS%dtbt - 0.0001) - if (is_root_PE() .and. (nstep /= CS%nstep_last)) then + if (is_root_PE() .and. ((nstep /= CS%nstep_last) .or. CS%debug)) then write(mesg,'("btstep is using a dynamic barotropic timestep of ", ES12.6, & & " seconds, max ", ES12.6, ".")') (US%T_to_s*dt/nstep), US%T_to_s*CS%dtbt_max call MOM_mesg(mesg, 3) @@ -791,7 +795,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Idtbt = 1.0 / dtbt bebt = CS%bebt be_proj = CS%bebt - mass_to_Z = 1.0 / GV%Rho0 !--- setup the weight when computing vbt_trans and ubt_trans if (project_velocity) then @@ -1275,17 +1278,17 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dy_Cu(I,j) <= 0.0) then CS%IDatu(I,j) = 0.0 elseif (integral_BT_cont) then - CS%IDatu(I,j) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j)*dt, BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatu(I,j) = GV%Z_to_H * CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & + CS%IDatu(I,j) = CS%dy_Cu(I,j) / (max(find_duhbt_du(ubt(I,j), BTCL_u(I,j)), & CS%dy_Cu(I,j)*Htot_avg) ) else - CS%IDatu(I,j) = GV%Z_to_H / Htot_avg + CS%IDatu(I,j) = 1.0 / Htot_avg endif endif - BT_force_u(I,j) = forces%taux(I,j) * mass_to_Z * CS%IDatu(I,j)*visc_rem_u(I,j,1) + BT_force_u(I,j) = forces%taux(I,j) * GV%RZ_to_H * CS%IDatu(I,j)*visc_rem_u(I,j,1) else BT_force_u(I,j) = 0.0 endif ; enddo ; enddo @@ -1301,28 +1304,28 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (Htot_avg*CS%dx_Cv(i,J) <= 0.0) then CS%IDatv(i,J) = 0.0 elseif (integral_BT_cont) then - CS%IDatv(i,J) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J)*dt, BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) elseif (use_BT_cont) then ! Reconsider the max and whether there should be some scaling. - CS%IDatv(i,J) = GV%Z_to_H * CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & + CS%IDatv(i,J) = CS%dx_Cv(i,J) / (max(find_dvhbt_dv(vbt(i,J), BTCL_v(i,J)), & CS%dx_Cv(i,J)*Htot_avg) ) else - CS%IDatv(i,J) = GV%Z_to_H / Htot_avg + CS%IDatv(i,J) = 1.0 / Htot_avg endif endif - BT_force_v(i,J) = forces%tauy(i,J) * mass_to_Z * CS%IDatv(i,J)*visc_rem_v(i,J,1) + BT_force_v(i,J) = forces%tauy(i,J) * GV%RZ_to_H * CS%IDatv(i,J)*visc_rem_v(i,J,1) else BT_force_v(i,J) = 0.0 endif ; enddo ; enddo if (associated(taux_bot) .and. associated(tauy_bot)) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then - BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * mass_to_Z * CS%IDatu(I,j) + BT_force_u(I,j) = BT_force_u(I,j) - taux_bot(I,j) * GV%RZ_to_H * CS%IDatu(I,j) endif ; enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then - BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * mass_to_Z * CS%IDatv(i,J) + BT_force_v(i,J) = BT_force_v(i,J) - tauy_bot(i,J) * GV%RZ_to_H * CS%IDatv(i,J) endif ; enddo ; enddo endif @@ -1595,10 +1598,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (CS%dynamic_psurf) then ice_is_rigid = (associated(forces%rigidity_ice_u) .and. & associated(forces%rigidity_ice_v)) - H_min_dyn = GV%Z_to_H * CS%Dmin_dyn_psurf + H_min_dyn = CS%Dmin_dyn_psurf if (ice_is_rigid .and. use_BT_cont) & call BT_cont_to_face_areas(BT_cont, Datu, Datv, G, US, MS, halo=0) if (ice_is_rigid) then + if (GV%Boussinesq) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + endif !$OMP parallel do default(shared) private(Idt_max2,H_eff_dx2,dyn_coef_max,ice_strength) do j=js,je ; do i=is,ie ! First determine the maximum stable value for dyn_coef_eta. @@ -1626,7 +1634,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, (CS%ice_strength_length**2 * dtbt) ! Units of dyn_coef: [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1] - dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * GV%H_to_Z) + dyn_coef_eta(i,j) = min(dyn_coef_max, ice_strength * H_to_Z) enddo ; enddo ; endif endif @@ -1681,9 +1689,11 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT frhat[uv]", CS%frhatu, CS%frhatv, G%HI, haloshift=0, & symmetric=.true., omit_corners=.true., scalar_pair=.true.) + call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, haloshift=0, & + symmetric=.true., omit_corners=.true., scalar_pair=.true.) call uvchksum("BT bc_accel_[uv]", bc_accel_u, bc_accel_v, G%HI, haloshift=0, scale=US%L_T2_to_m_s2) call uvchksum("BT IDat[uv]", CS%IDatu, CS%IDatv, G%HI, haloshift=0, & - scale=US%m_to_Z, scalar_pair=.true.) + scale=GV%m_to_H, scalar_pair=.true.) call uvchksum("BT visc_rem_[uv]", visc_rem_u, visc_rem_v, G%HI, & haloshift=1, scalar_pair=.true.) endif @@ -2772,7 +2782,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) !! the effective open face areas as a !! function of barotropic flow. real, optional, intent(in) :: gtot_est !< An estimate of the total gravitational - !! acceleration [L2 Z-1 T-2 ~> m s-2]. + !! acceleration [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. real, optional, intent(in) :: SSH_add !< An additional contribution to SSH to !! provide a margin of error when !! calculating the external wave speed [Z ~> m]. @@ -2817,6 +2827,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke MS%isdw = G%isd ; MS%iedw = G%ied ; MS%jsdw = G%jsd ; MS%jedw = G%jed + if (.not.(present(pbce) .or. present(gtot_est))) call MOM_error(FATAL, & "set_dtbt: Either pbce or gtot_est must be present.") @@ -2853,8 +2864,8 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) enddo ; enddo ; enddo else do j=js,je ; do i=is,ie - gtot_E(i,j) = gtot_est * GV%H_to_Z ; gtot_W(i,j) = gtot_est * GV%H_to_Z - gtot_N(i,j) = gtot_est * GV%H_to_Z ; gtot_S(i,j) = gtot_est * GV%H_to_Z + gtot_E(i,j) = gtot_est ; gtot_W(i,j) = gtot_est + gtot_N(i,j) = gtot_est ; gtot_S(i,j) = gtot_est enddo ; enddo endif @@ -2876,6 +2887,12 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) CS%dtbt = CS%dtbt_fraction * dtbt_max CS%dtbt_max = dtbt_max + + if (CS%debug) then + call chksum0(CS%dtbt, "End set_dtbt dtbt", scale=US%T_to_s) + call chksum0(CS%dtbt_max, "End set_dtbt dtbt_max", scale=US%T_to_s) + endif + end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. @@ -3342,6 +3359,7 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! around a u-point (positive upward) [H ~> m or kg m-2] real :: D_shallow_v(SZIB_(G))! The height of the shallower of the adjacent bathymetric depths ! around a v-point (positive upward) [H ~> m or kg m-2] + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] real :: htot ! The sum of the layer thicknesses [H ~> m or kg m-2]. real :: Ihtot ! The inverse of htot [H-1 ~> m-1 or m2 kg-1]. @@ -3383,9 +3401,9 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) ! This estimates the fractional thickness of each layer at the velocity ! points, using a harmonic mean estimate. -!$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & -!$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,h_u,CS,h_neglect,h,use_default,G,GV) & + !$OMP private(hatutot,Ihatutot,e_u,D_shallow_u,h_arith,h_harm,wt_arith,Z_to_H) do j=js,je if (present(h_u)) then do I=is-1,ie ; hatutot(I) = h_u(I,j,1) ; enddo @@ -3407,9 +3425,10 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) hatutot(I) = hatutot(I) + CS%frhatu(I,j,k) enddo ; enddo elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do I=is-1,ie - e_u(I,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) - D_shallow_u(I) = -GV%Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) + e_u(I,nz+1) = -0.5 * Z_to_H * (G%bathyT(i+1,j) + G%bathyT(i,j)) + D_shallow_u(I) = -Z_to_H * min(G%bathyT(i+1,j), G%bathyT(i,j)) hatutot(I) = 0.0 enddo do k=nz,1,-1 ; do I=is-1,ie @@ -3447,8 +3466,8 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) endif enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & -!$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith) + !$OMP parallel do default(none) shared(is,ie,js,je,nz,CS,G,GV,h_v,h_neglect,h,use_default) & + !$OMP private(hatvtot,Ihatvtot,e_v,D_shallow_v,h_arith,h_harm,wt_arith,Z_to_H) do J=js-1,je if (present(h_v)) then do i=is,ie ; hatvtot(i) = h_v(i,J,1) ; enddo @@ -3470,9 +3489,10 @@ subroutine btcalc(h, G, GV, CS, h_u, h_v, may_use_default, OBC) hatvtot(i) = hatvtot(i) + CS%frhatv(i,J,k) enddo ; enddo elseif (CS%hvel_scheme == HYBRID .or. use_default) then + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do i=is,ie - e_v(i,nz+1) = -0.5 * GV%Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) - D_shallow_v(I) = -GV%Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) + e_v(i,nz+1) = -0.5 * Z_to_H * (G%bathyT(i,j+1) + G%bathyT(i,j)) + D_shallow_v(I) = -Z_to_H * min(G%bathyT(i,j+1), G%bathyT(i,j)) hatvtot(I) = 0.0 enddo do k=nz,1,-1 ; do i=is,ie @@ -4140,23 +4160,23 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) ! Local variables real :: H1, H2 ! Temporary total thicknesses [H ~> m or kg m-2]. + real :: Z_to_H ! A local conversion factor [H Z-1 ~> nondim or kg m-3] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec hs = max(halo,0) -!$OMP parallel default(none) shared(is,ie,js,je,hs,eta,GV,G,CS,Datu,Datv,add_max) & -!$OMP private(H1,H2) + !$OMP parallel default(shared) private(H1,H2,Z_to_H) if (present(eta)) then ! The use of harmonic mean thicknesses ensure positive definiteness. if (GV%Boussinesq) then -!$OMP do + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) Datu(I,j) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (H1 + H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs H1 = CS%bathyT(i,j)*GV%Z_to_H + eta(i,j) ; H2 = CS%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) Datv(i,J) = 0.0 ; if ((H1 > 0.0) .and. (H2 > 0.0)) & @@ -4164,14 +4184,14 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) ! Datv(i,J) = CS%dy_v(i,J) * 0.5 * (H1 + H2) enddo ; enddo else -!$OMP do + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs Datu(I,j) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i+1,j) > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * eta(i,j) * eta(i+1,j)) / & (eta(i,j) + eta(i+1,j)) ! Datu(I,j) = CS%dy_Cu(I,j) * 0.5 * (eta(i,j) + eta(i+1,j)) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs Datv(i,J) = 0.0 ; if ((eta(i,j) > 0.0) .and. (eta(i,j+1) > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * eta(i,j) * eta(i,j+1)) / & @@ -4180,33 +4200,37 @@ subroutine find_face_areas(Datu, Datv, G, GV, US, CS, MS, halo, eta, add_max) enddo ; enddo endif elseif (present(add_max)) then -!$OMP do + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - Datu(I,j) = CS%dy_Cu(I,j) * GV%Z_to_H * & + Datu(I,j) = CS%dy_Cu(I,j) * Z_to_H * & max(max(CS%bathyT(i+1,j), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - Datv(i,J) = CS%dx_Cv(i,J) * GV%Z_to_H * & + Datv(i,J) = CS%dx_Cv(i,J) * Z_to_H * & max(max(CS%bathyT(i,j+1), CS%bathyT(i,j)) + (G%Z_ref + add_max), 0.0) enddo ; enddo else -!$OMP do + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + + !$OMP do do j=js-hs,je+hs ; do I=is-1-hs,ie+hs - H1 = (CS%bathyT(i,j) + G%Z_ref) * GV%Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * GV%Z_to_H + H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i+1,j) + G%Z_ref) * Z_to_H Datu(I,j) = 0.0 if ((H1 > 0.0) .and. (H2 > 0.0)) & Datu(I,j) = CS%dy_Cu(I,j) * (2.0 * H1 * H2) / (H1 + H2) enddo ; enddo -!$OMP do + !$OMP do do J=js-1-hs,je+hs ; do i=is-hs,ie+hs - H1 = (CS%bathyT(i,j) + G%Z_ref) * GV%Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * GV%Z_to_H + H1 = (CS%bathyT(i,j) + G%Z_ref) * Z_to_H ; H2 = (CS%bathyT(i,j+1) + G%Z_ref) * Z_to_H Datv(i,J) = 0.0 if ((H1 > 0.0) .and. (H2 > 0.0)) & Datv(i,J) = CS%dx_Cv(i,J) * (2.0 * H1 * H2) / (H1 + H2) enddo ; enddo endif -!$OMP end parallel + !$OMP end parallel end subroutine find_face_areas @@ -4306,13 +4330,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, character(len=40) :: mdl = "MOM_barotropic" ! This module's name. real :: Datu(SZIBS_(G),SZJ_(G)) ! Zonal open face area [H L ~> m2 or kg m-1]. real :: Datv(SZI_(G),SZJBS_(G)) ! Meridional open face area [H L ~> m2 or kg m-1]. - real :: gtot_estimate ! Summed GV%g_prime [L2 Z-1 T-2 ~> m s-2], to give an upper-bound estimate for pbce. + real :: gtot_estimate ! Summed GV%g_prime [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2], to give an + ! upper-bound estimate for pbce. real :: SSH_extra ! An estimate of how much higher SSH might get, for use ! in calculating the safe external wave speed [Z ~> m]. real :: dtbt_input ! The input value of DTBT, [nondim] if negative or [s] if positive. real :: dtbt_tmp ! A temporary copy of CS%dtbt read from a restart file [T ~> s] real :: wave_drag_scale ! A scaling factor for the barotropic linear wave drag - ! piston velocities. + ! piston velocities [nondim]. character(len=200) :: inputdir ! The directory in which to find input files. character(len=200) :: wave_drag_file ! The file from which to read the wave ! drag piston velocity. @@ -4320,11 +4345,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! name in wave_drag_file. 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 :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] + real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1] real :: det_de ! The partial derivative due to self-attraction and loading of the reference ! geopotential with the sea surface height when tides are enabled [nondim]. ! This is typically ~0.09 or less. real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points - ! that acts on the barotropic flow [Z T-1 ~> m s-1]. + ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. type(memory_size_type) :: MS type(group_pass_type) :: pass_static_data, pass_q_D_Cor @@ -4444,6 +4471,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "If true, use the full depth of the ocean at the start of the barotropic "//& "step when calculating the surface stress contribution to the barotropic "//& "acclerations. Otherwise use the depth based on bathyT.", default=.false.) + call get_param(param_file, mdl, "BT_RHO_LINEARIZED", CS%Rho_BT_lin, & + "A density that is used to convert total water column thicknesses into mass "//& + "in non-Boussinesq mode with linearized options in the barotropic solver or "//& + "when estimating the stable barotropic timestep without access to the full "//& + "baroclinic model state.", & + 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, "DYNAMIC_SURFACE_PRESSURE", CS%dynamic_psurf, & "If true, add a dynamic pressure due to a viscous ice "//& @@ -4457,7 +4491,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "The minimum depth to use in limiting the size of the "//& "dynamic surface pressure for stability, if "//& "DYNAMIC_SURFACE_PRESSURE is true..", & - units="m", default=1.0e-6, scale=US%m_to_Z, do_not_log=.not.CS%dynamic_psurf) + units="m", default=1.0e-6, scale=GV%m_to_H, do_not_log=.not.CS%dynamic_psurf) call get_param(param_file, mdl, "CONST_DYN_PSURF", CS%const_dyn_psurf, & "The constant that scales the dynamic surface pressure, "//& "if DYNAMIC_SURFACE_PRESSURE is true. Stable values "//& @@ -4471,20 +4505,23 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", answers_2018, & "If true, use expressions for the barotropic solver that recover the answers "//& "from the end of 2018. Otherwise, use more efficient or general expressions.", & - default=default_2018_answers) + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& "while higher values uuse more efficient or general expressions. "//& "If both BAROTROPIC_2018_ANSWERS and BAROTROPIC_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) @@ -4729,21 +4766,23 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ALLOC_(CS%D_v_Cor(CS%isdw:CS%iedw,CS%jsdw-1:CS%jedw)) CS%q_D(:,:) = 0.0 ; CS%D_u_Cor(:,:) = 0.0 ; CS%D_v_Cor(:,:) = 0.0 + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin + Mean_SL = G%Z_ref do j=js,je ; do I=is-1,ie - CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) + CS%D_u_Cor(I,j) = 0.5 * (max(Mean_SL+G%bathyT(i+1,j),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H enddo ; enddo do J=js-1,je ; do i=is,ie - CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) + CS%D_v_Cor(i,J) = 0.5 * (max(Mean_SL+G%bathyT(i,j+1),0.0) + max(Mean_SL+G%bathyT(i,j),0.0)) * Z_to_H enddo ; enddo do J=js-1,je ; do I=is-1,ie if (G%mask2dT(i,j)+G%mask2dT(i,j+1)+G%mask2dT(i+1,j)+G%mask2dT(i+1,j+1)>0.) then CS%q_D(I,J) = 0.25 * (CS%BT_Coriolis_scale * G%CoriolisBu(I,J)) * & ((G%areaT(i,j) + G%areaT(i+1,j+1)) + (G%areaT(i+1,j) + G%areaT(i,j+1))) / & - (max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & - G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & - (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & - G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_to_Z*GV%H_subroundoff) ) + (Z_to_H * max(((G%areaT(i,j) * max(Mean_SL+G%bathyT(i,j),0.0) + & + G%areaT(i+1,j+1) * max(Mean_SL+G%bathyT(i+1,j+1),0.0)) + & + (G%areaT(i+1,j) * max(Mean_SL+G%bathyT(i+1,j),0.0) + & + G%areaT(i,j+1) * max(Mean_SL+G%bathyT(i,j+1),0.0))), GV%H_subroundoff) ) else ! All four h points are masked out so q_D(I,J) will is meaningless CS%q_D(I,J) = 0. endif @@ -4767,15 +4806,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, allocate(lin_drag_h(isd:ied,jsd:jed), source=0.0) - call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=US%m_to_Z*US%T_to_s) + call MOM_read_data(wave_drag_file, wave_drag_var, lin_drag_h, G%Domain, scale=GV%m_to_H*US%T_to_s) call pass_var(lin_drag_h, G%Domain) do j=js,je ; do I=is-1,ie - CS%lin_drag_u(I,j) = (GV%Z_to_H * wave_drag_scale) * & - 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) + CS%lin_drag_u(I,j) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i+1,j)) enddo ; enddo do J=js-1,je ; do i=is,ie - CS%lin_drag_v(i,J) = (GV%Z_to_H * wave_drag_scale) * & - 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) + CS%lin_drag_v(i,J) = wave_drag_scale * 0.5 * (lin_drag_h(i,j) + lin_drag_h(i,j+1)) enddo ; enddo deallocate(lin_drag_h) endif @@ -4790,7 +4827,12 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! Estimate the maximum stable barotropic time step. gtot_estimate = 0.0 - do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%g_prime(K) ; enddo + if (GV%Boussinesq) then + do k=1,GV%ke ; gtot_estimate = gtot_estimate + GV%H_to_Z*GV%g_prime(K) ; enddo + else + H_to_Z = GV%H_to_RZ / CS%Rho_BT_lin + do k=1,GV%ke ; gtot_estimate = gtot_estimate + H_to_Z*GV%g_prime(K) ; enddo + endif call set_dtbt(G, GV, US, CS, gtot_est=gtot_estimate, SSH_add=SSH_extra) if (dtbt_input > 0.0) then @@ -4957,16 +4999,17 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, if (.not.CS%nonlin_stress) then Mean_SL = G%Z_ref + Z_to_H = GV%Z_to_H ; if (.not.GV%Boussinesq) Z_to_H = GV%RZ_to_H * CS%Rho_BT_lin do j=js,je ; do I=is-1,ie if (G%mask2dCu(I,j)>0.) then - CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL) + CS%IDatu(I,j) = G%mask2dCu(I,j) * 2.0 / (Z_to_H * ((G%bathyT(i+1,j) + G%bathyT(i,j)) + 2.0*Mean_SL)) else ! Both neighboring H points are masked out so IDatu(I,j) is meaningless CS%IDatu(I,j) = 0. endif enddo ; enddo do J=js-1,je ; do i=is,ie if (G%mask2dCv(i,J)>0.) then - CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL) + CS%IDatv(i,J) = G%mask2dCv(i,J) * 2.0 / (Z_to_H * ((G%bathyT(i,j+1) + G%bathyT(i,j)) + 2.0*Mean_SL)) else ! Both neighboring H points are masked out so IDatv(i,J) is meaningless CS%IDatv(i,J) = 0. endif From 8234e696d9d8e82c645a8c09177efca67ee2e087 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 27 Jul 2023 11:09:57 -0600 Subject: [PATCH 335/629] Add hbd to the control structure Simplifies and reduces the code by adding hbd to the neutral diffusion contril structure. This avoid the need to "extract" hbl multiple times. Answers are bitwise indenticals. --- src/tracer/MOM_neutral_diffusion.F90 | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 7a5c93d4fa..01c2522145 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -58,6 +58,7 @@ module MOM_neutral_diffusion !! interior_only=true. logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. + real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] ! Coefficients used to apply tapering from neutral to horizontal direction real, allocatable, dimension(:) :: coeff_l !< Non-dimensional coefficient in the left column, !! at cell interfaces @@ -335,7 +336,6 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Variables used for reconstructions real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] @@ -354,14 +354,14 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Check if hbl needs to be extracted if (CS%interior_only) then - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, CS%hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, CS%hbl, G, US, & m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) + call pass_var(CS%hbl,G%Domain) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 if (G%mask2dT(i,j) > 0.0) then - call boundary_k_range(SURFACE, G%ke, h(i,j,:), hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) + call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) endif enddo; enddo ! TODO: add similar code for BOTTOM boundary layer @@ -604,7 +604,6 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion ! [H L2 conc ~> m3 conc or kg conc] - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth [H ~> m or kg m-2] type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk @@ -613,14 +612,6 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - ! Check if hbl needs to be extracted - if (CS%tapering) then - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & - m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) - endif - if (.not. CS%continuous_reconstruction) then if (CS%remap_answer_date < 20190101) then h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 @@ -648,7 +639,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) if (G%mask2dCu(I,j)>0.) then if (CS%tapering) then ! compute coeff_l and coeff_r and pass them to neutral_surface_flux - call compute_tapering_coeffs(G%ke+1, hbl(I,j), hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & h(I,j,:), h(I+1,j,:)) call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & @@ -674,7 +665,7 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) if (G%mask2dCv(i,J)>0.) then if (CS%tapering) then ! compute coeff_l and coeff_r and pass them to neutral_surface_flux - call compute_tapering_coeffs(G%ke+1, hbl(i,J), hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & h(i,J,:), h(i,J+1,:)) call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & From 53ccbc329b40156737a2ae15a3c596832ed9b4e1 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 27 Jul 2023 11:26:26 -0600 Subject: [PATCH 336/629] Fix line length --- src/tracer/MOM_neutral_diffusion.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 01c2522145..3f3a3fdf10 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -361,7 +361,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 if (G%mask2dT(i,j) > 0.0) then - call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), zeta_bot(i,j)) + call boundary_k_range(SURFACE, G%ke, h(i,j,:), CS%hbl(i,j), k_top(i,j), zeta_top(i,j), k_bot(i,j), & + zeta_bot(i,j)) endif enddo; enddo ! TODO: add similar code for BOTTOM boundary layer From cf29f1beb2b4a364c596ce09be58074437917136 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 27 Jul 2023 11:38:01 -0600 Subject: [PATCH 337/629] Allocate hbl --- src/tracer/MOM_neutral_diffusion.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 3f3a3fdf10..ee2d5e6a03 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -267,6 +267,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, endif if (CS%interior_only) then + allocate(CS%hbl(SZI_(G),SZJ_(G)), source=0.) call extract_diabatic_member(diabatic_CSp, KPP_CSp=CS%KPP_CSp) call extract_diabatic_member(diabatic_CSp, energetic_PBL_CSp=CS%energetic_PBL_CSp) if ( .not. ASSOCIATED(CS%energetic_PBL_CSp) .and. .not. ASSOCIATED(CS%KPP_CSp) ) then From fffb6f350533f228019b1cbc8d3794edd91260ba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 May 2023 05:48:06 -0400 Subject: [PATCH 338/629] +*Use thickness_to_dz in tracer modules Use thickness_to_dz to convert layer thicknesses to depths in 4 tracer modules (DOME_tracer, dye_example, ideal_age_example and nw2_tracers) so that this conversion is done correctly in non-Boussineq mode, and there is no longer any dependency on the Boussinesq reference density in that mode. This change includes the addition of a thermo_var_ptrs argument to 5 routines (initialize_DOME_tracer, initialize_dye_tracer, dye_tracer_column_physics ideal_age_tracer_column_physics and count_BL_layers) and changes to the units of some internal variables, and the addition of 6 new 2-d or 3-d arrays with the vertical distance across layers. An unused param_file_type argument to initialize_DOME_tracer was also eliminated. Comments were also added to describe the units of 5 of the variables in the ideal age tracer control structure and 7 internal variables in that same module, and there was some minor cleanup of the formatting cf calls in tracer_flow_control_init. There was some minor refactoring in the ns2_tracers module to use SZK_(GV) instead of SZK_(G) to declare the vertical extent of some arrays, and the vertical indexing convention for interfaces in nw2_tracer_dist was revised from starting at 0 to start at 1 for consistency with all the other code in MOM6. Also moved the code to do halo updates for the physical model state variables and call calc_derived_thermo before calling tracer_flow_control_init, because some routines there are now using the layer average specific volume to convert between thicknesses and heights when in non-Boussinesq mode. All answers in Boussinesq mode are bitwise identical, but these passive tracer modules have slightly different answers in non-Boussinesq mode. There are changes to the non-optional arguments to 4 public interfaces. --- src/core/MOM.F90 | 40 ++++++++-------- src/tracer/DOME_tracer.F90 | 66 ++++++++++++++------------ src/tracer/MOM_tracer_flow_control.F90 | 27 +++++------ src/tracer/dye_example.F90 | 39 ++++++++------- src/tracer/ideal_age_example.F90 | 66 ++++++++++++++------------ src/tracer/nw2_tracers.F90 | 39 ++++++++------- 6 files changed, 149 insertions(+), 128 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d7e2d74735..d1d4be51dd 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3124,26 +3124,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif - ! This subroutine initializes any tracer packages. - call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & - CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & - CS%ALE_sponge_CSp, CS%tv) - if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp - - ! If running in offline tracer mode, initialize the necessary control structure and - ! parameters - if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode - - if (CS%offline_tracer_mode) then - ! Setup some initial parameterizations and also assign some of the subtypes - call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV, US) - call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & - diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & - tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & - tv=CS%tv, x_before_y=(MODULO(first_direction,2)==0), debug=CS%debug ) - call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) - endif - !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM call cpu_clock_begin(id_clock_pass_init) dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) @@ -3169,6 +3149,26 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & call cpu_clock_end(id_clock_pass_init) + ! This subroutine initializes any tracer packages. + call tracer_flow_control_init(.not.new_sim, Time, G, GV, US, CS%h, param_file, & + CS%diag, CS%OBC, CS%tracer_flow_CSp, CS%sponge_CSp, & + CS%ALE_sponge_CSp, CS%tv) + if (present(tracer_flow_CSp)) tracer_flow_CSp => CS%tracer_flow_CSp + + ! If running in offline tracer mode, initialize the necessary control structure and + ! parameters + if (present(offline_tracer_mode)) offline_tracer_mode=CS%offline_tracer_mode + + if (CS%offline_tracer_mode) then + ! Setup some initial parameterizations and also assign some of the subtypes + call offline_transport_init(param_file, CS%offline_CSp, CS%diabatic_CSp, G, GV, US) + call insert_offline_main( CS=CS%offline_CSp, ALE_CSp=CS%ALE_CSp, diabatic_CSp=CS%diabatic_CSp, & + diag=CS%diag, OBC=CS%OBC, tracer_adv_CSp=CS%tracer_adv_CSp, & + tracer_flow_CSp=CS%tracer_flow_CSp, tracer_Reg=CS%tracer_Reg, & + tv=CS%tv, x_before_y=(MODULO(first_direction,2)==0), debug=CS%debug ) + call register_diags_offline_transport(Time, CS%diag, CS%offline_CSp, GV, US) + endif + call register_obsolete_diagnostics(param_file, CS%diag) if (use_frazil) then diff --git a/src/tracer/DOME_tracer.F90 b/src/tracer/DOME_tracer.F90 index 98788843e3..e0bd659a60 100644 --- a/src/tracer/DOME_tracer.F90 +++ b/src/tracer/DOME_tracer.F90 @@ -10,6 +10,7 @@ module DOME_tracer use MOM_forcing_type, only : forcing use MOM_hor_index, only : hor_index_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_tracer_type use MOM_open_boundary, only : OBC_segment_type @@ -19,7 +20,7 @@ module DOME_tracer use MOM_tracer_registry, only : register_tracer, tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -156,7 +157,7 @@ end function register_DOME_tracer !> Initializes the NTR tracer fields in tr(:,:,:,:) and sets up the tracer output. subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & - sponge_CSp, param_file) + sponge_CSp, 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 @@ -170,27 +171,27 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & !! call to DOME_register_tracer. type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure !! for the sponges, if they are in use. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables -! Local variables + ! Local variables real, allocatable :: temp(:,:,:) ! Target values for the tracers in the sponges, perhaps in [g kg-1] character(len=16) :: name ! A variable's name in a NetCDF file. real, pointer :: tr_ptr(:,:,:) => NULL() ! A pointer to one of the tracers, perhaps in [g kg-1] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: tr_y ! Initial zonally uniform tracer concentrations, perhaps in [g kg-1] - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A thickness that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m or kg m-2]. real :: e(SZK_(GV)+1) ! Interface heights relative to the sea surface (negative down) [Z ~> m] real :: e_top ! Height of the top of the tracer band relative to the sea surface [Z ~> m] real :: e_bot ! Height of the bottom of the tracer band relative to the sea surface [Z ~> m] real :: d_tr ! A change in tracer concentrations, in tracer units, perhaps [g kg-1] integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz, m - integer :: IsdB, IedB, JsdB, JedB if (.not.associated(CS)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - h_neglect = GV%H_subroundoff + + dz_neglect = GV%dz_subroundoff CS%Time => day CS%diag => diag @@ -225,31 +226,34 @@ subroutine initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS, & enddo ; enddo ; enddo if (NTR >= 7) then - do j=js,je ; do i=is,ie - e(1) = 0.0 - do k=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z - do m=7,NTR - e_top = -CS%sheet_spacing * (real(m-6)) - e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) - if (e_top < e(K)) then - if (e_top < e(K+1)) then ; d_tr = 0.0 - elseif (e_bot < e(K+1)) then - d_tr = 1.0 * (e_top-e(K+1)) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) - else ; d_tr = 1.0 * (e_top-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + e(1) = 0.0 + do k=1,nz + e(K+1) = e(K) - dz(i,k) + do m=7,NTR + e_top = -CS%sheet_spacing * (real(m-6)) + e_bot = -CS%sheet_spacing * (real(m-6) + 0.5) + if (e_top < e(K)) then + if (e_top < e(K+1)) then ; d_tr = 0.0 + elseif (e_bot < e(K+1)) then + d_tr = 1.0 * (e_top-e(K+1)) / (dz(i,k)+dz_neglect) + else ; d_tr = 1.0 * (e_top-e_bot) / (dz(i,k)+dz_neglect) + endif + elseif (e_bot < e(K)) then + if (e_bot < e(K+1)) then ; d_tr = 1.0 + else ; d_tr = 1.0 * (e(K)-e_bot) / (dz(i,k)+dz_neglect) + endif + else + d_tr = 0.0 endif - elseif (e_bot < e(K)) then - if (e_bot < e(K+1)) then ; d_tr = 1.0 - else ; d_tr = 1.0 * (e(K)-e_bot) / ((h(i,j,k)+h_neglect)*GV%H_to_Z) - endif - else - d_tr = 0.0 - endif - if (h(i,j,k) < 2.0*GV%Angstrom_H) d_tr=0.0 - CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + if (dz(i,k) < 2.0*GV%Angstrom_Z) d_tr=0.0 + CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + d_tr + enddo enddo enddo - enddo ; enddo + enddo endif endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index fc50fc4d1b..bf4988488b 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -317,34 +317,31 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag sponge_CSp) if (CS%use_DOME_tracer) & call initialize_DOME_tracer(restart, day, G, GV, US, h, diag, OBC, CS%DOME_tracer_CSp, & - sponge_CSp, param_file) + sponge_CSp, tv) if (CS%use_ISOMIP_tracer) & call initialize_ISOMIP_tracer(restart, day, G, GV, h, diag, OBC, CS%ISOMIP_tracer_CSp, & ALE_sponge_CSp) if (CS%use_RGC_tracer) & - call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, & - CS%RGC_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + call initialize_RGC_tracer(restart, day, G, GV, h, diag, OBC, CS%RGC_tracer_CSp, & + sponge_CSp, ALE_sponge_CSp) if (CS%use_ideal_age) & call initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS%ideal_age_tracer_CSp, & - sponge_CSp) + sponge_CSp) if (CS%use_regional_dyes) & - call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, & - sponge_CSp) + call initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS%dye_tracer_CSp, sponge_CSp, tv) if (CS%use_oil) & - call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, & - sponge_CSp) + call initialize_oil_tracer(restart, day, G, GV, US, h, diag, OBC, CS%oil_tracer_CSp, sponge_CSp) if (CS%use_advection_test_tracer) & call initialize_advection_test_tracer(restart, day, G, GV, h, diag, OBC, CS%advection_test_tracer_CSp, & sponge_CSp) if (CS%use_OCMIP2_CFC) & - call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, & - sponge_CSp) + call initialize_OCMIP2_CFC(restart, day, G, GV, US, h, diag, OBC, CS%OCMIP2_CFC_CSp, sponge_CSp) if (CS%use_CFC_cap) & call initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS%CFC_cap_CSp) if (CS%use_MOM_generic_tracer) & call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & - CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) + CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) if (CS%use_pseudo_salt_tracer) & call initialize_pseudo_salt_tracer(restart, day, G, GV, US, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & sponge_CSp, tv) @@ -488,13 +485,13 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp, & + G, GV, US, tv, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth, & Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%dye_tracer_CSp, & + G, GV, US, tv, CS%dye_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_oil) & @@ -567,10 +564,10 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) & call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hml) + G, GV, US, tv, CS%ideal_age_tracer_CSp, Hbl=Hml) if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, CS%dye_tracer_CSp) + G, GV, US, tv, CS%dye_tracer_CSp) if (CS%use_oil) & call oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%oil_tracer_CSp, tv) diff --git a/src/tracer/dye_example.F90 b/src/tracer/dye_example.F90 index fbc2b28a95..ff2199fc80 100644 --- a/src/tracer/dye_example.F90 +++ b/src/tracer/dye_example.F90 @@ -11,6 +11,7 @@ module regional_dyes use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : vardesc, var_desc, query_vardesc use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, MOM_restart_CS @@ -21,7 +22,7 @@ module regional_dyes use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -189,7 +190,7 @@ end function register_dye_tracer !> This subroutine initializes the CS%ntr tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. -subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp) +subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_CSp, tv) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. @@ -202,10 +203,12 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C !! conditions are used. type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. - type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure - !! for the sponges, if they are in use. + type(sponge_CS), pointer :: sponge_CSp !< A pointer to the control structure + !! for the sponges, if they are in use. + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables -! Local variables + ! Local variables + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] integer :: i, j, k, m @@ -216,8 +219,9 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C CS%diag => diag ! Establish location of source - do m= 1, CS%ntr - do j=G%jsd,G%jed ; do i=G%isd,G%ied + do j=G%jsc,G%jec + call thickness_to_dz(h, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=G%isc,G%iec ! A dye is set dependent on the center of the cell being inside the rectangular box. if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & @@ -226,8 +230,8 @@ subroutine initialize_dye_tracer(restart, day, G, GV, h, diag, OBC, CS, sponge_C G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k = 1, GV%ke - z_bot = z_bot - h(i,j,k)*GV%H_to_Z - z_center = z_bot + 0.5*h(i,j,k)*GV%H_to_Z + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 @@ -244,7 +248,7 @@ end subroutine initialize_dye_tracer !! This is a simple example of a set of advected passive tracers. !! The arguments to this subroutine are redundant in that !! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) -subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & +subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -264,6 +268,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US !! and tracer forcing fields. Unused fields have NULL ptrs. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(dye_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_dye_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -271,8 +276,9 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] -! Local variables + ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: z_bot ! Height of the bottom of the layer relative to the sea surface [Z ~> m] real :: z_center ! Height of the center of the layer relative to the sea surface [Z ~> m] integer :: i, j, k, is, ie, js, je, nz, m @@ -284,7 +290,7 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US if (present(evap_CFL_limit) .and. present(minimum_forcing_depth)) then do m=1,CS%ntr - do k=1,nz ;do j=js,je ; do i=is,ie + do k=1,nz ; do j=js,je ; do i=is,ie h_work(i,j,k) = h_old(i,j,k) enddo ; enddo ; enddo call applyTracerBoundaryFluxesInOut(G, GV, CS%tr(:,:,:,m), dt, fluxes, h_work, & @@ -297,8 +303,9 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US enddo endif - do m=1,CS%ntr - do j=G%jsd,G%jed ; do i=G%isd,G%ied + do j=js,je + call thickness_to_dz(h_new, tv, dz, j, G, GV) + do m=1,CS%ntr ; do i=is,ie ! A dye is set dependent on the center of the cell being inside the rectangular box. if (CS%dye_source_minlon(m) < G%geoLonT(i,j) .and. & CS%dye_source_maxlon(m) >= G%geoLonT(i,j) .and. & @@ -307,8 +314,8 @@ subroutine dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US G%mask2dT(i,j) > 0.0 ) then z_bot = 0.0 do k=1,nz - z_bot = z_bot - h_new(i,j,k)*GV%H_to_Z - z_center = z_bot + 0.5*h_new(i,j,k)*GV%H_to_Z + z_bot = z_bot - dz(i,k) + z_center = z_bot + 0.5*dz(i,k) if ( z_center > -CS%dye_source_maxdepth(m) .and. & z_center < -CS%dye_source_mindepth(m) ) then CS%tr(i,j,k,m) = 1.0 diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index dfa5e894db..8492437cb6 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -12,6 +12,7 @@ module ideal_age_example use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc +use MOM_interface_heights, only : thickness_to_dz use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_spatial_means, only : global_mass_int_EFP @@ -21,7 +22,7 @@ module ideal_age_example use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface +use MOM_variables, only : surface, thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -46,13 +47,13 @@ module ideal_age_example logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface. - real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. - real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1]. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package [years] or other units + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [years] or other units + real, dimension(NTR_MAX) :: young_val = 0.0 !< The value assigned to tr at the surface [years] or other units + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [years] or other units + real, dimension(NTR_MAX) :: growth_rate !< The exponential growth rate for the young value [year-1] real, dimension(NTR_MAX) :: tracer_start_year !< The year in which tracers start aging, or at which the - !! surface value equals young_val, in years. + !! surface value equals young_val [years]. logical :: use_real_BL_depth !< If true, uses the BL scheme to determine the number of !! layers above the BL depth instead of the fixed nkbl value. integer :: BL_residence_num !< The tracer number assigned to the BL residence tracer in this module @@ -296,7 +297,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers -subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & +subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & evap_CFL_limit, minimum_forcing_depth, Hbl) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -316,6 +317,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! and tracer forcing fields. Unused fields have NULL ptrs. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can @@ -331,12 +333,12 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified - real :: young_val ! The "young" value for the tracers. + real, dimension(SZI_(G),SZJ_(G)) :: BL_layers ! Stores number of layers in boundary layer [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real :: young_val ! The "young" value for the tracers [years] or other units real :: Isecs_per_year ! The inverse of the amount of time in a year [T-1 ~> s-1] - real :: year ! The time in years. - real :: layer_frac + real :: year ! The time in years [years] + real :: layer_frac ! The fraction of the current layer that is within the mixed layer [nondim] integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -347,7 +349,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif if (CS%use_real_BL_depth .and. present(Hbl)) then - call count_BL_layers(G, GV, h_old, Hbl, BL_layers) + call count_BL_layers(G, GV, h_old, Hbl, tv, BL_layers) endif if (.not.associated(CS)) return @@ -576,33 +578,37 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end -subroutine count_BL_layers(G, GV, h, Hbl, BL_layers) +subroutine count_BL_layers(G, GV, h, Hbl, tv, BL_layers) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer depth [Z ~> m] - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer [nondim] - real :: current_depth + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: current_depth ! Distance from the free surface [Z ~> m] integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke BL_layers(:,:) = 0. - do j=js,je ; do i=is,ie - - current_depth = 0. - do k=1,nz - current_depth = current_depth + h(i,j,k)*GV%H_to_Z - if (Hbl(i,j) <= current_depth) then - BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / (h(i,j,k)*GV%H_to_Z)) - exit - else - BL_layers(i,j) = BL_layers(i,j) + 1.0 - endif + do j=js,je + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie + current_depth = 0. + do k=1,nz + current_depth = current_depth + dz(i,k) + if (Hbl(i,j) <= current_depth) then + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / dz(i,k)) + exit + else + BL_layers(i,j) = BL_layers(i,j) + 1.0 + endif + enddo enddo - enddo ; enddo + enddo end subroutine count_BL_layers diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index e9d0bd5ef7..3c8fbe4ae8 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -9,6 +9,7 @@ module nw2_tracers use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_time_manager, only : time_type, time_type_to_real @@ -115,7 +116,7 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + 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 @@ -124,7 +125,8 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) type(nw2_tracers_CS), pointer :: CS !< The control structure returned by a previous !! call to register_nw2_tracer. ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] real :: rscl ! z* scaling factor [nondim] character(len=8) :: var_name ! The variable's name. integer :: i, j, k, m @@ -135,20 +137,22 @@ subroutine initialize_nw2_tracers(restart, day, G, GV, US, h, tv, diag, CS) CS%diag => diag ! Calculate z* interface positions + call thickness_to_dz(h, tv, dz, G, GV, US) + if (GV%Boussinesq) then ! First calculate interface positions in z-space (m) do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) enddo ; enddo do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h(i,j,k) * GV%H_to_Z + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) enddo ; enddo ; enddo ! Re-calculate for interface positions in z*-space (m) do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%bathyT(i,j)>0.) then rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) do K=GV%ke, 1, -1 - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h(i,j,k) * GV%H_to_Z * rscl + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl enddo endif enddo ; enddo @@ -176,15 +180,15 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_old !< Layer thickness before entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_new !< Layer thickness after entrainment [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: ea !< an array to which the amount of fluid entrained !! from the layer above during this call will be !! added [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: eb !< an array to which the amount of fluid entrained !! from the layer below during this call will be !! added [H ~> m or kg m-2]. @@ -206,8 +210,9 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! The arguments to this subroutine are redundant in that ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(G)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(G)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Interface heights [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Vertical extent of layers [Z ~> m] integer :: i, j, k, m real :: dt_x_rate ! dt * restoring rate [nondim] real :: rscl ! z* scaling factor [nondim] @@ -231,20 +236,22 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US endif ! Calculate z* interface positions + call thickness_to_dz(h_new, tv, dz, G, GV, US) + if (GV%Boussinesq) then - ! First calculate interface positions in z-space (m) + ! First calculate interface positions in z-space [Z ~> m] do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,GV%ke+1) = - G%mask2dT(i,j) * G%bathyT(i,j) enddo ; enddo do k=GV%ke,1,-1 ; do j=G%jsc,G%jec ; do i=G%isc,G%iec - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h_new(i,j,k) * GV%H_to_Z + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) enddo ; enddo ; enddo - ! Re-calculate for interface positions in z*-space (m) + ! Re-calculate for interface positions in z*-space [Z ~> m] do j=G%jsc,G%jec ; do i=G%isc,G%iec if (G%bathyT(i,j)>0.) then rscl = G%bathyT(i,j) / ( eta(i,j,1) + G%bathyT(i,j) ) do K=GV%ke, 1, -1 - eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * h_new(i,j,k) * GV%H_to_Z * rscl + eta(i,j,K) = eta(i,j,K+1) + G%mask2dT(i,j) * dz(i,j,k) * rscl enddo endif enddo ; enddo @@ -269,7 +276,7 @@ real function nw2_tracer_dist(m, G, GV, eta, i, j, k) integer, intent(in) :: m !< Indicates the NW2 tracer 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),0:SZK_(G)), & + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: eta !< Interface position [Z ~> m] integer, intent(in) :: i !< Cell index i integer, intent(in) :: j !< Cell index j @@ -280,7 +287,7 @@ real function nw2_tracer_dist(m, G, GV, eta, i, j, k) pi = 2.*acos(0.) x = ( G%geolonT(i,j) - G%west_lon ) / G%len_lon ! 0 ... 1 y = -G%geolatT(i,j) / G%south_lat ! -1 ... 1 - z = - 0.5 * ( eta(i,j,K-1) + eta(i,j,K) ) / GV%max_depth ! 0 ... 1 + z = - 0.5 * ( eta(i,j,K) + eta(i,j,K+1) ) / GV%max_depth ! 0 ... 1 select case ( mod(m-1,3) ) case (0) ! sin(2 pi x/L) nw2_tracer_dist = sin( 2.0 * pi * x ) From 55fc59a36f278f5658a8927208f3fed35879aaa6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 12:52:28 -0400 Subject: [PATCH 339/629] Fix a bug in the OMP directive for plume_flux Changed a recently added OMP directive for plume_flux from private to firstprivate to reflect how this variable is actually used. This bug was introduced with PR #401, but was causing sporadic failures in some of our pipeline tests with the intel compiler (essentially due to initialized memory when openMP is used) for subsequent commits. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 3742e93229..009cdc4075 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1207,8 +1207,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & !$OMP mixing_depth,A_brine,fraction_left_brine, & - !$OMP plume_flux,plume_fraction,dK) & - !$OMP firstprivate(SurfPressure) + !$OMP plume_fraction,dK) & + !$OMP firstprivate(SurfPressure,plume_flux) do j=js,je ! Work in vertical slices for efficiency From 5af37b6545a70cc86c49c345a750074a2da1e364 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 27 Jun 2023 18:34:43 -0400 Subject: [PATCH 340/629] Generalized MOM restart function This patch merges the internal `save_restart` function with the new `save_MOM6_internal_state` function into a new general MOM restart function. It also makes an effort to eliminate `MOM_restart` as a driver dependency, narrowing the required MOM API for existing and future drivers. Also removes the `restart_CSp` argument from `MOM_wave_interface_init`, since it appeared to be used for nothing. --- .../drivers/FMS_cap/ocean_model_MOM.F90 | 26 +++---- .../drivers/mct_cap/mom_ocean_model_mct.F90 | 28 +++---- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 36 ++++----- config_src/drivers/solo_driver/MOM_driver.F90 | 25 +++---- src/core/MOM.F90 | 74 ++++++++++--------- src/user/MOM_wave_interface.F90 | 3 +- 6 files changed, 84 insertions(+), 108 deletions(-) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index bd86a633c6..5fde791724 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -14,7 +14,8 @@ module ocean_model_mod use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type @@ -37,7 +38,6 @@ module ocean_model_mod use MOM_grid, only : ocean_grid_type use MOM_io, only : write_version_number, stdout_if_root use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing_gfdl, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_gfdl, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum @@ -209,9 +209,6 @@ module ocean_model_mod Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -279,7 +276,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, wind_stagger, gas ! initialization of ice shelf parameters and arrays. call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & diag_ptr=OS%diag, count_calls=.true., ice_shelf_CSp=OS%ice_shelf_CSp, & waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & @@ -572,7 +569,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, time_start_upda endif if ((OS%nstep==0) .and. (OS%nstep_thermo==0)) then ! This is the first call to update_ocean_model. - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif Time_thermo_start = OS%Time @@ -693,24 +690,22 @@ subroutine ocean_model_restart(OS, timestamp) "restart files can only be created after the buoyancy forcing is applied.") if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif end subroutine ocean_model_restart @@ -758,16 +753,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) - end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 index cdf93b1bef..82d8881c03 100644 --- a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 @@ -14,7 +14,8 @@ module MOM_ocean_model_mct use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -34,7 +35,6 @@ module MOM_ocean_model_mct use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_surface_forcing_mct, only : surface_forcing_init, convert_IOB_to_fluxes use MOM_surface_forcing_mct, only : convert_IOB_to_forces, ice_ocn_bnd_type_chksum @@ -207,9 +207,6 @@ module MOM_ocean_model_mct Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -271,7 +268,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & @@ -575,7 +572,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif call disable_averaging(OS%diag) @@ -689,35 +686,32 @@ subroutine ocean_model_restart(OS, timestamp, restartname) "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir, .true.) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif @@ -768,7 +762,7 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index 205dbdadcc..9ee7ef921f 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -14,7 +14,8 @@ module MOM_ocean_model_nuopc use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, allocate_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized -use MOM, only : get_ocean_stocks, step_offline, save_MOM6_internal_state +use MOM, only : get_ocean_stocks, step_offline +use MOM, only : save_MOM_restart use MOM_coms, only : field_chksum use MOM_constants, only : CELSIUS_KELVIN_OFFSET, hlf use MOM_diag_mediator, only : diag_ctrl, enable_averages, disable_averaging @@ -34,7 +35,6 @@ module MOM_ocean_model_nuopc use MOM_grid, only : ocean_grid_type use MOM_io, only : close_file, file_exists, read_data, write_version_number use MOM_marine_ice, only : iceberg_forces, iceberg_fluxes, marine_ice_init, marine_ice_CS -use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions, only : uppercase use MOM_time_manager, only : time_type, get_time, set_time, operator(>) use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) @@ -214,9 +214,6 @@ module MOM_ocean_model_nuopc Waves => NULL() !< A pointer to the surface wave control structure type(surface_forcing_CS), pointer :: & forcing_CSp => NULL() !< A pointer to the MOM forcing control structure - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer set to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure end type ocean_state_type @@ -281,7 +278,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i OS%Time = Time_in call initialize_MOM(OS%Time, Time_init, param_file, OS%dirs, OS%MOM_CSp, & - OS%restart_CSp, Time_in, offline_tracer_mode=OS%offline_tracer_mode, & + Time_in, offline_tracer_mode=OS%offline_tracer_mode, & input_restart_file=input_restart_file, & diag_ptr=OS%diag, count_calls=.true., waves_CSp=OS%Waves) call get_MOM_state_elements(OS%MOM_CSp, G=OS%grid, GV=OS%GV, US=OS%US, C_p=OS%C_p, & @@ -407,7 +404,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i ! MOM_wave_interface_init is called regardless of the value of USE_WAVES because ! it also initializes statistical waves. - call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag, OS%restart_CSp) + call MOM_wave_interface_init(OS%Time, OS%grid, OS%GV, OS%US, param_file, OS%Waves, OS%diag) if (associated(OS%grid%Domain%maskmap)) then call initialize_ocean_public_type(OS%grid%Domain%mpp_domain, Ocean_sfc, & @@ -608,7 +605,7 @@ subroutine update_ocean_model(Ice_ocean_boundary, OS, Ocean_sfc, & endif if (OS%nstep==0) then - call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp, OS%restart_CSp) + call finish_MOM_initialization(OS%Time, OS%dirs, OS%MOM_CSp) endif call disable_averaging(OS%diag) @@ -730,36 +727,32 @@ subroutine ocean_model_restart(OS, timestamp, restartname, stoch_restartname, nu "restart files can only be created after the buoyancy forcing is applied.") if (present(restartname)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV, filename=restartname, num_rest_files=num_rest_files) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) ! Is this needed? if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, & OS%dirs%restart_output_dir) endif - - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) else if (BTEST(OS%Restart_control,1)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, .true., GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, time_stamped=.true., GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & - OS%dirs%restart_output_dir, .true.) + OS%dirs%restart_output_dir, time_stamped=.true.) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir, .true.) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, .true.) endif if (BTEST(OS%Restart_control,0)) then - call save_restart(OS%dirs%restart_output_dir, OS%Time, OS%grid, & - OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time, & + OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, OS%Time, & OS%dirs%restart_output_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - call save_MOM6_internal_state(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) endif endif if (present(stoch_restartname)) then @@ -814,16 +807,13 @@ subroutine ocean_model_save_restart(OS, Time, directory, filename_suffix) if (present(directory)) then ; restart_dir = directory else ; restart_dir = OS%dirs%restart_output_dir ; endif - call save_restart(restart_dir, Time, OS%grid, OS%restart_CSp, GV=OS%GV) + call save_MOM_restart(OS%MOM_CSp, restart_dir, Time, OS%grid, GV=OS%GV) call forcing_save_restart(OS%forcing_CSp, OS%grid, Time, restart_dir) if (OS%use_ice_shelf) then call ice_shelf_save_restart(OS%Ice_shelf_CSp, OS%Time, OS%dirs%restart_output_dir) endif - - call save_MOM6_internal_start(OS%MOM_CSp, OS%dirs%restart_output_dir, OS%Time) - end subroutine ocean_model_save_restart !> Initialize the public ocean type diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 72981122f2..84c2eec5b5 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -31,7 +31,8 @@ program MOM6 use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized - use MOM, only : step_offline, save_MOM6_internal_state + use MOM, only : step_offline + use MOM, only : save_MOM_restart use MOM_coms, only : Set_PElist use MOM_domains, only : MOM_infra_init, MOM_infra_end, set_MOM_thread_affinity use MOM_ensemble_manager, only : ensemble_manager_init, get_ensemble_size @@ -52,7 +53,6 @@ program MOM6 use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end use MOM_io, only : APPEND_FILE, READONLY_FILE - use MOM_restart, only : MOM_restart_CS, save_restart use MOM_string_functions,only : uppercase use MOM_surface_forcing, only : set_forcing, forcing_save_restart use MOM_surface_forcing, only : surface_forcing_init, surface_forcing_CS @@ -177,9 +177,6 @@ program MOM6 logical :: override_shelf_fluxes !< If true, and shelf dynamics are active, !! the data_override feature is enabled (only for MOSAIC grid types) type(wave_parameters_cs), pointer :: waves_CSp => NULL() - type(MOM_restart_CS), pointer :: & - restart_CSp => NULL() !< A pointer to the restart control structure - !! that will be used for MOM restart files. type(diag_ctrl), pointer :: & diag => NULL() !< A pointer to the diagnostic regulatory structure !----------------------------------------------------------------------- @@ -281,7 +278,7 @@ program MOM6 if (segment_start_time_set) then ! In this case, the segment starts at a time fixed by ocean_solo.res Time = segment_start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & segment_start_time, offline_tracer_mode=offline_tracer_mode, & diag_ptr=diag, tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, & waves_CSp=Waves_CSp) @@ -289,7 +286,7 @@ program MOM6 ! In this case, the segment starts at a time read from the MOM restart file ! or is left at Start_time by MOM_initialize. Time = Start_time - call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, restart_CSp, & + call initialize_MOM(Time, Start_time, param_file, dirs, MOM_CSp, & offline_tracer_mode=offline_tracer_mode, diag_ptr=diag, & tracer_flow_CSp=tracer_flow_CSp, ice_shelf_CSp=ice_shelf_CSp, waves_CSp=Waves_CSp) endif @@ -473,7 +470,7 @@ program MOM6 endif if (ns==1) then - call finish_MOM_initialization(Time, dirs, MOM_CSp, restart_CSp) + call finish_MOM_initialization(Time, dirs, MOM_CSp) endif ! This call steps the model over a time dt_forcing. @@ -564,22 +561,19 @@ program MOM6 if ((permit_incr_restart) .and. (fluxes%fluxes_used) .and. & (Time + (Time_step_ocean/2) > restart_time)) then if (BTEST(Restart_control,1)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, .true., GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, & + time_stamped=.true., GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir, .true.) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir, .true.) - call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time, .true.) endif if (BTEST(Restart_control,0)) then - call save_restart(dirs%restart_output_dir, Time, grid, & - restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) call forcing_save_restart(surface_forcing_CSp, grid, Time, & dirs%restart_output_dir) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) endif restart_time = restart_time + restint endif @@ -600,10 +594,9 @@ program MOM6 "For conservation, the ocean restart files can only be "//& "created after the buoyancy forcing is applied.") - call save_restart(dirs%restart_output_dir, Time, grid, restart_CSp, GV=GV) + call save_MOM_restart(MOM_CSp, dirs%restart_output_dir, Time, grid, GV=GV) if (use_ice_shelf) call ice_shelf_save_restart(ice_shelf_CSp, Time, & dirs%restart_output_dir) - call save_MOM6_internal_state(MOM_CSp, dirs%restart_output_dir, Time) ! Write the ocean solo restart file. call write_ocean_solo_res(Time, Start_time, calendar_type, & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d1d4be51dd..5dd3f45634 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -435,13 +435,16 @@ module MOM type(porous_barrier_type) :: pbv !< porous barrier fractional cell metrics type(particles), pointer :: particles => NULL() ! NULL() !< a pointer to the stochastics control structure + type(MOM_restart_CS), pointer :: restart_CS => NULL() + !< Pointer to MOM's restart control structure end type MOM_control_struct public initialize_MOM, finish_MOM_initialization, MOM_end -public step_MOM, step_offline, save_MOM6_internal_state +public step_MOM, step_offline public extract_surface_state, get_ocean_stocks public get_MOM_state_elements, MOM_state_is_synchronized public allocate_surface_state, deallocate_surface_state +public save_MOM_restart !>@{ CPU time clock IDs integer :: id_clock_ocean @@ -1903,7 +1906,7 @@ end subroutine step_offline !> Initialize MOM, including memory allocation, setting up parameters and diagnostics, !! initializing the ocean state variables, and initializing subsidiary modules -subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & +subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & Time_in, offline_tracer_mode, input_restart_file, diag_ptr, & count_calls, tracer_flow_CSp, ice_shelf_CSp, waves_CSp) type(time_type), target, intent(inout) :: Time !< model time, set in this routine @@ -1911,9 +1914,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(param_file_type), intent(out) :: param_file !< structure indicating parameter file to parse type(directories), intent(out) :: dirs !< structure with directory paths type(MOM_control_struct), intent(inout), target :: CS !< pointer set in this routine to MOM control structure - type(MOM_restart_CS), pointer :: restart_CSp !< pointer set in this routine to the - !! restart control structure that will - !! be used for MOM. type(time_type), optional, intent(in) :: Time_in !< time passed to MOM_initialize_state when !! model is not being started from a restart file logical, optional, intent(out) :: offline_tracer_mode !< True is returned if tracers are being run offline @@ -1939,6 +1939,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(dyn_horgrid_type), pointer :: dG_in => NULL() type(diag_ctrl), pointer :: diag => NULL() type(unit_scale_type), pointer :: US => NULL() + type(MOM_restart_CS), pointer :: restart_CSp => NULL() character(len=4), parameter :: vers_num = 'v2.0' integer :: turns ! Number of grid quarter-turns @@ -1957,7 +1958,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & type(sponge_CS), pointer :: sponge_in_CSp => NULL() type(ALE_sponge_CS), pointer :: ALE_sponge_in_CSp => NULL() type(oda_incupd_CS),pointer :: oda_incupd_in_CSp => NULL() - ! This include declares and sets the variable "version". # include "version_variable.h" @@ -2665,7 +2665,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & ! Set the fields that are needed for bitwise identical restarting ! the time stepping scheme. - call restart_init(param_file, restart_CSp) + call restart_init(param_file, CS%restart_CS) + restart_CSp => CS%restart_CS + call set_restart_fields(GV, US, param_file, CS, restart_CSp) if (CS%split) then call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & @@ -3219,13 +3221,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & end subroutine initialize_MOM !> Finishes initializing MOM and writes out the initial conditions. -subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) +subroutine finish_MOM_initialization(Time, dirs, CS) type(time_type), intent(in) :: Time !< model time, used in this routine type(directories), intent(in) :: dirs !< structure with directory paths type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - type(MOM_restart_CS), pointer :: restart_CSp !< pointer to the restart control - !! structure that will be used for MOM. - ! Local variables + type(ocean_grid_type), pointer :: G => NULL() ! pointer to a structure containing ! metrics and related information type(verticalGrid_type), pointer :: GV => NULL() ! Pointer to the vertical grid structure @@ -3247,7 +3247,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS, restart_CSp) ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) - restart_CSp_tmp = restart_CSp + restart_CSP_tmp = CS%restart_CS call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) @@ -3926,27 +3926,35 @@ subroutine get_ocean_stocks(CS, mass, heat, salt, on_PE_only) end subroutine get_ocean_stocks -!> Trigger a writing of restarts for the MOM6 internal state -!! -!! Currently this applies to the state that does not take the form -!! of simple arrays for which the generic save_restart() function -!! can be used. -!! -!! Todo: -!! [ ] update particles to use Time and directories -!! [ ] move the call to generic save_restart() in here. -subroutine save_MOM6_internal_state(CS, dirs, time, stamp_time) - type(MOM_control_struct), intent(inout) :: CS !< MOM control structure - character(len=*), intent(in) :: dirs !< The directory where the restart - !! files are to be written - type(time_type), intent(in) :: time !< The current model time - logical, optional, intent(in) :: stamp_time !< If present and true, add time-stamp - - ! Could call save_restart(CS%restart_CSp) here - - if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) - -end subroutine save_MOM6_internal_state +!> Save restart/pickup files required to initialize the MOM6 internal state. +subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & + GV, num_rest_files, write_IC) + type(MOM_control_struct), intent(inout) :: CS + !< MOM control structure + character(len=*), intent(in) :: directory + !< The directory where the restart files are to be written + type(time_type), intent(in) :: time + !< The current model time + type(ocean_grid_type), intent(inout) :: G + !< The ocean's grid structure + logical, optional, intent(in) :: time_stamped + !< If present and true, add time-stamp to the restart file names + character(len=*), optional, intent(in) :: filename + !< A filename that overrides the name in CS%restartfile + type(verticalGrid_type), optional, intent(in) :: GV + !< The ocean's vertical grid structure + integer, optional, intent(out) :: num_rest_files + !< number of restart files written + logical, optional, intent(in) :: write_IC + !< If present and true, initial conditions are being written + + call save_restart(directory, time, G, CS%restart_CS, & + time_stamped=time_stamped, filename=filename, GV=GV, & + num_rest_files=num_rest_files, write_IC=write_IC) + + ! TODO: Update particles to use Time and directories + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) +end subroutine save_MOM_restart !> End of ocean model, including memory deallocation diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a548436329..82ed753fb3 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -259,7 +259,7 @@ module MOM_wave_interface contains !> Initializes parameters related to MOM_wave_interface -subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restart_CSp) +subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) type(time_type), target, intent(in) :: Time !< Model time type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -267,7 +267,6 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar type(param_file_type), intent(in) :: param_file !< Input parameter structure type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostic Pointer - type(MOM_restart_CS), optional, pointer:: restart_CSp!< Restart control structure ! Local variables character(len=40) :: mdl = "MOM_wave_interface" !< This module's name. From 3d9190c99c4551b130a32f8b99e1fa6f1066c555 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 6 Jul 2023 10:32:17 -0400 Subject: [PATCH 341/629] Create restart directory if absent MOM simulations typically abort of the restart directory (usually RESTART) are absent. This patch adds POSIX support for mkdir() and creates the directory if it is missing. --- src/framework/MOM_get_input.F90 | 11 +++++++++++ src/framework/posix.F90 | 32 ++++++++++++++++++++++++++++++++ 2 files changed, 43 insertions(+) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index b6b5b89be9..09f7efc956 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -11,6 +11,7 @@ module MOM_get_input use MOM_file_parser, only : open_param_file, param_file_type use MOM_io, only : file_exists, close_file, slasher, ensembler use MOM_io, only : open_namelist_file, check_nml_error +use posix, only : mkdir implicit none ; private @@ -73,6 +74,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, endif ! Read namelist parameters + ! NOTE: Every rank is reading MOM_input_nml ierr=1 ; do while (ierr /= 0) read(unit, nml=MOM_input_nml, iostat=io, end=10) ierr = check_nml_error(io, 'MOM_input_nml') @@ -92,6 +94,15 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, dirs%restart_input_dir = slasher(ensembler(restart_input_dir)) dirs%input_filename = ensembler(input_filename) endif + + ! Create the RESTART directory if absent + if (is_root_PE()) then + if (.not. file_exists(dirs%restart_output_dir)) then + ierr = mkdir(trim(dirs%restart_output_dir), int(o'700')) + if (ierr == -1) & + call MOM_error(FATAL, 'Restart directory could not be created.') + endif + endif endif ! Open run-time parameter file(s) diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 213ff4656d..9524543fb7 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -52,6 +52,21 @@ function chmod_posix(path, mode) result(rc) bind(c, name="chmod") !< Function return code end function chmod_posix + !> C interface to POSIX mkdir() + !! Users should use the Fortran-defined mkdir() function. + function mkdir_posix(path, mode) result(rc) bind(c, name="mkdir") + ! #include + ! int mkdir(const char *path, mode_t mode); + import :: c_char, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Zero-delimited file path + integer(kind=c_int), value, intent(in) :: mode + !< File permission to be assigned to file. + integer(kind=c_int) :: rc + !< Function return code + end function mkdir_posix + !> C interface to POSIX signal() !! Users should use the Fortran-defined signal() function. function signal_posix(sig, func) result(handle) bind(c, name="signal") @@ -240,6 +255,23 @@ function chmod(path, mode) result(rc) rc = int(rc_c) end function chmod +!> Create a file directory +!! +!! This creates a new directory named `path` with permissons set by `mode`. +!! If successful, it returns zero. Otherwise, it returns -1. +function mkdir(path, mode) result(rc) + character(len=*), intent(in) :: path + integer, intent(in) :: mode + integer :: rc + + integer(kind=c_int) :: mode_c + integer(kind=c_int) :: rc_c + + mode_c = int(mode, kind=c_int) + rc_c = mkdir_posix(path//c_null_char, mode_c) + rc = int(rc_c) +end function mkdir + !> Create a signal handler `handle` to be called when `sig` is detected. !! !! If successful, the previous handler for `sig` is returned. Otherwise, From 5efad9b983b494dc26f24cb1238d33cf6b0c5f1e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 21 Jul 2023 17:48:49 -0400 Subject: [PATCH 342/629] Use POSIX stat to check if restart dir exists Using inquire() to check for directory existence is not possible, since at least one compiler (Intel) does not consider directories to be files. The inquire call is replaced with a C interface to the POSIX stat() function. We do not fully emulate the behavior of stat, but we use its return value to determine existence of directories. This provides a more reliable method for identifying the existence of the directory. This should resolve many of the observed problems with RESTART creation in coupled runs. --- src/framework/MOM_get_input.F90 | 6 ++-- src/framework/posix.F90 | 49 ++++++++++++++++++++++++++++++++- src/framework/posix.h | 6 ++++ 3 files changed, 58 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_get_input.F90 b/src/framework/MOM_get_input.F90 index 09f7efc956..b6773ccb21 100644 --- a/src/framework/MOM_get_input.F90 +++ b/src/framework/MOM_get_input.F90 @@ -11,7 +11,7 @@ module MOM_get_input use MOM_file_parser, only : open_param_file, param_file_type use MOM_io, only : file_exists, close_file, slasher, ensembler use MOM_io, only : open_namelist_file, check_nml_error -use posix, only : mkdir +use posix, only : mkdir, stat, stat_buf implicit none ; private @@ -55,6 +55,8 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, character(len=240) :: output_dir integer :: unit, io, ierr, valid_param_files + type(stat_buf) :: buf + namelist /MOM_input_nml/ output_directory, input_filename, parameter_filename, & restart_input_dir, restart_output_dir @@ -97,7 +99,7 @@ subroutine get_MOM_input(param_file, dirs, check_params, default_input_filename, ! Create the RESTART directory if absent if (is_root_PE()) then - if (.not. file_exists(dirs%restart_output_dir)) then + if (stat(trim(dirs%restart_output_dir), buf) == -1) then ierr = mkdir(trim(dirs%restart_output_dir), int(o'700')) if (ierr == -1) & call MOM_error(FATAL, 'Restart directory could not be created.') diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index 9524543fb7..fffb619cba 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -13,6 +13,16 @@ module posix implicit none +!> Container for file metadata from stat +!! +!! NOTE: This is currently just a placeholder containing fields, such as size, +!! uid, mode, etc. A readable Fortran type may be used in the future. +type, bind(c) :: stat_buf + private + character(kind=c_char) :: state(SIZEOF_STAT_BUF) + !< Byte array containing file metadata +end type stat_buf + !> Container for the jump point buffer created by setjmp(). !! !! The buffer typically contains the current register values, stack pointers, @@ -67,6 +77,19 @@ function mkdir_posix(path, mode) result(rc) bind(c, name="mkdir") !< Function return code end function mkdir_posix + !> C interface to POSIX stat() + !! Users should use the Fortran-defined stat() function. + function stat_posix(path, buf) result(rc) bind(c, name="stat") + import :: c_char, stat_buf, c_int + + character(kind=c_char), dimension(*), intent(in) :: path + !< Pathname of a POSIX file + type(stat_buf), intent(in) :: buf + !< Information describing the file if it exists + integer(kind=c_int) :: rc + !< Function return code + end function + !> C interface to POSIX signal() !! Users should use the Fortran-defined signal() function. function signal_posix(sig, func) result(handle) bind(c, name="signal") @@ -272,6 +295,27 @@ function mkdir(path, mode) result(rc) rc = int(rc_c) end function mkdir +!> Get file status +!! +!! This obtains information about the named file and writes it to buf. +!! If found, it returns zero. Otherwise, it returns -1. +function stat(path, buf) result(rc) + character(len=*), intent(in) :: path + !< Pathname of file to be inspected + type(stat_buf), intent(out) :: buf + !< Buffer containing information about the file if it exists + ! NOTE: Currently the contents of buf are not readable, but we could move + ! the contents into a readable Fortran type. + integer :: rc + !< Function return code + + integer(kind=c_int) :: rc_c + + rc_c = stat_posix(path//c_null_char, buf) + + rc = int(rc_c) +end function stat + !> Create a signal handler `handle` to be called when `sig` is detected. !! !! If successful, the previous handler for `sig` is returned. Otherwise, @@ -391,6 +435,9 @@ function setjmp_missing(env) result(rc) bind(c) print '(a)', 'ERROR: setjmp() is not implemented in this build.' print '(a)', 'Recompile with autoconf or -DSETJMP_NAME=\"\".' error stop + + ! NOTE: compilers may expect a return value, even if it is unreachable + rc = -1 end function setjmp_missing !> Placeholder function for a missing or unconfigured longjmp @@ -418,7 +465,7 @@ function sigsetjmp_missing(env, savesigs) result(rc) bind(c) print '(a)', 'Recompile with autoconf or -DSIGSETJMP_NAME=\"\".' error stop - ! NOTE: Compilers may expect a return value, even if it is unreachable + ! NOTE: compilers may expect a return value, even if it is unreachable rc = -1 end function sigsetjmp_missing diff --git a/src/framework/posix.h b/src/framework/posix.h index f7cea0fec9..c4b09e1285 100644 --- a/src/framework/posix.h +++ b/src/framework/posix.h @@ -1,6 +1,12 @@ #ifndef MOM6_POSIX_H_ #define MOM6_POSIX_H_ +! STAT_BUF_SIZE should be set to sizeof(stat). +! The default value is based on glibc 2.28. +#ifndef SIZEOF_STAT_BUF +#define SIZEOF_STAT_BUF 144 +#endif + ! JMP_BUF_SIZE should be set to sizeof(jmp_buf). ! If unset, then use a typical glibc value (25 long ints) #ifndef SIZEOF_JMP_BUF From 84056b18f74b04b65c1c2b2ad65bc7e31258ff3a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 30 Mar 2023 13:10:19 -0400 Subject: [PATCH 343/629] *Cancel out Z_to_H factors in MOM_hor_visc.F90 Cancelled out factors of GV%Z_to_H in MOM_hor_visc.F90 to simplify the code and reduce the dependence on the value of GV%Rho_0 in non-Boussinesq mode. This involved changing the units of 3 internal variables in horizontal_viscosity and one element in the hor_visc_CS type to use thickness units or their inverse. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode. --- src/parameterizations/lateral/MOM_hor_visc.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 9037c71c5a..83809d39db 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -98,7 +98,7 @@ module MOM_hor_visc !! the answers from the end of 2018, while higher values use updated !! and more robust forms of the same expressions. real :: GME_h0 !< The strength of GME tapers quadratically to zero when the bathymetric - !! depth is shallower than GME_H0 [Z ~> m] + !! total water column thickness is less than GME_H0 [H ~> m or kg m-2] real :: GME_efficiency !< The nondimensional prefactor multiplying the GME coefficient [nondim] real :: GME_limiter !< The absolute maximum value the GME coefficient is allowed to take [L2 T-1 ~> m2 s-1]. real :: min_grid_Kh !< Minimum horizontal Laplacian viscosity used to @@ -284,7 +284,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot ! The total thickness of all layers [Z ~> m] + htot ! The total thickness of all layers [H ~> m or kg m-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] @@ -353,8 +353,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: hu, hv ! Thicknesses interpolated by arithmetic means to corner ! points; these are first interpolated to u or v velocity ! points where masks are applied [H ~> m or kg m-2]. - real :: h_arith_q ! The arithmetic mean total thickness at q points [Z ~> m] - real :: I_GME_h0 ! The inverse of GME tapering scale [Z-1 ~> m-1] + real :: h_arith_q ! The arithmetic mean total thickness at q points [H ~> m or kg m-2] + real :: I_GME_h0 ! The inverse of GME tapering scale [H-1 ~> m-1 or m2 kg-1] 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 :: h_min ! Minimum h at the 4 neighboring velocity points [H ~> m] @@ -494,7 +494,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, htot(i,j) = 0.0 enddo ; enddo do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 - htot(i,j) = htot(i,j) + GV%H_to_Z*h(i,j,k) + htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo I_GME_h0 = 1.0 / CS%GME_h0 @@ -2042,7 +2042,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "GME_H0", CS%GME_h0, & "The strength of GME tapers quadratically to zero when the bathymetric "//& "depth is shallower than GME_H0.", & - units="m", scale=US%m_to_Z, default=1000.0) + units="m", scale=GV%m_to_H, default=1000.0) call get_param(param_file, mdl, "GME_EFFICIENCY", CS%GME_efficiency, & "The nondimensional prefactor multiplying the GME coefficient.", & units="nondim", default=1.0) From 3fd219112db9c8e108d878f6b6a4b0fda9d5ea5d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 14 Jul 2023 06:45:13 -0400 Subject: [PATCH 344/629] +*Revise the units of 12 vertvisc_type elements Revised the units of 12 vertvisc_type elements to be based on thicknesses, so that vertical viscosities (in [H Z T-1 ~> m2 s-1 or Pa s]) are stored as dynamic viscosites when in non-Boussinesq mode, with analogous changes to the diapycanl diffusivity (now in [H Z T-1 ~> m2 s-1 or kg m-1 s-1]). Similarly changed the units of the 2 Rayleigh drag velocity elements (Ray_u and Ray_v) of the vertvisc_type from vertical velocity units to thickness flux units and to more accurately reflect the nature of these fields. The bottom boundary layer TKE source element (TKE_BBL) was also revised to [H Z2 T-3 ~> m3 s-3 or W m-2]. This commit also adds required changes to the units of the viscosities or shear-driven diffusivities returned from KPP_calculate, calculate_CVMix_shear, calculate_CVMix_conv, Calculate_kappa_shear, Calc_kappa_shear_vertex, calculate_tidal_mixing and calculate_CVMix_tidal. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode unless GV%Rho_0 is chosen to be an integer power of 2. --- src/core/MOM_variables.F90 | 28 ++++---- src/parameterizations/lateral/MOM_MEKE.F90 | 4 +- .../vertical/MOM_CVMix_KPP.F90 | 12 ++-- .../vertical/MOM_CVMix_conv.F90 | 6 +- .../vertical/MOM_CVMix_shear.F90 | 16 ++--- .../vertical/MOM_diabatic_driver.F90 | 14 ++-- .../vertical/MOM_kappa_shear.F90 | 25 +++---- .../vertical/MOM_set_diffusivity.F90 | 48 +++++++------- .../vertical/MOM_set_viscosity.F90 | 66 +++++++++---------- .../vertical/MOM_tidal_mixing.F90 | 8 +-- .../vertical/MOM_vert_friction.F90 | 34 +++++----- 11 files changed, 131 insertions(+), 130 deletions(-) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 0c4a42e8c6..199524fa33 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -234,12 +234,12 @@ module MOM_variables real, allocatable, dimension(:,:) :: & bbl_thick_u, & !< The bottom boundary layer thickness at the u-points [Z ~> m]. bbl_thick_v, & !< The bottom boundary layer thickness at the v-points [Z ~> m]. - kv_bbl_u, & !< The bottom boundary layer viscosity at the u-points [Z2 T-1 ~> m2 s-1]. - kv_bbl_v, & !< The bottom boundary layer viscosity at the v-points [Z2 T-1 ~> m2 s-1]. - ustar_BBL, & !< The turbulence velocity in the bottom boundary layer at h points [Z T-1 ~> m s-1]. + kv_bbl_u, & !< The bottom boundary layer viscosity at the u-points [H Z T-1 ~> m2 s-1 or Pa s] + kv_bbl_v, & !< The bottom boundary layer viscosity at the v-points [H Z T-1 ~> m2 s-1 or Pa s] + ustar_BBL, & !< The turbulence velocity in the bottom boundary layer at + !! h points [H T-1 ~> m s-1 or kg m-2 s-1]. TKE_BBL, & !< A term related to the bottom boundary layer source of turbulent kinetic - !! energy, currently in [Z3 T-3 ~> m3 s-3], but may at some time be changed - !! to [R Z3 T-3 ~> W m-2]. + !! energy, currently in [H Z2 T-3 ~> m3 s-3 or W m-2]. taux_shelf, & !< The zonal stresses on the ocean under shelves [R Z L T-2 ~> Pa]. tauy_shelf !< The meridional stresses on the ocean under shelves [R Z L T-2 ~> Pa]. real, allocatable, dimension(:,:) :: tbl_thick_shelf_u @@ -247,9 +247,11 @@ module MOM_variables real, allocatable, dimension(:,:) :: tbl_thick_shelf_v !< Thickness of the viscous top boundary layer under ice shelves at v-points [Z ~> m]. real, allocatable, dimension(:,:) :: kv_tbl_shelf_u - !< Viscosity in the viscous top boundary layer under ice shelves at u-points [Z2 T-1 ~> m2 s-1]. + !< Viscosity in the viscous top boundary layer under ice shelves at + !! u-points [H Z T-1 ~> m2 s-1 or Pa s] real, allocatable, dimension(:,:) :: kv_tbl_shelf_v - !< Viscosity in the viscous top boundary layer under ice shelves at v-points [Z2 T-1 ~> m2 s-1]. + !< Viscosity in the viscous top boundary layer under ice shelves at + !! v-points [H Z T-1 ~> m2 s-1 or Pa s] real, allocatable, dimension(:,:) :: nkml_visc_u !< The number of layers in the viscous surface mixed layer at u-points [nondim]. !! This is not an integer because there may be fractional layers, and it is stored in @@ -258,24 +260,24 @@ module MOM_variables real, allocatable, dimension(:,:) :: nkml_visc_v !< The number of layers in the viscous surface mixed layer at v-points [nondim]. real, allocatable, dimension(:,:,:) :: & - Ray_u, & !< The Rayleigh drag velocity to be applied to each layer at u-points [Z T-1 ~> m s-1]. - Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [Z T-1 ~> m s-1]. + Ray_u, & !< The Rayleigh drag velocity to be applied to each layer at u-points [H T-1 ~> m s-1 or Pa s m-1]. + Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [H T-1 ~> m s-1 or Pa s m-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(:,:) :: 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]. + !! in tracer columns [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, pointer, dimension(:,:,:) :: Kv_shear => NULL() !< The shear-driven turbulent vertical viscosity at the interfaces between layers - !! in tracer columns [Z2 T-1 ~> m2 s-1]. + !! in tracer columns [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: Kv_shear_Bu => NULL() !< The shear-driven turbulent vertical viscosity at the interfaces between layers in - !! corner columns [Z2 T-1 ~> m2 s-1]. + !! corner columns [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: Kv_slow => NULL() !< The turbulent vertical viscosity component due to "slow" processes (e.g., tidal, - !! background, convection etc) [Z2 T-1 ~> m2 s-1]. + !! background, convection etc) [H Z T-1 ~> m2 s-1 or Pa s] real, pointer, dimension(:,:,:) :: TKE_turb => NULL() !< The turbulent kinetic energy per unit mass at the interfaces [Z2 T-2 ~> m2 s-2]. !! This may be at the tracer or corner points diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 0ef261a956..3059ca1637 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -311,13 +311,13 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js,je ; do I=is-1,ie drag_vel_u(I,j) = 0.0 if ((G%mask2dCu(I,j) > 0.0) .and. (visc%bbl_thick_u(I,j) > 0.0)) & - drag_vel_u(I,j) = visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) + drag_vel_u(I,j) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie drag_vel_v(i,J) = 0.0 if ((G%mask2dCv(i,J) > 0.0) .and. (visc%bbl_thick_v(i,J) > 0.0)) & - drag_vel_v(i,J) = visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) + drag_vel_v(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) enddo ; enddo !$OMP parallel do default(shared) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 32946021be..f5d30029f1 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -616,7 +616,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & !! [Z2 T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP !! (out) Vertical viscosity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransHeat !< Temp non-local transport [nondim] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: nonLocalTransScalar !< scalar non-local trans. [nondim] type(wave_parameters_CS), pointer :: Waves !< Wave CS for Langmuir turbulence @@ -713,7 +713,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & else Kdiffusivity(:,1) = US%Z2_T_to_m2_s * Kt(i,j,:) Kdiffusivity(:,2) = US%Z2_T_to_m2_s * Ks(i,j,:) - Kviscosity(:) = US%Z2_T_to_m2_s * Kv(i,j,:) + Kviscosity(:) = GV%HZ_T_to_m2_s * Kv(i,j,:) endif IF (CS%LT_K_ENHANCEMENT) then @@ -862,15 +862,15 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & do k=1, GV%ke+1 Kt(i,j,k) = Kt(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,1) Ks(i,j,k) = Ks(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,2) - Kv(i,j,k) = Kv(i,j,k) + US%m2_s_to_Z2_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) + Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,1) if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,2) - if (Kviscosity(k) /= 0.) Kv(i,j,k) = US%m2_s_to_Z2_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) + if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo endif endif diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index e26c061929..ce5adc82e2 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -147,7 +147,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) !! will be incremented here [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: KV !< Viscosity at each interface that will be - !! incremented here [Z2 T-1 ~> m2 s-1]. + !! incremented here [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_aux !< A second diapycnal diffusivity at each !! interface that will also be incremented @@ -249,7 +249,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! Increment the viscosity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * kv_col(K) + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * kv_col(K) enddo ! Store 3-d arrays for diagnostics. @@ -278,7 +278,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! if (CS%id_kv_conv > 0) & ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 708bb7c4fd..2e23787555 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -66,9 +66,9 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) 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 !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kd !< The vertical diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(out) :: kv !< The vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] type(CVMix_shear_cs), pointer :: CS !< The control structure returned by a previous !! call to CVMix_shear_init. ! Local variables @@ -176,8 +176,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) if (CS%id_ri_grad > 0) CS%ri_grad(i,j,:) = Ri_Grad(:) do K=1,GV%ke+1 - Kvisc(K) = US%Z2_T_to_m2_s * kv(i,j,K) - Kdiff(K) = US%Z2_T_to_m2_s * kd(i,j,K) + Kvisc(K) = GV%HZ_T_to_m2_s * kv(i,j,K) + Kdiff(K) = GV%HZ_T_to_m2_s * kd(i,j,K) enddo ! Call to CVMix wrapper for computing interior mixing coefficients. @@ -187,8 +187,8 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) nlev=GV%ke, & max_nlev=GV%ke) do K=1,GV%ke+1 - kv(i,j,K) = US%m2_s_to_Z2_T * Kvisc(K) - kd(i,j,K) = US%m2_s_to_Z2_T * Kdiff(K) + kv(i,j,K) = GV%m2_s_to_HZ_T * Kvisc(K) + kd(i,j,K) = GV%m2_s_to_HZ_T * Kdiff(K) enddo enddo enddo @@ -324,9 +324,9 @@ logical function CVMix_shear_init(Time, G, GV, US, param_file, diag, CS) endif CS%id_kd = register_diag_field('ocean_model', 'kd_shear_CVMix', diag%axesTi, Time, & - 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Vertical diffusivity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_kv = register_diag_field('ocean_model', 'kv_shear_CVMix', diag%axesTi, Time, & - 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Vertical viscosity added by MOM_CVMix_shear module', 'm2/s', conversion=GV%HZ_T_to_m2_s) end function CVMix_shear_init diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 466ebbabca..6e67f9f51b 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -814,7 +814,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & - optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & + optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then @@ -850,10 +850,10 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) endif Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) @@ -1395,10 +1395,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) endif Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 78ec0d9391..191b88de0a 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -127,15 +127,15 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. Initially this is the - !! value from the previous timestep, which may + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. Initially this + !! is the value from the previous timestep, which may !! accelerate the iteration toward convergence. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(inout) :: kv_io !< The vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. This discards any + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s]. This discards any !! previous value (i.e. it is intent out) and !! simply sets Kv = Prandtl * Kd_shear real, intent(in) :: dt !< Time increment [T ~> s]. @@ -312,15 +312,15 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif ; enddo ! i-loop do K=1,nz+1 ; do i=is,ie - kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) + kappa_io(i,j,K) = G%mask2dT(i,j) * GV%Z_to_H*kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) - kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb + kv_io(i,j,K) = ( G%mask2dT(i,j) * GV%Z_to_H*kappa_2d(i,K) ) * CS%Prandtl_turb enddo ; enddo enddo ! end of j-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) call hchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif @@ -353,12 +353,13 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ !! (or NULL). real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: kappa_io !< The diapycnal diffusivity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & intent(out) :: tke_io !< The turbulent kinetic energy per unit mass at !! each interface (not layer!) [Z2 T-2 ~> m2 s-2]. real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)+1), & - intent(inout) :: kv_io !< The vertical viscosity at each interface [Z2 T-1 ~> m2 s-1]. + intent(inout) :: kv_io !< The vertical viscosity at each interface + !! [H Z T-1 ~> m2 s-1 or Pa s]. !! The previous value is used to initialize kappa !! in the vertex columns as Kappa = Kv/Prandtl !! to accelerate the iteration toward convergence. @@ -577,11 +578,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nz+1 ; do I=IsB,IeB tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) - kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb + kv_io(I,J,K) = ( G%mask2dBu(I,J) * GV%Z_to_H*kappa_2d(I,K,J2) ) * CS%Prandtl_turb enddo ; enddo if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec ! Set the diffusivities in tracer columns from the values at vertices. - kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * GV%Z_to_H * & ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) enddo ; enddo ; endif @@ -589,7 +590,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ enddo ! end of J-loop if (CS%debug) then - call hchksum(kappa_io, "kappa", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(kappa_io, "kappa", G%HI, scale=GV%HZ_T_to_m2_s) call Bchksum(tke_io, "tke", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif @@ -1906,7 +1907,7 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag CS%id_Kd_shear = register_diag_field('ocean_model','Kd_shear', diag%axesTi, Time, & - 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Shear-driven Diapycnal Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_TKE = register_diag_field('ocean_model','TKE_shear', diag%axesTi, Time, & 'Shear-driven Turbulent Kinetic Energy', 'm2 s-2', conversion=US%Z_to_m**2*US%s_to_T**2) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index dfd264c92a..a83b36a377 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -310,7 +310,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_int(:,:,:) = CS%Kd if (present(Kd_extra_T)) Kd_extra_T(:,:,:) = 0.0 if (present(Kd_extra_S)) Kd_extra_S(:,:,:) = 0.0 - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = GV%Z_to_H*CS%Kv ! Set up arrays for diagnostics. @@ -346,8 +346,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) if (associated(visc%Kv_shear)) visc%Kv_shear(:,:,:) = 0.0 ! needed for other parameterizations if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after calc_KS_vert visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call Bchksum(visc%Kv_shear_Bu, "after calc_KS_vert visc%Kv_shear_Bu", G%HI, scale=GV%HZ_T_to_m2_s) call Bchksum(visc%TKE_turb, "after calc_KS_vert visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif else @@ -355,8 +355,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call calculate_kappa_shear(u_h, v_h, h, tv, fluxes%p_surf, visc%Kd_shear, visc%TKE_turb, & visc%Kv_shear, dt, G, GV, US, CS%kappaShear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after calc_KS visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after calc_KS visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) call hchksum(visc%TKE_turb, "after calc_KS visc%TKE_turb", G%HI, scale=US%Z_to_m**2*US%s_to_T**2) endif endif @@ -366,8 +366,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !NOTE{BGR}: this needs to be cleaned up. It works in 1D case, but has not been tested outside. call calculate_CVMix_shear(u_h, v_h, h, tv, visc%Kd_shear, visc%Kv_shear, G, GV, US, CS%CVMix_shear_CSp) if (CS%debug) then - call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=US%Z2_T_to_m2_s) - call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=US%Z2_T_to_m2_s) + call hchksum(visc%Kd_shear, "after CVMix_shear visc%Kd_shear", G%HI, scale=GV%HZ_T_to_m2_s) + call hchksum(visc%Kv_shear, "after CVMix_shear visc%Kv_shear", G%HI, scale=GV%HZ_T_to_m2_s) endif elseif (associated(visc%Kv_shear)) then visc%Kv_shear(:,:,:) = 0.0 ! needed if calculate_kappa_shear is not enabled @@ -408,7 +408,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay_2d, Kd_int_2d, Kv_bkgnd, j, G, GV, US, CS%bkgnd_mixing_csp) ! Update Kv and 3-d diffusivity diagnostics. if (associated(visc%Kv_slow)) then ; do K=1,nz+1 ; do i=is,ie - visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + Kv_bkgnd(i,K) + visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + GV%Z_to_H*Kv_bkgnd(i,K) enddo ; enddo ; endif if (CS%id_Kv_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie dd%Kv_bkgnd(i,j,K) = Kv_bkgnd(i,K) @@ -474,14 +474,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Add the input turbulent diffusivity. if (CS%useKappaShear .or. CS%use_CVMix_shear) then do K=2,nz ; do i=is,ie - Kd_int_2d(i,K) = visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) + Kd_int_2d(i,K) = GV%H_to_Z*visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) enddo ; enddo do i=is,ie - Kd_int_2d(i,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int_2d(i,1) = GV%H_to_Z*visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. Kd_int_2d(i,nz+1) = 0.0 enddo do k=1,nz ; do i=is,ie - Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + GV%H_to_Z*0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else do i=is,ie @@ -582,7 +582,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (CS%debug) then if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) @@ -591,7 +591,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then call uvchksum("BBL Kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, symmetric=.true., scale=US%Z2_T_to_m2_s, & + haloshift=0, symmetric=.true., scale=GV%HZ_T_to_m2_s, & scalar_pair=.true.) endif @@ -1211,7 +1211,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & ! Any turbulence that makes it into the mixed layers is assumed ! to be relatively small and is discarded. do i=is,ie - ustar_h = visc%ustar_BBL(i,j) + ustar_h = GV%H_to_Z*visc%ustar_BBL(i,j) if (associated(fluxes%ustar_tidal)) & ustar_h = ustar_h + fluxes%ustar_tidal(i,j) absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & @@ -1224,7 +1224,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & I2decay(i) = 0.5*CS%IMax_decay endif TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - visc%TKE_BBL(i,j) + GV%H_to_Z*visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & @@ -1284,7 +1284,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1426,7 +1426,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! ! u* at the bottom [Z T-1 ~> m s-1]. - ustar = visc%ustar_BBL(i,j) + ustar = GV%H_to_Z*visc%ustar_BBL(i,j) ustar2 = ustar**2 ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting ! since ustar_BBL should already include all contributions to u*? -AJA @@ -1439,9 +1439,9 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. - ! (Note that visc%TKE_BBL is in [Z3 T-3 ~> m3 s-3], set in set_BBL_TKE().) + ! (Note that visc%TKE_BBL is in [H Z2 T-3 ~> m3 s-3 or W m-2], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA - TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) + TKE_column = cdrag_sqrt * GV%H_to_Z*visc%TKE_BBL(i,j) ! Add in tidal dissipation energy at the bottom [Z3 T-3 ~> m3 s-3]. ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. if (associated(fluxes%TKE_tidal)) & @@ -1463,7 +1463,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & + 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1740,7 +1740,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%Kv_bbl_v)) then do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. - vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) + vstar(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) endif ; enddo endif !### What about terms from visc%Ray? @@ -1794,7 +1794,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%bbl_thick_u)) then do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. - ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) + ustar(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) endif ; enddo endif @@ -1839,12 +1839,12 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) endif ; enddo do i=is,ie - visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * & + visc%ustar_BBL(i,j) = GV%Z_to_H*sqrt(0.5*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + & G%areaCu(I,j)*(ustar(I)*ustar(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = US%L_to_Z**2 * & + visc%TKE_BBL(i,j) = GV%Z_to_H*US%L_to_Z**2 * & (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 481aa5e9fc..f7b1456d46 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -964,12 +964,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then if (Rayleigh > 0.0) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + visc%Ray_u(I,j,k) = GV%Z_to_H*Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) else ; visc%Ray_u(I,j,k) = 0.0 ; endif else if (Rayleigh > 0.0) then u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + visc%Ray_v(i,J,k) = GV%Z_to_H*Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif @@ -1027,33 +1027,31 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif endif - if (CS%body_force_drag) then - if (h_bbl_drag(i) > 0.0) then - ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. - h_sum = 0.0 - I_hwtot = 1.0 / h_bbl_drag(i) - do k=nz,1,-1 - h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot - if (m==1) then - visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr - else - visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr - endif - h_sum = h_sum + h_at_vel(i,k) - if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. - enddo - ! Do not enhance the near-bottom viscosity in this case. - Kv_bbl = CS%Kv_BBL_min - endif - endif + if (CS%body_force_drag) then ; if (h_bbl_drag(i) > 0.0) then + ! Increment the Rayleigh drag as a way introduce the bottom drag as a body force. + h_sum = 0.0 + I_hwtot = 1.0 / h_bbl_drag(i) + do k=nz,1,-1 + h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (m==1) then + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr + else + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr + endif + h_sum = h_sum + h_at_vel(i,k) + if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. + enddo + ! Do not enhance the near-bottom viscosity in this case. + Kv_bbl = CS%Kv_BBL_min + endif ; endif kv_bbl = max(CS%Kv_BBL_min, kv_bbl) if (m==1) then visc%bbl_thick_u(I,j) = bbl_thick_Z - if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = kv_bbl + if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = GV%Z_to_H*kv_bbl else visc%bbl_thick_v(i,J) = bbl_thick_Z - if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl + if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = GV%Z_to_H*kv_bbl endif endif ; enddo ! end of i loop enddo ; enddo ! end of m & j loops @@ -1078,10 +1076,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%debug) then if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & - call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=US%Z_to_m*US%s_to_T) + call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & - haloshift=0, scale=US%Z2_T_to_m2_s, scalar_pair=.true.) + haloshift=0, scale=GV%HZ_T_to_m2_s, scalar_pair=.true.) if (allocated(visc%bbl_thick_u) .and. allocated(visc%bbl_thick_v)) & call uvchksum("bbl_thick_[uv]", visc%bbl_thick_u, visc%bbl_thick_v, & G%HI, haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) @@ -1604,7 +1602,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z - visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + visc%Kv_tbl_shelf_u(I,j) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) endif ; enddo ! I-loop endif ! do_any_shelf @@ -1841,7 +1839,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z - visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + visc%Kv_tbl_shelf_v(i,J) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) endif ; enddo ! i-loop endif ! do_any_shelf @@ -1903,21 +1901,21 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & "Shear-driven turbulent diffusivity at interfaces", & - units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') + units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & "Shear-driven turbulent viscosity at interfaces", & - units="m2 s-1", conversion=US%Z2_T_to_m2_s, z_grid='i') + units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & "Shear-driven turbulent viscosity at vertex interfaces", & - units="m2 s-1", conversion=US%Z2_T_to_m2_s, hor_grid="Bu", z_grid='i') + units="m2 s-1", conversion=GV%HZ_T_to_m2_s, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -2277,7 +2275,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_thick_u = register_diag_field('ocean_model', 'bbl_thick_u', & diag%axesCu1, Time, 'BBL thickness at u points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_u = register_diag_field('ocean_model', 'kv_bbl_u', diag%axesCu1, & - Time, 'BBL viscosity at u points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + Time, 'BBL viscosity at u points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_bbl_u = register_diag_field('ocean_model', 'bbl_u', diag%axesCu1, & Time, 'BBL mean u current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_u>0) then @@ -2286,7 +2284,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS CS%id_bbl_thick_v = register_diag_field('ocean_model', 'bbl_thick_v', & diag%axesCv1, Time, 'BBL thickness at v points', 'm', conversion=US%Z_to_m) CS%id_kv_bbl_v = register_diag_field('ocean_model', 'kv_bbl_v', diag%axesCv1, & - Time, 'BBL viscosity at v points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + Time, 'BBL viscosity at v points', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_bbl_v = register_diag_field('ocean_model', 'bbl_v', diag%axesCv1, & Time, 'BBL mean v current', 'm s-1', conversion=US%L_T_to_m_s) if (CS%id_bbl_v>0) then @@ -2304,9 +2302,9 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS allocate(visc%Ray_u(IsdB:IedB,jsd:jed,nz), source=0.0) allocate(visc%Ray_v(isd:ied,JsdB:JedB,nz), source=0.0) CS%id_Ray_u = register_diag_field('ocean_model', 'Rayleigh_u', diag%axesCuL, & - Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + Time, 'Rayleigh drag velocity at u points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_Ray_v = register_diag_field('ocean_model', 'Rayleigh_v', diag%axesCvL, & - Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + Time, 'Rayleigh drag velocity at v points', 'm s-1', conversion=GV%H_to_m*US%s_to_T) endif diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 430a9225b5..57fc98834e 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -746,7 +746,7 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! [Z2 T-1 ~> m2 s-1]. !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & @@ -777,7 +777,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy !! frequency at the interfaces [T-2 ~> s-2]. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface - !! (not layer!) [Z2 T-1 ~> m2 s-1]. + !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers [Z2 T-1 ~> m2 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & @@ -873,7 +873,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update viscosity with the proper unit conversion. if (associated(Kv)) then do K=1,GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. enddo endif @@ -975,7 +975,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update viscosity if (associated(Kv)) then do K=1,GV%ke+1 - Kv(i,j,K) = Kv(i,j,K) + US%m2_s_to_Z2_T * Kv_tidal(K) ! Rescale from m2 s-1 to Z2 T-1. + Kv(i,j,K) = Kv(i,j,K) + GV%m2_s_to_HZ_T * Kv_tidal(K) ! Rescale from m2 s-1 to H Z T-1. enddo endif diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 496012c3d9..6af1dd78a2 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -464,7 +464,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) + Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) enddo ; enddo ; endif ! perform forward elimination on the tridiagonal system @@ -636,7 +636,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) + Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then @@ -877,7 +877,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = visc%Ray_u(I,j,k) + Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) enddo ; enddo ; endif do I=Isq,Ieq ; if (do_i(I)) then @@ -906,7 +906,7 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = visc%Ray_v(i,J,k) + Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then @@ -1070,7 +1070,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq - kv_bbl(I) = visc%Kv_bbl_u(I,j) + kv_bbl(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H + h_neglect if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) enddo ; endif @@ -1263,7 +1263,7 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie - kv_bbl(i) = visc%Kv_bbl_v(i,J) + kv_bbl(i) = GV%H_to_Z*visc%Kv_bbl_v(i,J) bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + h_neglect if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) enddo ; endif @@ -1609,14 +1609,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! layer thicknesses or the surface wind stresses are added later. if (work_on_u) then do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) endif ; enddo ; enddo if (do_OBCs) then do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i+1,j,k) ; enddo endif endif ; enddo endif @@ -1625,14 +1625,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) endif ; enddo ; enddo if (do_OBCs) then do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo + do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j+1,k) ; enddo endif endif ; enddo endif @@ -1648,11 +1648,11 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! to further modify these viscosities here to take OBCs into account. if (work_on_u) then do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then - Kv_tot(I,K) = Kv_tot(I,K) + (0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(I,K) = Kv_tot(I,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + (0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(i,K) = Kv_tot(i,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo endif endif @@ -1726,10 +1726,10 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Set the coefficients to include the no-slip surface stress. do i=is,ie ; if (do_i(i)) then if (work_on_u) then - kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) + kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_u(I,j) tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + h_neglect else - kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) + kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_v(i,J) tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + h_neglect endif z_t(i) = 0.0 @@ -2440,7 +2440,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ALLOC_(CS%h_v(isd:ied,JsdB:JedB,nz)) ; CS%h_v(:,:,:) = 0.0 CS%id_Kv_slow = register_diag_field('ocean_model', 'Kv_slow', diag%axesTi, Time, & - 'Slow varying vertical viscosity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & 'Total vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) From 2d42dcacfc8e1773e900a3520339ab3c1ce0f5a5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 16 Jul 2023 18:57:51 -0400 Subject: [PATCH 345/629] +Thickness-based diffusivity arguments Rescaled diapycnal diffusivities passed as arguments in non-Boussinesq mode, to be equivalent to the thermal conductivity divided by the heat capacity, analogously to the difference between a kinematic viscosity and a dynamic viscosity, so that the new units are [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. This includes changing the units of 4 arguments to set_diffusivity; 3 arguments each to calculate_bkgnd_mixing, add_drag_diffusivity, add_LOTW_BBL_diffusivity, user_change_diff, calculate_tidal_mixing and add_int_tide_diffusivity; 2 arguments to KPP_calculate, calculate_CVMix_conv, compute_ddiff_coeffs, differential_diffuse_T_S, entrainment_diffusive, double_diffusion, add_MLrad_diffusivity, and calculate_CVMix_tidal; and one argument to energetic_PBL. The units of 36 internal variables were also changed, as were a total of 29 elements in various opaque types, including 8 elements in bkgnd_mixing_cs, 2 in diabatic_CC, 3 in tidal_mixing_diags type, 1 in user_change_diff_CS, 9 in set_diffusivity_CS type, and 6 elements in diffusivity_diags. Two new internal variables were added, and several redundant GV%H_to_Z conversion factors were also cancelled out, some using that GV%H_to_Z*GV%Rho0 = GV%H_to_RZ. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode unless GV%Rho_0 is chosen to be an integer power of 2. --- .../vertical/MOM_CVMix_KPP.F90 | 26 +-- .../vertical/MOM_CVMix_conv.F90 | 15 +- .../vertical/MOM_CVMix_ddiff.F90 | 10 +- .../vertical/MOM_bkgnd_mixing.F90 | 81 +++---- .../vertical/MOM_diabatic_aux.F90 | 12 +- .../vertical/MOM_diabatic_driver.F90 | 150 ++++++------ .../vertical/MOM_energetic_PBL.F90 | 4 +- .../vertical/MOM_entrain_diffusive.F90 | 14 +- .../vertical/MOM_set_diffusivity.F90 | 215 +++++++++--------- .../vertical/MOM_tidal_mixing.F90 | 90 ++++---- src/user/user_change_diffusivity.F90 | 16 +- 11 files changed, 327 insertions(+), 306 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index f5d30029f1..5e56098c98 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -536,7 +536,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) 'Heat diffusivity due to KPP, as calculated by [CVMix] KPP', & 'm2/s', conversion=US%Z2_T_to_m2_s) CS%id_Kd_in = register_diag_field('ocean_model', 'KPP_Kd_in', diag%axesTi, Time, & - 'Diffusivity passed to KPP', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Diffusivity passed to KPP', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Ks_KPP = register_diag_field('ocean_model', 'KPP_Ksalt', diag%axesTi, Time, & 'Salt diffusivity due to KPP, as calculated by [CVMix] KPP', & 'm2/s', conversion=US%Z2_T_to_m2_s) @@ -610,10 +610,10 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kt !< (in) Vertical diffusivity of heat w/o KPP !! (out) Vertical diffusivity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Ks !< (in) Vertical diffusivity of salt w/o KPP !! (out) Vertical diffusivity including KPP - !! [Z2 T-1 ~> m2 s-1] + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kv !< (in) Vertical viscosity w/o KPP !! (out) Vertical viscosity including KPP !! [H Z T-1 ~> m2 s-1 or Pa s] @@ -650,8 +650,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & call hchksum(h, "KPP in: h",G%HI,haloshift=0, scale=GV%H_to_m) call hchksum(uStar, "KPP in: uStar",G%HI,haloshift=0, scale=US%Z_to_m*US%s_to_T) call hchksum(buoyFlux, "KPP in: buoyFlux",G%HI,haloshift=0, scale=US%L_to_m**2*US%s_to_T**3) - call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kt, "KPP in: Kt",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP in: Ks",G%HI,haloshift=0, scale=GV%HZ_T_to_m2_s) endif nonLocalTrans(:,:) = 0.0 @@ -711,8 +711,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & Kdiffusivity(:,:) = 0. ! Diffusivities for heat and salt [m2 s-1] Kviscosity(:) = 0. ! Viscosity [m2 s-1] else - Kdiffusivity(:,1) = US%Z2_T_to_m2_s * Kt(i,j,:) - Kdiffusivity(:,2) = US%Z2_T_to_m2_s * Ks(i,j,:) + Kdiffusivity(:,1) = GV%HZ_T_to_m2_s * Kt(i,j,:) + Kdiffusivity(:,2) = GV%HZ_T_to_m2_s * Ks(i,j,:) Kviscosity(:) = GV%HZ_T_to_m2_s * Kv(i,j,:) endif @@ -860,15 +860,15 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & if (.not. CS%passiveMode) then if (CS%KPPisAdditive) then do k=1, GV%ke+1 - Kt(i,j,k) = Kt(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,1) - Ks(i,j,k) = Ks(i,j,k) + US%m2_s_to_Z2_T * Kdiffusivity(k,2) + Kt(i,j,k) = Kt(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + Ks(i,j,k) = Ks(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,2) Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 - if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,1) - if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = US%m2_s_to_Z2_T * Kdiffusivity(k,2) + if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,1) + if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,2) if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) enddo @@ -883,8 +883,8 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & call cpu_clock_end(id_clock_KPP_calc) if (CS%debug) then - call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kt, "KPP out: Kt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Ks, "KPP out: Ks", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! send diagnostics to post_data diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index ce5adc82e2..c95b967681 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -143,15 +143,16 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) type(CVMix_conv_cs), intent(in) :: CS !< CVMix convection control structure real, dimension(SZI_(G),SZJ_(G)), intent(in) :: hbl !< Depth of ocean boundary layer [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd !< Diapycnal diffusivity at each interface that - !! will be incremented here [Z2 T-1 ~> m2 s-1]. + intent(inout) :: Kd !< Diapycnal diffusivity at each interface + !! that will be incremented here + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: KV !< Viscosity at each interface that will be + intent(inout) :: Kv !< Viscosity at each interface that will be !! incremented here [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_aux !< A second diapycnal diffusivity at each !! interface that will also be incremented - !! here [Z2 T-1 ~> m2 s-1]. + !! here [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables real, dimension(SZK_(GV)) :: rho_lwr !< Adiabatic Water Density [kg m-3], this is a dummy @@ -238,12 +239,12 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! Increment the diffusivity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kd(i,j,K) = Kd(i,j,K) + US%m2_s_to_Z2_T * kd_col(K) + Kd(i,j,K) = Kd(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) enddo if (present(Kd_aux)) then ! Increment the other diffusivity outside of the boundary layer. do K=max(1,kOBL+1),GV%ke+1 - Kd_aux(i,j,K) = Kd_aux(i,j,K) + US%m2_s_to_Z2_T * kd_col(K) + Kd_aux(i,j,K) = Kd_aux(i,j,K) + GV%m2_s_to_HZ_T * kd_col(K) enddo endif @@ -277,7 +278,7 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) ! call hchksum(Kd_conv, "MOM_CVMix_conv: Kd_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) ! if (CS%id_kv_conv > 0) & ! call hchksum(Kv_conv, "MOM_CVMix_conv: Kv_conv", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd, "MOM_CVMix_conv: Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(Kv, "MOM_CVMix_conv: Kv", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index 6e2c76ba8d..c2bf357559 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -150,9 +150,11 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) integer, intent(in) :: j !< Meridional grid index to work on. ! Kd_T and Kd_S are intent inout because only one j-row is set here, but they are essentially outputs. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_T !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. + !! diffusivity for temperature + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd_S !< Interface double diffusion diapycnal - !! diffusivity for salt [Z2 T-1 ~> m2 s-1]. + !! diffusivity for salinity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(CVMix_ddiff_cs), pointer :: CS !< The control structure returned !! by a previous call to CVMix_ddiff_init. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & @@ -254,8 +256,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) nlev=GV%ke, & max_nlev=GV%ke) do K=1,GV%ke+1 - Kd_T(i,j,K) = US%m2_s_to_Z2_T * Kd1_T(K) - Kd_S(i,j,K) = US%m2_s_to_Z2_T * Kd1_S(K) + Kd_T(i,j,K) = GV%m2_s_to_HZ_T * Kd1_T(K) + Kd_S(i,j,K) = GV%m2_s_to_HZ_T * Kd1_S(K) enddo ! Do not apply mixing due to convection within the boundary layer diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 01f8303ae2..693b9395bd 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -45,15 +45,15 @@ module MOM_bkgnd_mixing real :: Bryan_Lewis_c4 !< The depth where diffusivity is Bryan_Lewis_bl1 in the !! Bryan-Lewis profile [Z ~> m] real :: bckgrnd_vdc1 !< Background diffusivity (Ledwell) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_eq !< Equatorial diffusivity (Gregg) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_psim !< Max. PSI induced diffusivity (MacKinnon) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: bckgrnd_vdc_Banda !< Banda Sea diffusivity (Gordon) when - !! horiz_varying_background=.true. [Z2 T-1 ~> m2 s-1] - real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1] - real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1] + !! horiz_varying_background=.true. [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: N0_2Omega !< ratio of the typical Buoyancy frequency to !! twice the Earth's rotation period, used with the @@ -63,10 +63,10 @@ module MOM_bkgnd_mixing real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of !! diffusivities with Kd_tanh_lat_fn [nondim]. Valid values !! are in the range of -2 to 2; 0.4 reproduces CM2M. - real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_tot_ml !< The mixed layer diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! when no other physically based mixed layer turbulence !! parameterization is being used. - real :: Hmix !< mixed layer thickness [Z ~> m] when no physically based + real :: Hmix !< mixed layer thickness [H ~> m or kg m-2] when no physically based !! ocean surface boundary layer parameterization is used. logical :: Kd_tanh_lat_fn !< If true, use the tanh dependence of Kd_sfc on !! latitude, like GFDL CM2.1/CM2M. There is no @@ -114,8 +114,10 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL !! surface boundary layer. ! Local variables - real :: Kv ! The interior vertical viscosity [Z2 T-1 ~> m2 s-1] - read to set Prandtl + real :: Kv ! The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] - read to set Prandtl ! number unless it is provided as a parameter + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. real :: prandtl_bkgnd_comp ! Kv/CS%Kd [nondim]. Gets compared with user-specified prandtl_bkgnd. ! This include declares and sets the variable "version". @@ -132,19 +134,20 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call log_version(param_file, mdl, version, & "Adding static vertical background mixing coefficients") - call get_param(param_file, mdl, "KD", CS%Kd, & + call get_param(param_file, mdl, "KD", Kd_z, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z call get_param(param_file, mdl, "KV", Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) ! The following is needed to set one of the choices of vertical background mixing @@ -152,11 +155,11 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL if (CS%physical_OBL_scheme) then ! Check that Kdml is not set when using bulk mixed layer call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & - units="m2 s-1", default=-1., scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=-1., scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KDML is a depricated parameter that should not be used.") call get_param(param_file, mdl, "KD_ML_TOT", CS%Kd_tot_ml, & - units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (CS%Kd_tot_ml>0.) call MOM_error(FATAL, & "bkgnd_mixing_init: KD_ML_TOT cannot be set when using a physically based ocean "//& "boundary layer mixing parameterization.") @@ -166,13 +169,13 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL "The total diapcynal diffusivity in the surface mixed layer when there is "//& "not a physically based parameterization of mixing in the mixed layer, such "//& "as bulk mixed layer or KPP or ePBL.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (abs(CS%Kd_tot_ml - CS%Kd) <= 1.0e-15*abs(CS%Kd)) then call get_param(param_file, mdl, "KDML", CS%Kd_tot_ml, & "If BULKMIXEDLAYER is false, KDML is the elevated "//& "diapycnal diffusivity in the topmost HMIX of fluid. "//& "KDML is only used if BULKMIXEDLAYER is false.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (abs(CS%Kd_tot_ml - CS%Kd) > 1.0e-15*abs(CS%Kd)) & call MOM_error(WARNING, "KDML is a depricated parameter. Use KD_ML_TOT instead.") endif @@ -180,12 +183,12 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL "The total diapcynal diffusivity in the surface mixed layer when there is "//& "not a physically based parameterization of mixing in the mixed layer, such "//& "as bulk mixed layer or KPP or ePBL.", & - units="m2 s-1", default=CS%Kd*US%Z2_T_to_m2_s, unscale=US%Z2_T_to_m2_s) + units="m2 s-1", default=Kd_z*US%Z2_T_to_m2_s, unscale=GV%HZ_T_to_m2_s) call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & "The prescribed depth over which the near-surface "//& "viscosity and diffusivity are elevated when the bulk "//& - "mixed layer is not used.", units="m", scale=US%m_to_Z, fail_if_missing=.true.) + "mixed layer is not used.", units="m", scale=GV%m_to_H, fail_if_missing=.true.) endif call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -228,19 +231,19 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call get_param(param_file, mdl, "BCKGRND_VDC1", CS%bckgrnd_vdc1, & "Background diffusivity (Ledwell) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.16e-04, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 0.16e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_EQ", CS%bckgrnd_vdc_eq, & "Equatorial diffusivity (Gregg) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.01e-04, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 0.01e-04, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_PSIM", CS%bckgrnd_vdc_psim, & "Max. PSI induced diffusivity (MacKinnon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 0.13e-4, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 0.13e-4, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "BCKGRND_VDC_BAN", CS%bckgrnd_vdc_Banda, & "Banda Sea diffusivity (Gordon) when HORIZ_VARYING_BACKGROUND=True", & - units="m2 s-1",default = 1.0e-4, scale=US%m2_s_to_Z2_T) + units="m2 s-1",default = 1.0e-4, scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "PRANDTL_BKGND", CS%prandtl_bkgnd, & @@ -318,12 +321,12 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< squared buoyancy frequency associated !! with layers [T-2 ~> s-2] - real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity - !! of each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity - !! of each interface [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: Kd_lay !< The background diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kd_int !< The background diapycnal diffusivity of each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), intent(out) :: Kv_bkgnd !< The background vertical viscosity at - !! each interface [Z2 T-1 ~> m2 s-1] + !! each interface [H Z T-1 ~> m2 s-1 or Pa s] integer, intent(in) :: j !< Meridional grid index type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(bkgnd_mixing_cs), pointer :: CS !< The control structure returned by @@ -333,10 +336,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real, dimension(SZK_(GV)+1) :: depth_int !< Distance from surface of the interfaces [m] real, dimension(SZK_(GV)+1) :: Kd_col !< Diffusivities at the interfaces [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] - real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [Z2 T-1 ~> m2 s-1] - real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [Z ~> m] - real :: depth_c !< depth of the center of a layer [Z ~> m] - real :: I_Hmix !< inverse of fixed mixed layer thickness [Z-1 ~> m-1] + real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [H ~> m or kg m-2] + real :: depth_c !< depth of the center of a layer [H ~> m or kg m-2] + real :: I_Hmix !< inverse of fixed mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: I_2Omega !< 1/(2 Omega) [T ~> s] real :: N_2Omega ! The ratio of the stratification to the Earth's rotation rate [nondim] real :: N02_N2 ! The ratio a reference stratification to the actual stratification [nondim] @@ -344,8 +347,8 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real :: deg_to_rad !< factor converting degrees to radians [radians degree-1], pi/180. real :: abs_sinlat !< absolute value of sine of latitude [nondim] real :: min_sinlat ! The minimum value of the sine of latitude [nondim] - real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [Z2 T-1 ~> m2 s-1] - real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [Z2 T-1 ~> m2 s-1] + real :: bckgrnd_vdc_psin !< PSI diffusivity in northern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: bckgrnd_vdc_psis !< PSI diffusivity in southern hemisphere [H Z T-1 ~> m2 s-1 or kg m-1 s-1] integer :: i, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -380,11 +383,11 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, ! Update Kd and Kv. do K=1,nz+1 - Kv_bkgnd(i,K) = US%m2_s_to_Z2_T*Kv_col(K) - Kd_int(i,K) = US%m2_s_to_Z2_T*Kd_col(K) + Kv_bkgnd(i,K) = GV%m2_s_to_HZ_T * Kv_col(K) + Kd_int(i,K) = GV%m2_s_to_HZ_T*Kd_col(K) enddo do k=1,nz - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_col(K) + Kd_col(K+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_col(K) + Kd_col(K+1)) enddo enddo ! i loop @@ -461,10 +464,10 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, if ((.not.CS%physical_OBL_scheme) .and. (CS%Kd /= CS%Kd_tot_ml)) then ! This is a crude way to put in a diffusive boundary layer without an explicit boundary ! layer turbulence scheme. It should not be used for any realistic ocean models. - I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff*GV%H_to_Z) + I_Hmix = 1.0 / (CS%Hmix + GV%H_subroundoff) do i=is,ie ; depth(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - depth_c = depth(i) + 0.5*GV%H_to_Z*h(i,j,k) + depth_c = depth(i) + 0.5*h(i,j,k) if (CS%Kd_via_Kdml_bug) then ! These two lines should update Kd_lay, not Kd_int. They were correctly working on the ! same variables until MOM6 commit 7a818716 (PR#750), which was added on March 26, 2018. @@ -481,7 +484,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, endif endif - depth(i) = depth(i) + GV%H_to_Z*h(i,j,k) + depth(i) = depth(i) + h(i,j,k) enddo ; enddo else ! There is no vertical structure to the background diffusivity. diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 009cdc4075..f176b0d726 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -239,11 +239,11 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_T !< The extra diffusivity of temperature due to !! double diffusion relative to the diffusivity of - !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(in) :: Kd_S !< The extra diffusivity of salinity due to !! double diffusion relative to the diffusivity of - !! diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! density [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any !! available thermodynamic fields. real, intent(in) :: dt !< Time increment [T ~> s]. @@ -272,8 +272,8 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) do j=js,je do i=is,ie I_h_int = 1.0 / (0.5 * (h(i,j,1) + h(i,j,2)) + h_neglect) - mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H**2) * I_h_int - mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H**2) * I_h_int + mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H) * I_h_int + mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H) * I_h_int h_tr = h(i,j,1) + h_neglect b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) @@ -286,8 +286,8 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) do k=2,nz-1 ; do i=is,ie ! Calculate the mixing across the interface below this layer. I_h_int = 1.0 / (0.5 * (h(i,j,k) + h(i,j,k+1)) + h_neglect) - mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H**2) * I_h_int - mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H**2) * I_h_int + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H) * I_h_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H) * I_h_int c1_T(i,k) = mix_T(i,K) * b1_T(i) c1_S(i,k) = mix_S(i,K) * b1_S(i) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 6e67f9f51b..631a47c259 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -145,11 +145,11 @@ module MOM_diabatic_driver !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes - !! [Z2 T-1 ~> m2 s-1]. The entrainment at the bottom is at + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. The entrainment at the bottom is at !! least sqrt(Kd_BBL_tr*dt) over the same distance. real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers - !! near the bottom [Z2 T-1 ~> m2 s-1]. + !! near the bottom [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: minimum_forcing_depth !< The smallest depth over which heat and freshwater !! fluxes are applied [H ~> m or kg m-2]. real :: evap_CFL_limit = 0.8 !< The largest fraction of a layer that can be @@ -543,14 +543,14 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! salinity and passive tracers [H ~> m or kg m-2] ent_t, & ! The diffusive coupling across interfaces within one time step for ! temperature [H ~> m or kg m-2] - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] - Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. - Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -569,7 +569,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] - real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. real :: Ent_int ! The diffusive entrainment rate at an interface [H ~> m or kg m-2] @@ -638,7 +638,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! Set diffusivities for heat and salt separately @@ -659,8 +659,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%debug) then - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after set_diffusivity Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif call cpu_clock_begin(id_clock_kpp) @@ -673,17 +673,17 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) - ! The KPP scheme calculates boundary layer diffusivities and non-local transport. + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) @@ -719,8 +719,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & @@ -783,7 +783,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(I_hval) do K=2,nz ; do j=js,je ; do i=is,ie I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_s(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_int(i,j,K) + ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_int(i,j,K) ent_t(i,j,K) = ent_s(i,j,K) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_s and ent_t from Kd_int (diabatic)") @@ -818,8 +818,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_mks) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & scale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & @@ -850,13 +850,13 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif - Ent_int = Kd_add_here * (GV%Z_to_H**2 * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) + Ent_int = Kd_add_here * (GV%Z_to_H * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) ent_s(i,j,K) = ent_s(i,j,K) + Ent_int Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here @@ -869,7 +869,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (CS%debug) then call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif else @@ -1002,7 +1002,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je @@ -1021,7 +1021,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ent_s(i,j,K) + ent_s(i,j,K)) if (htot(i) < Tr_ea_BBL) then @@ -1034,7 +1034,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) ent_s(i,j,K) = ent_s(i,j,K) + add_ent endif ; endif @@ -1045,7 +1045,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) else add_ent = 0.0 @@ -1140,13 +1140,13 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ent_t, & ! The diffusive coupling across interfaces within one time step for ! temperature [H ~> m or kg m-2] Kd_heat, & ! diapycnal diffusivity of heat or the smaller of the diapycnal diffusivities of - ! heat and salt [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + ! heat and salt [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int returned from set_diffusivity [Z2 T-1 ~> m2 s-1]. + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int returned from set_diffusivity [Z2 T-1 ~> m2 s-1]. - Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] + ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1166,7 +1166,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. - real :: Kd_add_here ! An added diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: Idt ! The inverse time step [T-1 ~> s-1] logical :: showCallTree ! If true, show the call tree @@ -1235,7 +1235,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after set_diffusivity Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif ! Store the diagnosed typical diffusivity at interfaces. @@ -1257,8 +1257,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif if (CS%debug) then - call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after double diffuse Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after double diffuse Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif if (CS%useKPP) then @@ -1307,8 +1307,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & @@ -1395,10 +1395,10 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then Kd_add_here = Kd_ePBL(i,j,K) - visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K) + visc%Kv_shear(i,j,K) = visc%Kv_shear(i,j,K) + CS%ePBL_Prandtl*Kd_ePBL(i,j,K) else - Kd_add_here = max(Kd_ePBL(i,j,K) - GV%H_to_Z*visc%Kd_shear(i,j,K), 0.0) - visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*GV%Z_to_H*Kd_ePBL(i,j,K)) + Kd_add_here = max(Kd_ePBL(i,j,K) - visc%Kd_shear(i,j,K), 0.0) + visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif Kd_heat(i,j,K) = Kd_heat(i,j,K) + Kd_add_here @@ -1408,7 +1408,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (CS%debug) then call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif else @@ -1473,8 +1473,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, !$OMP parallel do default(shared) private(I_hval) do K=2,nz ; do j=js,je ; do i=is,ie I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_t(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_heat(i,j,k) - ent_s(i,j,K) = (GV%Z_to_H**2) * dt * I_hval * Kd_salt(i,j,k) + ent_t(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_heat(i,j,k) + ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_salt(i,j,k) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_t and ent_t from Kd_heat and " //& "Kd_salt (diabatic_ALE)") @@ -1505,14 +1505,14 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call diag_update_remap_grids(CS%diag) ! Diagnose the diapycnal diffusivities and other related quantities. - if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) - if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) - if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) + if (CS%id_Kd_heat > 0) call post_data(CS%id_Kd_heat, Kd_heat, CS%diag) + if (CS%id_Kd_salt > 0) call post_data(CS%id_Kd_salt, Kd_salt, CS%diag) + if (CS%id_Kd_ePBL > 0) call post_data(CS%id_Kd_ePBL, Kd_ePBL, CS%diag) - if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) - if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) - if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) - if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) + if (CS%id_ea_t > 0) call post_data(CS%id_ea_t, ent_t(:,:,1:nz), CS%diag) + if (CS%id_eb_t > 0) call post_data(CS%id_eb_t, ent_t(:,:,2:nz+1), CS%diag) + if (CS%id_ea_s > 0) call post_data(CS%id_ea_s, ent_s(:,:,1:nz), CS%diag) + if (CS%id_eb_s > 0) call post_data(CS%id_eb_s, ent_s(:,:,2:nz+1), CS%diag) Idt = 1.0 / dt if (CS%id_Tdif > 0) then @@ -1540,7 +1540,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1554,7 +1554,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! bottom, add some mixing of tracers between these layers. This flux is based on the ! harmonic mean of the two thicknesses, following what is done in layered mode. Kd_min_tr ! should be much less than the values in Kd_salt, perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & ((h(i,j,k-1)+h(i,j,k) + h_neglect) / (h(i,j,k-1)*h(i,j,k) + h_neglect2)) - & ent_s(i,j,K) if (htot(i) < Tr_ea_BBL) then @@ -1646,7 +1646,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! one time step [H ~> m or kg m-2] eb, & ! amount of fluid entrained from the layer below within ! one time step [H ~> m or kg m-2] - Kd_lay, & ! diapycnal diffusivity of layers [Z2 T-1 ~> m2 s-1] + Kd_lay, & ! diapycnal diffusivity of layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] @@ -1665,13 +1665,13 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! homogenize tracers in massless layers near the boundaries [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & - Kd_int, & ! diapycnal diffusivity of interfaces [Z2 T-1 ~> m2 s-1] - Kd_heat, & ! diapycnal diffusivity of heat [Z2 T-1 ~> m2 s-1] - Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [Z2 T-1 ~> m2 s-1] + Kd_int, & ! diapycnal diffusivity of interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_heat, & ! diapycnal diffusivity of heat [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_salt, & ! diapycnal diffusivity of salt and passive tracers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_T , & ! The extra diffusivity of temperature due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to - ! Kd_int [Z2 T-1 ~> m2 s-1]. + ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Tadv_flx, & ! advective diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1852,8 +1852,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after set_diffusivity ", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after set_diffusivity ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after set_diffusivity ", tv, G, US) - call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_lay, "after set_diffusivity Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after set_diffusivity Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif @@ -1930,8 +1930,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_state_chksum("after KPP", u, v, h, G, GV, US, haloshift=0) call MOM_forcing_chksum("after KPP", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP", tv, G, US) - call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux endif ! endif for KPP @@ -2301,7 +2301,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracers) then - Tr_ea_BBL = GV%Z_to_H * sqrt(dt*CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -2320,7 +2320,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H**2) * & + add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) @@ -2337,7 +2337,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent @@ -2361,7 +2361,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H**2) / & + add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & h_neglect) else @@ -3090,12 +3090,12 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "A minimal diffusivity that should always be applied to "//& "tracers, especially in massless layers near the bottom. "//& "The default is 0.1*KD.", & - units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.1*Kd*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_BBL_TR", CS%Kd_BBL_tr, & "A bottom boundary layer tracer diffusivity that will "//& "allow for explicitly specified bottom fluxes. The "//& "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& - "over the same distance.", units="m2 s-1", default=0., scale=US%m2_s_to_Z2_T) + "over the same distance.", units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T) endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & @@ -3242,19 +3242,19 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di endif CS%id_Kd_int = register_diag_field('ocean_model', 'Kd_interface', diag%axesTi, Time, & - 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_energetic_PBL) then CS%id_Kd_ePBL = register_diag_field('ocean_model', 'Kd_ePBL', diag%axesTi, Time, & - 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'ePBL diapycnal diffusivity at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif CS%id_Kd_heat = register_diag_field('ocean_model', 'Kd_heat', diag%axesTi, Time, & - 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s, & + 'Total diapycnal diffusivity for heat at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & cmor_field_name='difvho', & cmor_standard_name='ocean_vertical_heat_diffusivity', & cmor_long_name='Ocean vertical heat diffusivity') CS%id_Kd_salt = register_diag_field('ocean_model', 'Kd_salt', diag%axesTi, Time, & - 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=US%Z2_T_to_m2_s, & + 'Total diapycnal diffusivity for salt at interfaces', 'm2 s-1', conversion=GV%HZ_T_to_m2_s, & cmor_field_name='difvso', & cmor_standard_name='ocean_vertical_salt_diffusivity', & cmor_long_name='Ocean vertical salt diffusivity') diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 641816513c..2c2f94519a 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -277,7 +277,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & intent(out) :: Kd_int !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(energetic_PBL_CS), intent(inout) :: CS !< Energetic PBL control structure real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: buoy_flux !< The surface buoyancy flux [Z2 T-3 ~> m2 s-3]. @@ -467,7 +467,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS CS%ML_depth(i,j) = 0.0 endif ; enddo ! Close of i-loop - Note unusual loop order! - do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = GV%Z_to_H*Kd_2d(i,K) ; enddo ; enddo enddo ! j-loop diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index 51a28db0e9..c30f5c2c3f 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -78,10 +78,10 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains ! from the layers above and below. The entrainment rates are proportional to @@ -274,23 +274,23 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (present(Kd_Lay)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (dt * Kd_lay(i,j,k)) + dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) enddo ; enddo if (present(Kd_int)) then do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt * Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo else do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) + dtKd_int(i,K) = GV%Z_to_H * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) enddo ; enddo endif else ! Kd_int must be present, or there already would have been an error. do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H**2 * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) enddo ; enddo dO K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H**2 * (dt * Kd_int(i,j,K)) + dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index a83b36a377..97a34ddbcb 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -79,13 +79,13 @@ module MOM_set_diffusivity real :: cdrag !< quadratic drag coefficient [nondim] real :: IMax_decay !< inverse of a maximum decay scale for !! bottom-drag driven turbulence [Z-1 ~> m-1]. - real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Kd !< interior diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_min !< minimum diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_max !< maximum increment for diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_max !< maximum increment for diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! Set to a negative value to have no limit. real :: Kd_add !< uniform diffusivity added everywhere without - !! filtering or scaling [Z2 T-1 ~> m2 s-1]. + !! filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_smooth !< Vertical diffusivity used to interpolate more !! sensible values of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(diag_ctrl), pointer :: diag => NULL() !< structure to regulate diagnostic output timing @@ -96,7 +96,7 @@ module MOM_set_diffusivity real :: dissip_N0 !< Coefficient a in minimum dissipation = a+b*N [R Z2 T-3 ~> W m-3] real :: dissip_N1 !< Coefficient b in minimum dissipation = a+b*N [R Z2 T-2 ~> J m-3] real :: dissip_N2 !< Coefficient c in minimum dissipation = c*N2 [R Z2 T-1 ~> J s m-3] - real :: dissip_Kd_min !< Minimum Kd [Z2 T-1 ~> m2 s-1], with dissipation Rho0*Kd_min*N^2 + real :: dissip_Kd_min !< Minimum Kd [H Z T-1 ~> m2 s-1 or kg m-1 s-1], with dissipation Rho0*Kd_min*N^2 real :: omega !< Earth's rotation frequency [T-1 ~> s-1] logical :: ML_radiation !< allow a fraction of TKE available from wind work @@ -112,8 +112,8 @@ module MOM_set_diffusivity !! The diapycnal diffusivity is KD(k) = E/(N2(k)+OMEGA2), !! where N2 is the squared buoyancy frequency [T-2 ~> s-2] and OMEGA2 !! is the rotation rate of the earth squared. - real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence - !! radiated from the base of the mixed layer [Z2 T-1 ~> m2 s-1]. + real :: ML_rad_kd_max !< Maximum diapycnal diffusivity due to turbulence radiated from + !! the base of the mixed layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: ML_rad_efold_coeff !< Coefficient to scale penetration depth [nondim] real :: ML_rad_coeff !< Coefficient which scales MSTAR*USTAR^3 to obtain energy !! available for mixing below mixed layer base [nondim] @@ -148,8 +148,8 @@ module MOM_set_diffusivity logical :: simple_TKE_to_Kd !< If true, uses a simple estimate of Kd/TKE that !! does not rely on a layer-formulation. real :: Max_Rrho_salt_fingers !< max density ratio for salt fingering [nondim] - real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [Z2 T-1 ~> m2 s-1] - real :: Kv_molecular !< Molecular viscosity for double diffusive convection [Z2 T-1 ~> m2 s-1] + real :: Max_salt_diff_salt_fingers !< max salt diffusivity for salt fingers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kv_molecular !< Molecular viscosity for double diffusive convection [H Z T-1 ~> m2 s-1 or Pa s] integer :: answer_date !< The vintage of the order of arithmetic and expressions in this module's !! calculations. Values below 20190101 recover the answers from the @@ -178,19 +178,19 @@ module MOM_set_diffusivity type diffusivity_diags real, pointer, dimension(:,:,:) :: & N2_3d => NULL(), & !< squared buoyancy frequency at interfaces [T-2 ~> s-2] - Kd_user => NULL(), & !< user-added diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [Z2 T-1 ~> m2 s-1] + Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] - Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [Z2 T-1 ~> m2 s-1] - KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [Z2 T-1 ~> m2 s-1]. - KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [Z2 T-1 ~> m2 s-1]. + Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] + KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra => NULL(), & !< Double diffusion diffusivity for salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] drho_rat => NULL() !< The density difference ratio used in double diffusion [nondim]. real, pointer, dimension(:,:,:) :: TKE_to_Kd => NULL() !< conversion rate (~1.0 / (G_Earth + dRho_lay)) between TKE !! dissipated within a layer and Kd in that layer - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] end type diffusivity_diags @@ -224,18 +224,22 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !! boundary layer properties and related fields. real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(out) :: Kd_int !< Diapycnal diffusivity at each interface [Z2 T-1 ~> m2 s-1]. + intent(out) :: Kd_int !< Diapycnal diffusivity at each interface + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer [Z2 T-1 ~> m2 s-1]. + optional, intent(out) :: Kd_lay !< Diapycnal diffusivity of each layer + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_extra_T !< The extra diffusivity at interfaces of - !! temperature due to double diffusion relative to - !! the diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! temperature due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & optional, intent(out) :: Kd_extra_S !< The extra diffusivity at interfaces of - !! salinity due to double diffusion relative to - !! the diffusivity of density [Z2 T-1 ~> m2 s-1]. + !! salinity due to double diffusion relative + !! to the diffusivity of density + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables real, dimension(SZI_(G)) :: & @@ -249,19 +253,19 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] - Kd_lay_2d, & !< The layer diffusivities [Z2 T-1 ~> m2 s-1] + Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] maxTKE, & !< Energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer - !< [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)+1) :: & N2_int, & !< squared buoyancy frequency associated at interfaces [T-2 ~> s-2] - Kd_int_2d, & !< The interface diffusivities [Z2 T-1 ~> m2 s-1] - Kv_bkgnd, & !< The background diffusion related interface viscosities [Z2 T-1 ~> m2 s-1] + Kd_int_2d, & !< The interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + Kv_bkgnd, & !< The background diffusion related interface viscosities [H Z T-1 ~> m2 s-1 or Pa s] dRho_int, & !< Locally referenced potential density difference across interfaces [R ~> kg m-3] - KT_extra, & !< Double diffusion diffusivity of temperature [Z2 T-1 ~> m2 s-1] - KS_extra !< Double diffusion diffusivity of salinity [Z2 T-1 ~> m2 s-1] + KT_extra, & !< Double diffusion diffusivity of temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KS_extra !< Double diffusion diffusivity of salinity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: dissip ! local variable for dissipation calculations [Z2 R T-3 ~> W m-3] real :: Omega2 ! squared absolute rotation rate [T-2 ~> s-2] @@ -310,7 +314,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i Kd_int(:,:,:) = CS%Kd if (present(Kd_extra_T)) Kd_extra_T(:,:,:) = 0.0 if (present(Kd_extra_S)) Kd_extra_S(:,:,:) = 0.0 - if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = GV%Z_to_H*CS%Kv + if (associated(visc%Kv_slow)) visc%Kv_slow(:,:,:) = CS%Kv ! Set up arrays for diagnostics. @@ -408,7 +412,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay_2d, Kd_int_2d, Kv_bkgnd, j, G, GV, US, CS%bkgnd_mixing_csp) ! Update Kv and 3-d diffusivity diagnostics. if (associated(visc%Kv_slow)) then ; do K=1,nz+1 ; do i=is,ie - visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + GV%Z_to_H*Kv_bkgnd(i,K) + visc%Kv_slow(i,j,K) = visc%Kv_slow(i,j,K) + Kv_bkgnd(i,K) enddo ; enddo ; endif if (CS%id_Kv_bkgnd > 0) then ; do K=1,nz+1 ; do i=is,ie dd%Kv_bkgnd(i,j,K) = Kv_bkgnd(i,K) @@ -426,12 +430,12 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (KS_extra(i,K) > KT_extra(i,K)) then ! salt fingering Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KT_extra(i,K) Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KT_extra(i,K) - Kd_extra_S(i,j,K) = (KS_extra(i,K) - KT_extra(i,K)) + Kd_extra_S(i,j,K) = KS_extra(i,K) - KT_extra(i,K) Kd_extra_T(i,j,K) = 0.0 elseif (KT_extra(i,K) > 0.0) then ! double-diffusive convection Kd_lay_2d(i,k-1) = Kd_lay_2d(i,k-1) + 0.5 * KS_extra(i,K) Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * KS_extra(i,K) - Kd_extra_T(i,j,K) = (KT_extra(i,K) - KS_extra(i,K)) + Kd_extra_T(i,j,K) = KT_extra(i,K) - KS_extra(i,K) Kd_extra_S(i,j,K) = 0.0 else ! There is no double diffusion at this interface. Kd_extra_T(i,j,K) = 0.0 @@ -474,14 +478,14 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! Add the input turbulent diffusivity. if (CS%useKappaShear .or. CS%use_CVMix_shear) then do K=2,nz ; do i=is,ie - Kd_int_2d(i,K) = GV%H_to_Z*visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) + Kd_int_2d(i,K) = visc%Kd_shear(i,j,K) + 0.5 * (Kd_lay_2d(i,k-1) + Kd_lay_2d(i,k)) enddo ; enddo do i=is,ie - Kd_int_2d(i,1) = GV%H_to_Z*visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. + Kd_int_2d(i,1) = visc%Kd_shear(i,j,1) ! This isn't actually used. It could be 0. Kd_int_2d(i,nz+1) = 0.0 enddo do k=1,nz ; do i=is,ie - Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + GV%H_to_Z*0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) + Kd_lay_2d(i,k) = Kd_lay_2d(i,k) + 0.5 * (visc%Kd_shear(i,j,K) + visc%Kd_shear(i,j,K+1)) enddo ; enddo else do i=is,ie @@ -502,7 +506,6 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) - ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then @@ -525,7 +528,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_int(i,K)), & ! Floor aka Gargett CS%dissip_N2 * N2_int(i,K)) ! Floor of Kd_min*rho0/F_Ri Kd_int_2d(i,K) = max(Kd_int_2d(i,K) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_int(i,K) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_int(i,K) + Omega2)))) enddo ; enddo endif @@ -550,14 +553,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i CS%dissip_N0 + CS%dissip_N1 * sqrt(N2_lay(i,k)), & ! Floor aka Gargett CS%dissip_N2 * N2_lay(i,k)) ! Floor of Kd_min*rho0/F_Ri Kd_lay_2d(i,k) = max(Kd_lay_2d(i,k) , & ! Apply floor to Kd - dissip * (CS%FluxRi_max / (GV%Rho0 * (N2_lay(i,k) + Omega2)))) + dissip * (CS%FluxRi_max / (GV%H_to_RZ * (N2_lay(i,k) + Omega2)))) enddo ; enddo endif if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%Rho0 * Kd_lay_2d(i,k) * N2_lay(i,k) * & - GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 + dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 enddo ; enddo endif @@ -580,13 +582,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (CS%debug) then - if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + if (present(Kd_lay)) call hchksum(Kd_lay, "Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) if (CS%useKappaShear) call hchksum(visc%Kd_shear, "Turbulent Kd", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) if (CS%use_CVMix_ddiff) then - call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) - call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=US%Z2_T_to_m2_s) + call hchksum(Kd_extra_T, "MOM_set_diffusivity: Kd_extra_T", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) + call hchksum(Kd_extra_S, "MOM_set_diffusivity: Kd_extra_S", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) then @@ -602,7 +604,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then - call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=US%Z_to_m*US%s_to_T) + call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=GV%H_to_m*US%s_to_T) endif endif @@ -673,7 +675,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & !! TKE dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer @@ -735,7 +737,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & else; TKE_to_Kd(i,k) = 0.; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of Z3 T-3. + maxTKE(i,k) = hN2pO2 * GV%H_to_Z*CS%Kd_max ! Units of Z3 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -1055,10 +1057,10 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) type(set_diffusivity_CS), pointer :: CS !< Module control structure. real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Kd_T_dd !< Interface double diffusion diapycnal - !! diffusivity for temp [Z2 T-1 ~> m2 s-1]. + !! diffusivity for temp [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: Kd_S_dd !< Interface double diffusion diapycnal - !! diffusivity for saln [Z2 T-1 ~> m2 s-1]. + !! diffusivity for saln [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G)) :: & dRho_dT, & ! partial derivatives of density with respect to temperature [R C-1 ~> kg m-3 degC-1] @@ -1072,7 +1074,7 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) real :: Rrho ! vertical density ratio [nondim] real :: diff_dd ! factor for double-diffusion [nondim] - real :: Kd_dd ! The dominant double diffusive diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_dd ! The dominant double diffusive diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: prandtl ! flux ratio for diffusive convection regime [nondim] real, parameter :: Rrho0 = 1.9 ! limit for double-diffusive density ratio [nondim] @@ -1124,8 +1126,8 @@ subroutine double_diffusion(tv, h, T_f, S_f, j, G, GV, US, CS, Kd_T_dd, Kd_S_dd) end subroutine double_diffusion !> This routine adds diffusion sustained by flow energy extracted by bottom drag. -subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) +subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, & + kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) 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 @@ -1142,20 +1144,21 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & !! boundary layer properties and related fields integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE - !! TKE dissipated within a layer and the + !! TKE dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain !! to its maximum-realizable thickness [Z3 T-3 ~> m3 s-3] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! This routine adds diffusion sustained by flow energy extracted by bottom drag. @@ -1181,7 +1184,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] real :: I_rho0 ! 1 / RHO0 [R-1 ~> m3 kg-1] - real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [Z2 T-1 ~> m2 s-1]. + real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this ! extracted energy also drives diapycnal mixing. @@ -1297,13 +1300,13 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & TKE(i) = TKE(i) - TKE_to_layer - if (Kd_lay(i,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then - delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) + if (Kd_lay(i,k) < GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then delta_Kd = CS%Kd_max Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd else - Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) + Kd_lay(i,k) = GV%Z_to_H*(TKE_to_layer + TKE_Ray) *TKE_to_Kd(i,k) endif Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd @@ -1313,12 +1316,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & endif endif else - if (Kd_lay(i,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then + if (Kd_lay(i,k) >= GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then TKE_here = 0.0 TKE(i) = TKE(i) + TKE_Ray - elseif (Kd_lay(i,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & - maxTKE(i,k) * TKE_to_Kd(i,k)) then - TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + elseif (Kd_lay(i,k) + GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + GV%H_to_Z*Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) TKE(i) = (TKE(i) - TKE_here) + TKE_Ray else TKE_here = TKE_to_layer + TKE_Ray @@ -1327,7 +1330,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? if (TKE_here > 0.0) then - delta_Kd = TKE_here * TKE_to_Kd(i,k) + delta_Kd = GV%Z_to_H*TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd @@ -1377,11 +1380,11 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] real, dimension(SZI_(G),SZK_(GV)+1), & - intent(inout) :: Kd_int !< Interface net diffusivity [Z2 T-1 ~> m2 s-1] + intent(inout) :: Kd_int !< Interface net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure - real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [Z2 T-1 ~> m2 s-1] + real, dimension(:,:,:), pointer :: Kd_BBL !< Interface BBL diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< Layer net diffusivity [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] @@ -1397,8 +1400,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real :: D_minus_z ! distance to interface k from surface [Z ~> m]. real :: total_thickness ! total thickness of water column [Z ~> m]. real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. - real :: Kd_wall ! Law of the wall diffusivity [Z2 T-1 ~> m2 s-1]. - real :: Kd_lower ! diffusivity for lower interface [Z2 T-1 ~> m2 s-1] + real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. real :: I_Rho0 ! 1 / rho0 [R-1 ~> m3 kg-1] real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] @@ -1481,13 +1484,13 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ((CS%von_karm * ustar2) * (z_bot * D_minus_z)) & + Kd_wall = ((GV%Z_to_H*CS%von_karm * ustar2) * (z_bot * D_minus_z)) & / (ustar_D + absf * (z_bot * D_minus_z)) endif ! TKE associated with Kd_wall [Z3 T-3 ~> m3 s-3]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = GV%H_to_Z*Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1526,27 +1529,30 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, type(forcing), intent(in) :: fluxes !< Surface fluxes structure integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE !! TKE dissipated within a layer and the !! diapycnal diffusivity witin that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This routine adds effects of mixed layer radiation to the layer diffusivities. real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. - real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] - real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation [Z2 T-1 ~> m2 s-1]. + real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation + ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: C1_6 ! 1/6 [nondim] real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] @@ -1595,9 +1601,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! a more accurate Taylor series approximations for very thin layers. z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) if (z1 > 1e-5) then - Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) + Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else - Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) + Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) endif Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) @@ -1624,17 +1630,17 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of Z2 T-1 + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 endif else if (z1 > 1e-5) then - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) else - Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) endif endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) @@ -1645,7 +1651,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_mlr TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) - if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then + if (GV%Z_to_H*TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -1995,6 +2001,8 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. real :: vonKar ! The von Karman constant as used for mixed layer viscosity [nondim] + real :: Kd_z ! The background diapycnal diffusivity in [Z2 T-1 ~> m2 s-1] for use + ! in setting the default for other diffusivities. real :: omega_frac_dflt ! The default value for the fraction of the absolute rotation rate ! that is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] @@ -2085,7 +2093,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum diapycnal diffusivity due to turbulence "//& "radiated from the base of the mixed layer. "//& "This is only used if ML_RADIATION is true.", & - units="m2 s-1", default=1.0e-3, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0e-3, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "ML_RAD_COEFF", CS%ML_rad_coeff, & "The coefficient which scales MSTAR*USTAR^3 to obtain "//& "the energy available for mixing below the base of the "//& @@ -2163,7 +2171,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%use_LOTW_BBL_diffusivity = .false. ! This parameterization depends on a u* from viscous BBL endif CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & - 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) @@ -2180,19 +2188,20 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KV", CS%Kv, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & - units="m2 s-1", scale=US%m2_s_to_Z2_T, fail_if_missing=.true.) + units="m2 s-1", scale=GV%m2_s_to_HZ_T, fail_if_missing=.true.) - call get_param(param_file, mdl, "KD", CS%Kd, & + call get_param(param_file, mdl, "KD", Kd_z, & "The background diapycnal diffusivity of density in the "//& "interior. Zero or the molecular value, ~1e-7 m2 s-1, "//& "may be used.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + CS%Kd = (GV%m2_s_to_HZ_T*US%Z2_T_to_m2_s) * Kd_z call get_param(param_file, mdl, "KD_MIN", CS%Kd_min, & "The minimum diapycnal diffusivity.", & - units="m2 s-1", default=0.01*CS%Kd*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.01*Kd_z*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& "diffusivity from TKE-based parameterizations, or a negative "//& - "value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) + "value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) if (CS%simple_TKE_to_Kd) then if (CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: To use SIMPLE_TKE_TO_KD, KD_MAX must be set to >0.") @@ -2205,7 +2214,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "KD_ADD", CS%Kd_add, & "A uniform diapycnal diffusivity that is added "//& "everywhere without any filtering or scaling.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) if (CS%use_LOTW_BBL_diffusivity .and. CS%Kd_max<=0.) call MOM_error(FATAL, & "set_diffusivity_init: KD_MAX must be set (positive) when "// & "USE_LOTW_BBL_DIFFUSIVITY=True.") @@ -2237,21 +2246,21 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ units="J m-3", default=0.0, scale=US%W_m2_to_RZ3_T3*US%Z_to_m*US%s_to_T) call get_param(param_file, mdl, "DISSIPATION_KD_MIN", CS%dissip_Kd_min, & "The minimum vertical diffusivity applied as a floor.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T) CS%limit_dissipation = (CS%dissip_min>0.) .or. (CS%dissip_N1>0.) .or. & (CS%dissip_N0>0.) .or. (CS%dissip_Kd_min>0.) CS%dissip_N2 = 0.0 if (CS%FluxRi_max > 0.0) & - CS%dissip_N2 = CS%dissip_Kd_min * GV%Rho0 / CS%FluxRi_max + CS%dissip_N2 = CS%dissip_Kd_min * GV%H_to_RZ / CS%FluxRi_max CS%id_Kd_bkgnd = register_diag_field('ocean_model', 'Kd_bkgnd', diag%axesTi, Time, & - 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Background diffusivity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_bkgnd = register_diag_field('ocean_model', 'Kv_bkgnd', diag%axesTi, Time, & - 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=US%Z2_T_to_m2_s) + 'Background viscosity added by MOM_bkgnd_mixing module', 'm2/s', conversion=GV%HZ_T_to_m2_s) CS%id_Kd_layer = register_diag_field('ocean_model', 'Kd_layer', diag%axesTL, Time, & - 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Diapycnal diffusivity of layers (as set)', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_tidal_mixing) then CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & @@ -2259,7 +2268,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & - 'Convert TKE to Kd', 's2 m', conversion=US%Z2_T_to_m2_s*(US%m_to_Z**3*US%T_to_s**3)) + 'Convert TKE to Kd', 's2 m', conversion=GV%HZ_T_to_m2_s*(GV%m_to_H*US%m_to_Z**2*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & 'Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2, cmor_field_name='obvfsq', & cmor_long_name='Square of seawater buoyancy frequency', & @@ -2268,7 +2277,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%user_change_diff) & CS%id_Kd_user = register_diag_field('ocean_model', 'Kd_user', diag%axesTi, Time, & - 'User-specified Extra Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'User-specified Extra Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) call get_param(param_file, mdl, "DOUBLE_DIFFUSION", CS%double_diffusion, & "If true, increase diffusivites for temperature or salinity based on the "//& @@ -2281,10 +2290,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ default=2.55, units="nondim") call get_param(param_file, mdl, "MAX_SALT_DIFF_SALT_FINGERS", CS%Max_salt_diff_salt_fingers, & "Maximum salt diffusivity for salt fingering regime.", & - default=1.e-4, units="m2 s-1", scale=US%m2_s_to_Z2_T) + default=1.e-4, units="m2 s-1", scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KV_MOLECULAR", CS%Kv_molecular, & "Molecular viscosity for calculation of fluxes under double-diffusive "//& - "convection.", default=1.5e-6, units="m2 s-1", scale=US%m2_s_to_Z2_T) + "convection.", default=1.5e-6, units="m2 s-1", scale=GV%m2_s_to_HZ_T) ! The default molecular viscosity follows the CCSM4.0 and MOM4p1 defaults. endif ! old double-diffusion @@ -2322,9 +2331,9 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ if (CS%double_diffusion .or. CS%use_CVMix_ddiff) then CS%id_KT_extra = register_diag_field('ocean_model', 'KT_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for temperature', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_KS_extra = register_diag_field('ocean_model', 'KS_extra', diag%axesTi, Time, & - 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Double-diffusive diffusivity for salinity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif if (CS%use_CVMix_ddiff) then CS%id_R_rho = register_diag_field('ocean_model', 'R_rho', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 57fc98834e..33e7a6ddf8 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -43,9 +43,11 @@ module MOM_tidal_mixing !> Containers for tidal mixing diagnostics type, public :: tidal_mixing_diags ; private - real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. - real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation [Z3 T-3 ~> m3 s-3] - real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. + real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation + !! [Z3 T-3 ~> m3 s-3] + real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Lowmode_Work(:,:,:) !< layer integrated work by low mode driven mixing [R Z3 T-3 ~> W m-2] @@ -55,14 +57,14 @@ module MOM_tidal_mixing real, allocatable :: tidal_qe_md(:,:,:) !< Input tidal energy dissipated locally, !! interpolated to model vertical coordinate [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces - !! due to propagating low modes [Z2 T-1 ~> m2 s-1]. + !! due to propagating low modes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] real, allocatable :: TKE_itidal_used(:,:) !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] - real, allocatable :: Polzin_decay_scale_scaled(:,:) !< vertical scale of decay for tidal dissipation [Z ~> m] - real, allocatable :: Polzin_decay_scale(:,:) !< vertical decay scale for tidal dissipation with Polzin [Z ~> m] + real, allocatable :: Polzin_decay_scale_scaled(:,:) !< Vertical scale of decay for tidal dissipation [Z ~> m] + real, allocatable :: Polzin_decay_scale(:,:) !< Vertical decay scale for tidal dissipation with Polzin [Z ~> m] real, allocatable :: Simmons_coeff_2d(:,:) !< The Simmons et al mixing coefficient [nondim] end type @@ -86,7 +88,7 @@ module MOM_tidal_mixing !! for dissipation of the lee waves. Schemes that are !! currently encoded are St Laurent et al (2002) and !! Polzin (2009). - real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m]. + real :: Int_tide_decay_scale !< decay scale for internal wave TKE [Z ~> m] real :: Mu_itides !< efficiency for conversion of dissipation !! to potential energy [nondim] @@ -117,7 +119,7 @@ module MOM_tidal_mixing !! profile in Polzin formulation should not exceed !! Polzin_decay_scale_max_factor * depth of the ocean [nondim]. real :: Polzin_min_decay_scale !< minimum decay scale of the tidal dissipation - !! profile in Polzin formulation [Z ~> m]. + !! profile in Polzin formulation [Z ~> m] real :: TKE_itide_max !< maximum internal tide conversion [R Z3 T-3 ~> W m-2] !! available to mix above the BBL @@ -639,7 +641,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%Lowmode_itidal_dissipation) then CS%id_Kd_itidal = register_diag_field('ocean_model','Kd_itides',diag%axesTi,Time, & - 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Internal Tide Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) if (CS%use_CVMix_tidal) then CS%id_N2_int = register_diag_field('ocean_model','N2_int',diag%axesTi,Time, & @@ -666,7 +668,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%id_Kd_lowmode = register_diag_field('ocean_model','Kd_lowmode',diag%axesTi,Time, & 'Internal Tide Driven Diffusivity (from propagating low modes)', & - 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation', & @@ -708,7 +710,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di 'Lee wave Driven Turbulent Kinetic Energy', & 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_Kd_Niku = register_diag_field('ocean_model','Kd_Nikurashin',diag%axesTi,Time, & - 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Lee Wave Driven Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) endif endif ! S%use_CVMix_tidal endif @@ -737,21 +739,22 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] !! Set this to a negative value to have no limit. real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZK_(GV)+1), & - optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then @@ -779,9 +782,11 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int real, dimension(:,:,:), pointer :: Kv !< The "slow" vertical viscosity at each interface !! (not layer!) [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_lay!< The diapycnal diffusivity in the layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & - optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces [Z2 T-1 ~> m2 s-1]. + optional, intent(inout) :: Kd_int!< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! Local variables real, dimension(SZK_(GV)+1) :: Kd_tidal ! tidal diffusivity [m2 s-1] real, dimension(SZK_(GV)+1) :: Kv_tidal ! tidal viscosity [m2 s-1] @@ -801,7 +806,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! related to the distribution of tidal mixing energy, with unusual array ! extents that are not explained, that is set and used by the CVMix ! tidal mixing schemes, perhaps in [m3 kg-1]? - real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] real :: Simmons_coeff ! A coefficient in the Simmons et al (2004) mixing parameterization [nondim] integer :: i, k, is, ie @@ -862,12 +867,12 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update diffusivity if (present(Kd_lay)) then do k=1,GV%ke - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo endif if (present(Kd_int)) then do K=1,GV%ke+1 - Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + Kd_int(i,K) = Kd_int(i,K) + GV%m2_s_to_HZ_T * Kd_tidal(K) enddo endif ! Update viscosity with the proper unit conversion. @@ -879,7 +884,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T * Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T * Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -963,12 +968,12 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! Update diffusivity if (present(Kd_lay)) then do k=1,GV%ke - Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * US%m2_s_to_Z2_T * (Kd_tidal(k) + Kd_tidal(k+1)) + Kd_lay(i,k) = Kd_lay(i,k) + 0.5 * GV%m2_s_to_HZ_T * (Kd_tidal(k) + Kd_tidal(k+1)) enddo endif if (present(Kd_int)) then do K=1,GV%ke+1 - Kd_int(i,K) = Kd_int(i,K) + (US%m2_s_to_Z2_T * Kd_tidal(K)) + Kd_int(i,K) = Kd_int(i,K) + (GV%m2_s_to_HZ_T * Kd_tidal(K)) enddo endif @@ -981,7 +986,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int ! diagnostics if (allocated(CS%dd%Kd_itidal)) then - CS%dd%Kd_itidal(i,j,:) = US%m2_s_to_Z2_T*Kd_tidal(:) + CS%dd%Kd_itidal(i,j,:) = GV%m2_s_to_HZ_T*Kd_tidal(:) endif if (allocated(CS%dd%N2_int)) then CS%dd%N2_int(i,j,:) = N2_int(i,:) @@ -1029,19 +1034,20 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & !! dissipated within a layer and the !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) - !! [Z2 T-1 / Z3 T-3 = T2 Z-1 ~> s2 m-1] + !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. !! Set this to a negative value to have no limit. real, dimension(SZI_(G),SZK_(GV)), & - optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers [Z2 T-1 ~> m2 s-1] + optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZK_(GV)+1), & optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! local @@ -1054,7 +1060,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] - Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] (BDM) + Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m]. z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z @@ -1067,15 +1073,15 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & - ! fraction of bottom TKE that should appear at top of a layer [nondim] (BDM) + ! fraction of bottom TKE that should appear at top of a layer [nondim] z_from_bot, & ! distance from bottom [Z ~> m]. z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. real :: I_rho0 ! Inverse of the Boussinesq reference density, i.e. 1 / RHO0 [R-1 ~> m3 kg-1] - real :: Kd_add ! diffusivity to add in a layer [Z2 T-1 ~> m2 s-1]. + real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] (BDM) + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. @@ -1309,7 +1315,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*(TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1325,7 +1331,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, CS%dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1423,7 +1429,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, this is just CS%dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k Control structure for user_change_diffusivity type, public :: user_change_diff_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Kd_add !< The scale of a diffusivity that is added everywhere - !! without any filtering or scaling [Z2 T-1 ~> m2 s-1]. + real :: Kd_add !< The scale of a diffusivity that is added everywhere without + !! any filtering or scaling [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: lat_range(4) !< 4 values that define the latitude range over which !! a diffusivity scaled by Kd_add is added [degrees_N]. real :: rho_range(4) !< 4 values that define the coordinate potential @@ -54,17 +54,17 @@ subroutine user_change_diff(h, tv, G, GV, US, CS, Kd_lay, Kd_int, T_f, S_f, Kd_i !! fields. Absent fields have NULL ptrs. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(user_change_diff_CS), pointer :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of - !! each layer [Z2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity - !! at each interface [Z2 T-1 ~> m2 s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(inout) :: Kd_lay !< The diapycnal diffusivity of each + !! layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), optional, intent(inout) :: Kd_int !< The diapycnal diffusivity at each + !! interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: T_f !< Temperature with massless !! layers filled in vertically [C ~> degC]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, intent(in) :: S_f !< Salinity with massless !! layers filled in vertically [S ~> ppt]. real, dimension(:,:,:), optional, pointer :: Kd_int_add !< The diapycnal !! diffusivity that is being added at - !! each interface [Z2 T-1 ~> m2 s-1]. + !! each interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real :: Rcv(SZI_(G),SZK_(GV)) ! The coordinate density in layers [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! An array of tv%P_Ref pressures [R L2 T-2 ~> Pa]. @@ -222,7 +222,7 @@ subroutine user_change_diff_init(Time, G, GV, US, param_file, diag, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USER_KD_ADD", CS%Kd_add, & "A user-specified additional diffusivity over a range of "//& - "latitude and density.", default=0.0, units="m2 s-1", scale=US%m2_s_to_Z2_T) + "latitude and density.", default=0.0, units="m2 s-1", scale=GV%m2_s_to_HZ_T) if (CS%Kd_add /= 0.0) then call get_param(param_file, mdl, "USER_KD_ADD_LAT_RANGE", CS%lat_range(:), & "Four successive values that define a range of latitudes "//& From 359bdcbc833565bcd61a0819427f9b5a6caaabfe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 18 Jul 2023 22:01:37 -0400 Subject: [PATCH 346/629] +*Use [H Z2 T-3 ~> m3 s-3 or W m-2] for TKE units Changed the units for TKE arguments to [H Z2 T-3 ~> m3 s-3 or W m-2] for find_TKE_to_Kd, add_drag_diffusivity, calculate_tidal_mixing and add_int_tide_diffusivity, with similar changes to the units of 21 diagnostics or internal variables in the same routines and in add_LOTW_BBL_diffusivity and add_MLrad_diffusivity. Dozens of unit conversion factors were also cancelled out with these changes, including using that GV%Z_to_H/GV%Rho_0 = GV%RZ_to_H and that GV%Rho_0*GV%H_to_Z = GV%H_to_RZ for both Boussinesq or non-Boussinesq configurations. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode this conversion involves multiplication and division by GV%Rho_0, so while all answers are mathematically equivalent, this change does change answers at roundoff in non-Boussinesq mode unless GV%Rho_0 is chosen to be an integer power of 2. --- .../vertical/MOM_set_diffusivity.F90 | 92 +++++++++---------- .../vertical/MOM_tidal_mixing.F90 | 90 +++++++++--------- 2 files changed, 88 insertions(+), 94 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 97a34ddbcb..4fb0791b8f 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -181,7 +181,7 @@ module MOM_set_diffusivity Kd_user => NULL(), & !< user-added diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_BBL => NULL(), & !< BBL diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_work => NULL(), & !< layer integrated work by diapycnal mixing [R Z3 T-3 ~> W m-2] - maxTKE => NULL(), & !< energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + maxTKE => NULL(), & !< energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] Kd_bkgnd => NULL(), & !< Background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kv_bkgnd => NULL(), & !< Viscosity from background diffusivity at interfaces [H Z T-1 ~> m2 s-1 or Pa s] KT_extra => NULL(), & !< Double diffusion diffusivity for temperature [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -254,7 +254,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - maxTKE, & !< Energy required to entrain to h_max [Z3 T-3 ~> m3 s-3] + maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer !< [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] @@ -676,8 +676,8 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(out) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(out) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer. ! Local variables @@ -737,7 +737,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & else; TKE_to_Kd(i,k) = 0.; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. - maxTKE(i,k) = hN2pO2 * GV%H_to_Z*CS%Kd_max ! Units of Z3 T-3. + maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of H Z2 T-3. enddo ; enddo kb(is:ie) = -1 ! kb should not be used by any code in non-layered mode -AJA return @@ -856,7 +856,7 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & dRho_lay = 0.5 * max(dRho_int(i,K) + dRho_int(i,K+1), 0.0) maxTKE(i,k) = I_dt * (G_IRho0 * & (0.5*max(dRho_int(i,K+1) + dsp1_ds(i,k)*dRho_int(i,K), 0.0))) * & - ((GV%H_to_Z*h(i,j,k) + dh_max) * maxEnt(i,k)) + ((h(i,j,k) + GV%Z_to_H*dh_max) * maxEnt(i,k)) ! TKE_to_Kd should be rho_InSitu / G_Earth * (delta rho_InSitu) ! The omega^2 term in TKE_to_Kd is due to a rescaling of the efficiency of turbulent ! mixing by a factor of N^2 / (N^2 + Omega^2), as proposed by Melet et al., 2013? @@ -1148,8 +1148,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain - !! to its maximum-realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: maxTKE !< The energy required to for a layer to entrain to its + !! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure @@ -1172,18 +1172,17 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! the local ustar, times R0_g [R Z ~> kg m-2] Rho_top, & ! density at top of the BBL [R ~> kg m-3] TKE, & ! turbulent kinetic energy available to drive - ! bottom-boundary layer mixing in a layer [Z3 T-3 ~> m3 s-3] + ! bottom-boundary layer mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. - real :: TKE_to_layer ! TKE used to drive mixing in a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [Z3 T-3 ~> m3 s-3] - real :: TKE_here ! TKE that goes into mixing in this layer [Z3 T-3 ~> m3 s-3] + real :: TKE_to_layer ! TKE used to drive mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_here ! TKE that goes into mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] - real :: I_rho0 ! 1 / RHO0 [R-1 ~> m3 kg-1] real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this @@ -1203,7 +1202,6 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (GV%Rho0) R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1227,10 +1225,10 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, I2decay(i) = 0.5*CS%IMax_decay endif TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - GV%H_to_Z*visc%TKE_BBL(i,j) + visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & - TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * I_Rho0 * & + TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * GV%RZ_to_H * & (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following @@ -1287,7 +1285,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, else ; TKE_to_layer = 0.0 ; endif ! TKE_Ray has been initialized to 0 above. - if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & + if (Rayleigh_drag) TKE_Ray = 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1300,13 +1298,13 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE(i) = TKE(i) - TKE_to_layer - if (Kd_lay(i,k) < GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then - delta_Kd = GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) + if (Kd_lay(i,k) < (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k)) then + delta_Kd = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) - Kd_lay(i,k) if ((CS%Kd_max >= 0.0) .and. (delta_Kd > CS%Kd_max)) then delta_Kd = CS%Kd_max Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd else - Kd_lay(i,k) = GV%Z_to_H*(TKE_to_layer + TKE_Ray) *TKE_to_Kd(i,k) + Kd_lay(i,k) = (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) endif Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * delta_Kd @@ -1316,12 +1314,12 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, endif endif else - if (Kd_lay(i,k) >= GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then + if (Kd_lay(i,k) >= maxTKE(i,k) * TKE_to_Kd(i,k)) then TKE_here = 0.0 TKE(i) = TKE(i) + TKE_Ray - elseif (Kd_lay(i,k) + GV%Z_to_H*(TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & - GV%Z_to_H*maxTKE(i,k) * TKE_to_Kd(i,k)) then - TKE_here = ((TKE_to_layer + TKE_Ray) + GV%H_to_Z*Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) + elseif (Kd_lay(i,k) + (TKE_to_layer + TKE_Ray) * TKE_to_Kd(i,k) > & + maxTKE(i,k) * TKE_to_Kd(i,k)) then + TKE_here = ((TKE_to_layer + TKE_Ray) + Kd_lay(i,k) / TKE_to_Kd(i,k)) - maxTKE(i,k) TKE(i) = (TKE(i) - TKE_here) + TKE_Ray else TKE_here = TKE_to_layer + TKE_Ray @@ -1330,7 +1328,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, if (TKE(i) < 0.0) TKE(i) = 0.0 ! This should be unnecessary? if (TKE_here > 0.0) then - delta_Kd = GV%Z_to_H*TKE_here * TKE_to_Kd(i,k) + delta_Kd = TKE_here * TKE_to_Kd(i,k) if (CS%Kd_max >= 0.0) delta_Kd = min(delta_Kd, CS%Kd_max) Kd_lay(i,k) = Kd_lay(i,k) + delta_Kd Kd_int(i,K) = Kd_int(i,K) + 0.5 * delta_Kd @@ -1387,10 +1385,10 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables - real :: TKE_column ! net TKE input into the column [Z3 T-3 ~> m3 s-3] - real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [Z3 T-3 ~> m3 s-3] - real :: TKE_consumed ! TKE used for mixing in this layer [Z3 T-3 ~> m3 s-3] - real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [Z3 T-3 ~> m3 s-3] + real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [H Z2 T-3 ~> m3 s-3 or W m-2] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] @@ -1403,7 +1401,6 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. - real :: I_Rho0 ! 1 / rho0 [R-1 ~> m3 kg-1] real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. @@ -1419,7 +1416,6 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Determine whether to add Rayleigh drag contribution to TKE Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - I_Rho0 = 1.0 / (GV%Rho0) cdrag_sqrt = sqrt(CS%cdrag) do i=G%isc,G%iec ! Developed in single-column mode @@ -1441,14 +1437,14 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int Idecay = CS%IMax_decay if ((ustar > 0.0) .and. (absf > CS%IMax_decay * ustar)) Idecay = absf / ustar - ! Energy input at the bottom [Z3 T-3 ~> m3 s-3]. + ! Energy input at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. ! (Note that visc%TKE_BBL is in [H Z2 T-3 ~> m3 s-3 or W m-2], set in set_BBL_TKE().) ! I am still unsure about sqrt(cdrag) in this expressions - AJA - TKE_column = cdrag_sqrt * GV%H_to_Z*visc%TKE_BBL(i,j) - ! Add in tidal dissipation energy at the bottom [Z3 T-3 ~> m3 s-3]. + TKE_column = cdrag_sqrt * visc%TKE_BBL(i,j) + ! Add in tidal dissipation energy at the bottom [H Z2 T-3 ~> m3 s-3 or W m-2]. ! Note that TKE_tidal is in [R Z3 T-3 ~> W m-2]. if (associated(fluxes%TKE_tidal)) & - TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * I_Rho0 + TKE_column = TKE_column + fluxes%TKE_tidal(i,j) * GV%RZ_to_H TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column @@ -1466,7 +1462,7 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & - 0.5*CS%BBL_effic * GV%H_to_Z*US%L_to_Z**2 * G%IareaT(i,j) * & + 0.5*CS%BBL_effic * US%L_to_Z**2 * G%IareaT(i,j) * & ((G%areaCu(I-1,j) * visc%Ray_u(I-1,j,k) * u(I-1,j,k)**2 + & G%areaCu(I,j) * visc%Ray_u(I,j,k) * u(I,j,k)**2) + & (G%areaCv(i,J-1) * visc%Ray_v(i,J-1,k) * v(i,J-1,k)**2 + & @@ -1488,9 +1484,9 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int / (ustar_D + absf * (z_bot * D_minus_z)) endif - ! TKE associated with Kd_wall [Z3 T-3 ~> m3 s-3]. + ! TKE associated with Kd_wall [H Z2 T-3 ~> m3 s-3 or W m-2]. ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = GV%H_to_Z*Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1543,7 +1539,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This routine adds effects of mixed layer radiation to the layer diffusivities. real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. - real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [H Z2 T-3 ~> m3 s-3 or W m-2] real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -1587,7 +1583,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 - TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (fluxes%ustar(i,j))) + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (GV%Z_to_H*fluxes%ustar(i,j))) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & @@ -1601,9 +1597,9 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! a more accurate Taylor series approximations for very thin layers. z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) if (z1 > 1e-5) then - Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else - Kd_mlr = GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) + Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (z1 * (1.0 - z1 * (0.5 - C1_6 * z1))) endif Kd_mlr_ml(i) = min(Kd_mlr, CS%ML_rad_kd_max) TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) @@ -1630,17 +1626,17 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 else - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 endif else if (z1 > 1e-5) then - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (1.0 - exp(-z1)) else - Kd_mlr = (GV%Z_to_H*TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) + Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * (z1 * (1.0 - z1 * (0.5 - C1_6*z1))) endif endif Kd_mlr = min(Kd_mlr, CS%ML_rad_kd_max) @@ -1651,7 +1647,7 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_int(i,K+1) = Kd_int(i,K+1) + 0.5 * Kd_mlr TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-z1) - if (GV%Z_to_H*TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then + if (TKE_ml_flux(i) * I_decay(i) < 0.1 * CS%Kd_min * Omega2) then do_i(i) = .false. else ; do_any = .true. ; endif endif ; enddo @@ -2266,7 +2262,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kd_Work = register_diag_field('ocean_model', 'Kd_Work', diag%axesTL, Time, & 'Work done by Diapycnal Mixing', 'W m-2', conversion=US%RZ3_T3_to_W_m2) CS%id_maxTKE = register_diag_field('ocean_model', 'maxTKE', diag%axesTL, Time, & - 'Maximum layer TKE', 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'Maximum layer TKE', 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_TKE_to_Kd = register_diag_field('ocean_model', 'TKE_to_Kd', diag%axesTL, Time, & 'Convert TKE to Kd', 's2 m', conversion=GV%HZ_T_to_m2_s*(GV%m_to_H*US%m_to_Z**2*US%T_to_s**3)) CS%id_N2 = register_diag_field('ocean_model', 'N2', diag%axesTi, Time, & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 33e7a6ddf8..bcbda88fec 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -46,7 +46,7 @@ module MOM_tidal_mixing real, allocatable :: Kd_itidal(:,:,:) !< internal tide diffusivity at interfaces !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_itidal(:,:,:) !< vertical flux of tidal turbulent dissipation - !! [Z3 T-3 ~> m3 s-3] + !! [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable :: Kd_Niku(:,:,:) !< lee-wave diffusivity at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Kd_Niku_work(:,:,:) !< layer integrated work by lee-wave driven mixing [R Z3 T-3 ~> W m-2] real, allocatable :: Kd_Itidal_Work(:,:,:) !< layer integrated work by int tide driven mixing [R Z3 T-3 ~> W m-2] @@ -59,7 +59,7 @@ module MOM_tidal_mixing real, allocatable :: Kd_lowmode(:,:,:) !< internal tide diffusivity at interfaces !! due to propagating low modes [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable :: Fl_lowmode(:,:,:) !< vertical flux of tidal turbulent - !! dissipation due to propagating low modes [Z3 T-3 ~> m3 s-3] + !! dissipation due to propagating low modes [H Z2 T-3 ~> m3 s-3 or W m-2] real, allocatable :: TKE_itidal_used(:,:) !< internal tide TKE input at ocean bottom [R Z3 T-3 ~> W m-2] real, allocatable :: N2_bot(:,:) !< bottom squared buoyancy frequency [T-2 ~> s-2] real, allocatable :: N2_meanz(:,:) !< vertically averaged buoyancy frequency [T-2 ~> s-2] @@ -672,11 +672,11 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%id_Fl_itidal = register_diag_field('ocean_model','Fl_itides',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation', & - 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_Fl_lowmode = register_diag_field('ocean_model','Fl_lowmode',diag%axesTi,Time, & 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & - 'm3 s-3', conversion=(US%Z_to_m**3*US%s_to_T**3)) + 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & @@ -740,8 +740,9 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer to + !! entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes, @@ -1035,8 +1036,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & !! diapycnal diffusivity within that layer, !! usually (~Rho_0 / (G_Earth * dRho_lay)) !! [H Z T-1 / H Z2 T-3 = T2 Z-1 ~> s2 m-1] - real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required to for a layer to entrain - !! to its maximum realizable thickness [Z3 T-3 ~> m3 s-3] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: max_TKE !< The energy required for a layer + !! to entrain to its maximum realizable + !! thickness [H Z2 T-3 ~> m3 s-3 or W m-2] type(tidal_mixing_cs), intent(inout) :: CS !< The control structure for this module real, intent(in) :: Kd_max !< The maximum increment for diapycnal !! diffusivity due to TKE-based processes @@ -1055,9 +1057,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & htot, & ! total thickness above or below a layer, or the ! integrated thickness in the BBL [Z ~> m]. htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. - TKE_itidal_bot, & ! internal tide TKE at ocean bottom [Z3 T-3 ~> m3 s-3] - TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [Z3 T-3 ~> m3 s-3] - TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [Z3 T-3 ~> m3 s-3] (BDM) + TKE_itidal_bot, & ! internal tide TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [H Z2 T-3 ~> m3 s-3 or W m-2] Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] @@ -1067,9 +1069,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) ! z0_Polzin_scaled = z0_Polzin * N2_bot/N2_meanz N2_meanz, & ! vertically averaged squared buoyancy frequency [T-2 ~> s-2] for WKB scaling - TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [Z3 T-3 ~> m3 s-3] - TKE_Niku_rem, & ! remaining lee-wave TKE [Z3 T-3 ~> m3 s-3] - TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [Z3 T-3 ~> m3 s-3] (BDM) + TKE_itidal_rem, & ! remaining internal tide TKE (from barotropic source) [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_Niku_rem, & ! remaining lee-wave TKE [H Z2 T-3 ~> m3 s-3 or W m-2] + TKE_lowmode_rem, & ! remaining internal tide TKE (from propagating low mode source) [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_frac_top, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & @@ -1077,18 +1079,17 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & z_from_bot, & ! distance from bottom [Z ~> m]. z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. - real :: I_rho0 ! Inverse of the Boussinesq reference density, i.e. 1 / RHO0 [R-1 ~> m3 kg-1] real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [Z3 T-3 ~> m3 s-3] - real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [Z3 T-3 ~> m3 s-3] - real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [Z3 T-3 ~> m3 s-3] + real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [H Z2 T-3 ~> m3 s-3 or W m-2] + real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3]. real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. real :: z0_psl ! temporary variable [Z ~> m]. - real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] (BDM) + real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] logical :: use_Polzin, use_Simmons integer :: i, k, is, ie, nz @@ -1102,8 +1103,6 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) enddo ; enddo - I_Rho0 = 1.0 / (GV%Rho0) - use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & (CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09)) .or. & (CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09))) @@ -1114,9 +1113,8 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! Calculate parameters for vertical structure of dissipation ! Simmons: if ( use_Simmons ) then - Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%H_subroundoff*GV%H_to_Z) - Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, & - GV%H_subroundoff*GV%H_to_Z) + Izeta = 1.0 / max(CS%Int_tide_decay_scale, GV%dz_subroundoff) + Izeta_lee = 1.0 / max(CS%Int_tide_decay_scale*CS%Decay_scale_factor_lee, GV%dz_subroundoff) do i=is,ie CS%Nb(i,j) = sqrt(N2_bot(i)) if (allocated(CS%dd%N2_bot)) & @@ -1148,7 +1146,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * GV%H_to_Z * h(i,j,k) enddo ; enddo do i=is,ie - N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%H_subroundoff*GV%H_to_Z) + N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%dz_subroundoff) if (allocated(CS%dd%N2_meanz)) & CS%dd%N2_meanz(i,j) = N2_meanz(i) enddo @@ -1260,11 +1258,11 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) if (allocated(CS%dd%TKE_itidal_used)) & CS%dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) - TKE_itidal_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) + TKE_itidal_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) ! Dissipation of locally trapped lee waves TKE_Niku_bot(i) = 0.0 if (CS%Lee_wave_dissipation) then - TKE_Niku_bot(i) = (I_rho0 * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) + TKE_Niku_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_lee) * CS%TKE_Niku(i,j) endif ! Dissipation of propagating internal tide (baroclinic low modes; rays) (BDM) TKE_lowmode_tot = 0.0 @@ -1272,7 +1270,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (CS%Lowmode_itidal_dissipation) then ! get loss rate due to wave drag on low modes (already multiplied by q) call get_lowmode_loss(i,j,G,CS%int_tide_CSp,"WaveDrag",TKE_lowmode_tot) - TKE_lowmode_bot(i) = CS%Mu_itides * I_rho0 * TKE_lowmode_tot + TKE_lowmode_bot(i) = CS%Mu_itides * GV%RZ_to_H * TKE_lowmode_tot endif ! Vertical energy flux at bottom TKE_itidal_rem(i) = Inv_int(i) * TKE_itidal_bot(i) @@ -1302,7 +1300,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_lay = TKE_lowmode_rem(i) - TKE_lowmode_bot(i)* TKE_frac_top_lowmode(i) ! Actual power expended may be less than predicted if stratification is weak; adjust - if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > (max_TKE(i,k))) then + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay @@ -1315,7 +1313,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*(TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1331,38 +1329,38 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, CS%dd%Kd_itidal is just TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k (max_TKE(i,k))) then - frac_used = (max_TKE(i,k)) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + if (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay > max_TKE(i,k)) then + frac_used = max_TKE(i,k) / (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) TKE_itide_lay = frac_used * TKE_itide_lay TKE_Niku_lay = frac_used * TKE_Niku_lay TKE_lowmode_lay = frac_used * TKE_lowmode_lay @@ -1413,7 +1411,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_lowmode_rem(i) = TKE_lowmode_rem(i) - TKE_lowmode_lay ! Convert power to diffusivity - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*(TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) + Kd_add = TKE_to_Kd(i,k) * (TKE_itide_lay + TKE_Niku_lay + TKE_lowmode_lay) if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (present(Kd_lay)) then @@ -1429,36 +1427,36 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%Kd_itidal)) then ! If at layers, this is just CS%dd%Kd_itidal(i,j,K) = TKE_to_Kd(i,k) * TKE_itide_lay ! The following sets the interface diagnostics. - Kd_add = TKE_to_Kd(i,k) * GV%Z_to_H*TKE_itide_lay + Kd_add = TKE_to_Kd(i,k) * TKE_itide_lay if (Kd_max >= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_itidal(i,j,K) = CS%dd%Kd_itidal(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_Niku(i,j,K) = CS%dd%Kd_Niku(i,j,K) + 0.5*Kd_add if (k= 0.0) Kd_add = min(Kd_add, Kd_max) if (k>1) CS%dd%Kd_lowmode(i,j,K) = CS%dd%Kd_lowmode(i,j,K) + 0.5*Kd_add if (k Date: Wed, 5 Jul 2023 17:36:25 -0400 Subject: [PATCH 347/629] +*Non-Boussinesq Rossby_front initialization Revised the Rossby_front initialization routines to work directly in thickness units and added completely separate algorithms to initialize the Rossby_front thicknesses and velocities consistently when the Boussinesq approximation is not being made. To accommodate this change, error handling was added to detect when the THICKNESS_CONFIG and TS_CONFIG settings are incompatible. As a part of this commit the units of the h arguments to Rossby_front_initialize_thickness and Rossby_front_initialize_temperature_salinity are changed. MAXIMUM_DEPTH is now read in and rescaled via get_param in the Rossby_front routines rather than simply being pulled from the ocean grid type. There are are also changes to the units of 13 internal variables and 14 new internal variables in the Rossby_front routines. Also pass max_depth as a new argument the internal function Hml to replace the use of G%max_depth and permit simpler changes to the units being worked with. All answers are bitwise identical in Boussinesq mode, but there are substantial changes (improvements?) in answers in non-Boussinesq mode that are now independent of the value of the Boussinesq reference density. There are changes to the units of arguments to two publicly visible routines. --- .../MOM_state_initialization.F90 | 29 ++- src/user/Rossby_front_2d_initialization.F90 | 232 ++++++++++++------ 2 files changed, 179 insertions(+), 82 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 802fd33d0f..ef85607db1 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -153,7 +153,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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 + character(len=200) :: config, h_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 :: dt ! The baroclinic dynamics timestep for this run [T ~> s]. @@ -263,7 +263,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & convert = .false. else ! Initialize thickness, h. - call get_param(PF, mdl, "THICKNESS_CONFIG", config, & + call get_param(PF, mdl, "THICKNESS_CONFIG", h_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"//& @@ -294,7 +294,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t rossby_front - a mixed layer front in thermal wind balance.\n"//& " \t USER - call a user modified routine.", & default="uniform", do_not_log=just_read) - select case (trim(config)) + select case (trim(h_config)) case ("file") call initialize_thickness_from_file(dz, depth_tot, G, GV, US, PF, file_has_thickness=.false., & mass_file=.false., just_read=just_read) @@ -344,12 +344,13 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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(dz, G, GV, US, & - PF, just_read=just_read) + case ("rossby_front") + call Rossby_front_initialize_thickness(h, G, GV, US, PF, just_read=just_read) + convert = .false. ! Rossby_front initialization works directly in thickness units. 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)) + "Unrecognized layer thickness configuration "//trim(h_config)) end select ! Initialize temperature and salinity (T and S). @@ -376,6 +377,16 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & " \t USER - call a user modified routine.", & fail_if_missing=new_sim, do_not_log=just_read) ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& + + ! Check for incompatible THICKNESS_CONFIG and TS_CONFIG settings + if (.not.convert) then ; select case (trim(config)) + case ("DOME2D", "ISOMIP", "adjustment2d", "baroclinic_zone", "sloshing", & + "seamount", "dumbbell", "SCM_CVMix_tests", "dense") + call MOM_error(FATAL, "TS_CONFIG = "//trim(config)//" does not work with thicknesses "//& + "that have already been converted to thickness units, as is the case with "//& + "THICKNESS_CONFIG = "//trim(h_config)//".") + end select ; endif + select case (trim(config)) case ("fit"); call initialize_temp_salt_fit(tv%T, tv%S, G, GV, US, PF, & eos, tv%P_Ref, just_read=just_read) @@ -401,8 +412,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & tv%S, dz, G, GV, US, PF, just_read=just_read) case ("dumbbell"); call dumbbell_initialize_temperature_salinity(tv%T, & tv%S, dz, G, GV, US, PF, just_read=just_read) - case ("rossby_front"); call Rossby_front_initialize_temperature_salinity ( tv%T, & - tv%S, dz, G, GV, US, PF, just_read=just_read) + case ("rossby_front") + if (convert .and. .not.just_read) call dz_to_thickness(dz, tv, h, G, GV, US) + 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, dz, & G, GV, US, PF, just_read=just_read) case ("dense"); call dense_water_initialize_TS(G, GV, US, PF, tv%T, tv%S, & diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index 4f213d86d9..b76e69bb44 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -40,21 +40,23 @@ 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 [Z ~> m] + intent(out) :: h !< The thickness that is being initialized [H ~> m or kg m-2] type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. logical, intent(in) :: just_read !< If true, this call will only read !! parameters without changing h. - integer :: i, j, k, is, ie, js, je, nz - real :: Tz ! Vertical temperature gradient [C Z-1 ~> degC m-1] - real :: Dml ! Mixed layer depth [Z ~> m] - real :: eta ! An interface height depth [Z ~> m] + ! Local variables + real :: Tz ! Vertical temperature gradient [C H-1 ~> degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: eta ! An interface height depth [H ~> m or kg m-2] real :: stretch ! A nondimensional stretching factor [nondim] - real :: h0 ! The stretched thickness per layer [Z ~> m] + real :: h0 ! The stretched thickness per layer [H ~> m or kg m-2] real :: T_range ! Range of temperatures over the vertical [C ~> degC] real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -69,40 +71,57 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. - Tz = T_range / G%max_depth - - select case ( coordinateMode(verticalCoordinate) ) - - case (REGRIDDING_LAYER, REGRIDDING_RHO) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) - stretch = ( ( G%max_depth + eta ) / G%max_depth ) - h0 = ( G%max_depth / real(nz) ) * stretch - do k = 1, nz - h(i,j,k) = h0 - enddo - enddo ; enddo - - case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) - do j = G%jsc,G%jec ; do i = G%isc,G%iec - Dml = Hml( G, G%geoLatT(i,j) ) - eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) - stretch = ( ( G%max_depth + eta ) / G%max_depth ) - h0 = ( G%max_depth / real(nz) ) * stretch - do k = 1, nz - h(i,j,k) = h0 - enddo - enddo ; enddo - - case default - call MOM_error(FATAL,"Rossby_front_initialize: "// & - "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") - - end select + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_thickness: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + + Tz = T_range / max_depth + + if (GV%Boussinesq) then + select case ( coordinateMode(verticalCoordinate) ) + + case (REGRIDDING_LAYER, REGRIDDING_RHO) + ! This code is identical to the REGRIDDING_ZSTAR case but probably should not be. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case (REGRIDDING_ZSTAR, REGRIDDING_SIGMA) + do j = G%jsc,G%jec ; do i = G%isc,G%iec + Dml = Hml( G, G%geoLatT(i,j), max_depth ) + ! The free surface height is set so that the bottom pressure gradient is 0. + eta = -( -dRho_dT / GV%Rho0 ) * Tz * 0.5 * ( Dml * Dml ) + stretch = ( ( max_depth + eta ) / max_depth ) + h0 = ( max_depth / real(nz) ) * stretch + do k = 1, nz + h(i,j,k) = h0 + enddo + enddo ; enddo + + case default + call MOM_error(FATAL,"Rossby_front_initialize: "// & + "Unrecognized i.c. setup - set REGRIDDING_COORDINATE_MODE") + + end select + else + ! In non-Boussinesq mode with a flat bottom, the only requirement for no bottom pressure + ! gradient and no abyssal flow is that all columns have the same mass. + h0 = max_depth / real(nz) + do k=1,nz ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + h(i,j,k) = h0 + enddo ; enddo ; enddo + endif end subroutine Rossby_front_initialize_thickness @@ -114,20 +133,22 @@ 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 [Z ~> m] + 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 type(param_file_type), intent(in) :: param_file !< Parameter file handle logical, intent(in) :: just_read !< If true, this call will !! only read parameters without changing T & S. - - integer :: i, j, k, is, ie, js, je, nz + ! Local variables real :: T_ref ! Reference temperature within the surface layer [C ~> degC] 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 [Z ~> m] - real :: dTdz ! Vertical temperature gradient [C Z-1 ~> degC m-1] + real :: zc ! Position of the middle of the cell [H ~> m or kg m-2] + real :: zi ! Bottom interface position relative to the sea surface [H ~> m or kg m-2] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] character(len=40) :: verticalCoordinate + integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -135,24 +156,32 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) - call get_param(param_file, mdl,"T_REF",T_ref,'Reference temperature', & + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) - call get_param(param_file, mdl,"T_RANGE",T_range,'Initial temperature range',& + call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_temperature_salinity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + T(:,:,:) = 0.0 S(:,:,:) = S_ref - dTdz = T_range / G%max_depth + dTdz = T_range / max_depth + ! This sets the temperature to the value at the base of the specified mixed layer + ! depth from a horizontally uniform constant thermal stratification. do j = G%jsc,G%jec ; do i = G%isc,G%iec zi = 0. + Dml = Hml(G, G%geoLatT(i,j), max_depth) do k = 1, nz zi = zi - h(i,j,k) ! Bottom interface position zc = zi - 0.5*h(i,j,k) ! Position of middle of cell - zc = 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 + T(i,j,k) = T_ref + dTdz * min( zc, -Dml ) ! Linear temperature profile below the mixed layer enddo enddo ; enddo @@ -176,13 +205,24 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just !! read parameters without setting u & v. real :: T_range ! Range of temperatures over the vertical [C ~> degC] - real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f [L2 Z-1 T-1 C-1 ~> m s-1 degC-1] + real :: T_ref ! Reference temperature within the surface layer [C ~> degC] + real :: S_ref ! Reference salinity within the surface layer [S ~> ppt] + real :: dUdT ! Factor to convert dT/dy into dU/dz, g*alpha/f with rescaling + ! [L2 H-1 T-1 C-1 ~> m s-1 degC-1 or m4 kg-1 s-1 degC-1] + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] - real :: Dml ! Mixed layer depth [Z ~> m] - real :: zi, zc, zm ! Depths [Z ~> m]. + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + real :: dSpV_dT ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real :: T_here ! The temperature in the middle of a layer [C ~> degC] + real :: dTdz ! Vertical temperature gradient [C H-1 ~> degC m-1 or degC m2 kg-1] + real :: Dml ! Mixed layer depth [H ~> m or kg m-2] + real :: zi, zc, zm ! Depths in thickness units [H ~> m or kg m-2]. real :: f ! The local Coriolis parameter [T-1 ~> s-1] + real :: I_f ! The Adcroft reciprocal of the local Coriolis parameter [T ~> s] real :: Ty ! The meridional temperature gradient [C L-1 ~> degC m-1] - real :: hAtU ! Interpolated layer thickness [Z ~> m]. + real :: hAtU ! Interpolated layer thickness in height units [H ~> m or kg m-2]. + real :: u_int ! The zonal velocity at an interface [L T-1 ~> m s=1] + real :: max_depth ! Maximum depth of the model bathymetry [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz character(len=40) :: verticalCoordinate @@ -192,30 +232,73 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & + default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=.true.) + call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & + units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=.true.) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + units="kg m-3", default=1000.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & - units='kg m-3 degC-1', default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt, do_not_log=.true.) + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. + if (max_depth <= 0.0) call MOM_error(FATAL, & + "Rossby_front_initialize_thickness, Rossby_front_initialize_velocity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + v(:,:,:) = 0.0 u(:,:,:) = 0.0 - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 - f = 0.5* (G%CoriolisBu(I,j) + G%CoriolisBu(I,j-1) ) - dUdT = 0.0 ; if (abs(f) > 0.0) & - dUdT = ( GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) - Dml = Hml( G, G%geoLatT(i,j) ) - Ty = dTdy( G, T_range, G%geoLatT(i,j), US ) - zi = 0. - do k = 1, nz - hAtU = 0.5*(h(i,j,k)+h(i+1,j,k)) * GV%H_to_Z - zi = zi - hAtU ! Bottom interface position - zc = zi - 0.5*hAtU ! Position of middle of cell - zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer - u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML - enddo - enddo ; enddo - + if (GV%Boussinesq) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + dUdT = 0.0 ; if (abs(f) > 0.0) & + dUdT = ( GV%H_to_Z*GV%g_Earth*dRho_dT ) / ( f * GV%Rho0 ) + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = 0. + do k = 1, nz + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zi = zi - hAtU ! Bottom interface position + zc = zi - 0.5*hAtU ! Position of middle of cell + zm = max( zc + Dml, 0. ) ! Height above bottom of mixed layer + u(I,j,k) = dUdT * Ty * zm ! Thermal wind starting at base of ML + enddo + enddo ; enddo + else + ! With an equation of state that is linear in density, the nonlinearies in + ! specific volume require that temperature be calculated for each layer. + + dTdz = T_range / max_depth + + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 + f = 0.5* (G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) + I_f = 0.0 ; if (abs(f) > 0.0) I_f = 1.0 / f + Dml = Hml( G, G%geoLatCu(I,j), max_depth ) + Ty = dTdy( G, T_range, G%geoLatCu(I,j), US ) + zi = -max_depth + u_int = 0.0 ! The velocity at an interface + ! Work upward in non-Boussinesq mode + do k = nz, 1, -1 + hAtU = 0.5 * (h(i,j,k) + h(i+1,j,k)) + zc = zi + 0.5*hAtU ! Position of middle of cell + T_here = T_ref + dTdz * min(zc, -Dml) ! Linear temperature profile below the mixed layer + dSpV_dT = -dRho_dT / (Rho_T0_S0 + (dRho_dS * S_ref + dRho_dT * T_here) )**2 + dUdT = -( GV%H_to_RZ * GV%g_Earth * dSpV_dT ) * I_f + + ! There is thermal wind shear only within the mixed layer. + u(I,j,k) = u_int + dUdT * Ty * min(max((zi + Dml) + 0.5*hAtU, 0.0), 0.5*hAtU) + u_int = u_int + dUdT * Ty * min(max((zi + Dml) + hAtU, 0.0), hAtU) + + zi = zi + hAtU ! Update the layer top interface position + enddo + enddo ; enddo + endif end subroutine Rossby_front_initialize_velocity !> Pseudo coordinate across domain used by Hml() and dTdy() @@ -234,15 +317,16 @@ end function yPseudo !> Analytic prescription of mixed layer depth in 2d Rossby front test, -!! in the same units as G%max_depth (usually [Z ~> m]) -real function Hml( G, lat ) +!! in the same units as max_depth (usually [Z ~> m] or [H ~> m or kg m-2]) +real function Hml( G, lat, max_depth ) type(ocean_grid_type), intent(in) :: G !< Grid structure real, intent(in) :: lat !< Latitude in arbitrary units, often [km] + real, intent(in) :: max_depth !< The maximum depth of the ocean [Z ~> m] or [H ~> m or kg m-2] ! Local - real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] + real :: dHML, HMLmean ! The range and mean of the mixed layer depths [Z ~> m] or [H ~> m or kg m-2] - dHML = 0.5 * ( HMLmax - HMLmin ) * G%max_depth - HMLmean = 0.5 * ( HMLmin + HMLmax ) * G%max_depth + dHML = 0.5 * ( HMLmax - HMLmin ) * max_depth + HMLmean = 0.5 * ( HMLmin + HMLmax ) * max_depth Hml = HMLmean + dHML * sin( yPseudo(G, lat) ) end function Hml From 8f5465be7408746edd2920c42dd7bab4d472a801 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 30 Jul 2023 11:59:30 -0400 Subject: [PATCH 348/629] *Fix logic of an inconsistent initialization test Corrected the logic of a recently added test for inconsistently specified thickness units during the initialization of a new run to only apply to a new run. This was causing an incorrect fatal error with some restart tests. All answers are bitwise identical in cases that worked previously, but it corrects the problem with the restarted cases that had been aborted by the test that was added with the revision to the Rossby_front_2d_initialization code. --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ef85607db1..4ccf5b8bac 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -379,7 +379,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & ! " \t baroclinic_zone - an analytic baroclinic zone. \n"//& ! Check for incompatible THICKNESS_CONFIG and TS_CONFIG settings - if (.not.convert) then ; select case (trim(config)) + if (new_sim .and. (.not.convert)) then ; select case (trim(config)) case ("DOME2D", "ISOMIP", "adjustment2d", "baroclinic_zone", "sloshing", & "seamount", "dumbbell", "SCM_CVMix_tests", "dense") call MOM_error(FATAL, "TS_CONFIG = "//trim(config)//" does not work with thicknesses "//& From 36c1e266b38414b89a759b68952144123d8968dd Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 31 Jul 2023 10:39:17 -0600 Subject: [PATCH 349/629] Make tracer diffusivities 3D This commit adds a vertical dimension to the tracer diffusivities (Kh_u and Kh_v) and associated coefficiets (coef_x and coef_y). The following diagnostics were changed from 2D (lat/lon) to 3D (lat/lon/depth): KhTr_u, KhTr_v, and KhTr_h. To preserve old answers, the values of all modified arrays are depth independent by default. The option to apply the equivalent barotropic structure as the vertical structure of the tracer diffusivity is also introduced and this can be controlled via a new parameter: KHTR_USE_EBT_STRUCT (default is false). --- src/tracer/MOM_tracer_hor_diff.F90 | 196 ++++++++++++++++++++--------- 1 file changed, 136 insertions(+), 60 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 79e99f8bb7..6f4e5d0f90 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -52,6 +52,8 @@ module MOM_tracer_hor_diff real :: max_diff_CFL !< If positive, locally limit the along-isopycnal !! tracer diffusivity to keep the diffusive CFL !! locally at or below this value [nondim]. + logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. logical :: Diffuse_ML_interior !< If true, diffuse along isopycnals between !! the mixed layer and the interior. logical :: check_diffusive_CFL !< If true, automatically iterate the diffusion @@ -135,19 +137,22 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real, dimension(SZI_(G),SZJ_(G)) :: & Ihdxdy, & ! The inverse of the volume or mass of fluid in a layer in a ! grid cell [H-1 L-2 ~> m-3 or kg-1]. - Kh_h, & ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. CFL, & ! A diffusive CFL number for each cell [nondim]. dTr ! The change in a tracer's concentration, in units of concentration [Conc]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: Kh_h + ! The tracer diffusivity averaged to tracer points [L2 T-1 ~> m2 s-1]. real, dimension(SZIB_(G),SZJ_(G)) :: & - khdt_x, & ! The value of Khtr*dt times the open face width divided by + khdt_x ! The value of Khtr*dt times the open face width divided by ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G)) :: & + khdt_y ! The value of Khtr*dt times the open face width divided by + ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & Coef_x, & ! The coefficients relating zonal tracer differences to time-integrated ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_u ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. - real, dimension(SZI_(G),SZJB_(G)) :: & - khdt_y, & ! The value of Khtr*dt times the open face width divided by - ! the distance between adjacent tracer points [L2 ~> m2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & Coef_y, & ! The coefficients relating meridional tracer differences to time-integrated ! fluxes, in [L2 ~> m2] for some schemes and [H L2 ~> m3 or kg] for others. Kh_v ! Tracer mixing coefficient at u-points [L2 T-1 ~> m2 s-1]. @@ -224,12 +229,12 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) if (Resoln_scaled) & Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity Rd_dx=0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i+1,j) ) ! Rd/dx at u-points - Kh_loc = Kh_u(I,j)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + Kh_loc = Kh_u(I,j,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_u(I,j) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + Kh_u(I,j,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min endif enddo ; enddo !$OMP parallel do default(shared) private(Kh_loc,Rd_dx) @@ -241,41 +246,41 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) if (Resoln_scaled) & Kh_loc = Kh_loc * 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) if (CS%KhTr_passivity_coeff>0.) then ! Apply passivity Rd_dx = 0.5*( VarMix%Rd_dx_h(i,j)+VarMix%Rd_dx_h(i,j+1) ) ! Rd/dx at v-points - Kh_loc = Kh_v(i,J)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) + Kh_loc = Kh_v(i,J,1)*max( CS%KhTr_passivity_min, CS%KhTr_passivity_coeff*Rd_dx ) if (CS%KhTr_max > 0.) Kh_loc = min(Kh_loc, CS%KhTr_max) ! Re-apply max - Kh_v(i,J) = max(Kh_loc, CS%KhTr_min) ! Re-apply min + Kh_v(i,J,1) = max(Kh_loc, CS%KhTr_min) ! Re-apply min endif enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - khdt_x(I,j) = dt*(Kh_u(I,j)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + khdt_x(I,j) = dt*(Kh_u(I,j,1)*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - khdt_y(i,J) = dt*(Kh_v(i,J)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + khdt_y(i,J) = dt*(Kh_v(i,J,1)*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo elseif (Resoln_scaled) then !$OMP parallel do default(shared) private(Res_fn) do j=js,je ; do I=is-1,ie Res_fn = 0.5 * (VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i+1,j)) - Kh_u(I,j) = max(CS%KhTr * Res_fn, CS%KhTr_min) + Kh_u(I,j,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) * Res_fn enddo ; enddo !$OMP parallel do default(shared) private(Res_fn) do J=js-1,je ; do i=is,ie Res_fn = 0.5*(VarMix%Res_fn_h(i,j) + VarMix%Res_fn_h(i,j+1)) - Kh_v(i,J) = max(CS%KhTr * Res_fn, CS%KhTr_min) + Kh_v(i,J,1) = max(CS%KhTr * Res_fn, CS%KhTr_min) khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) * Res_fn enddo ; enddo else ! Use a simple constant diffusivity. if (CS%id_KhTr_u > 0) then !$OMP parallel do default(shared) do j=js,je ; do I=is-1,ie - Kh_u(I,j) = CS%KhTr + Kh_u(I,j,1) = CS%KhTr khdt_x(I,j) = dt*(CS%KhTr*(G%dy_Cu(I,j)*G%IdxCu(I,j))) enddo ; enddo else @@ -287,7 +292,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (CS%id_KhTr_v > 0) then !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie - Kh_v(i,J) = CS%KhTr + Kh_v(i,J,1) = CS%KhTr khdt_y(i,J) = dt*(CS%KhTr*(G%dx_Cv(i,J)*G%IdyCv(i,J))) enddo ; enddo else @@ -306,7 +311,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_x(I,j) > khdt_max) then khdt_x(I,j) = khdt_max if (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j)) > 0.0) & - Kh_u(I,j) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) + Kh_u(I,j,1) = khdt_x(I,j) / (dt*(G%dy_Cu(I,j)*G%IdxCu(I,j))) endif enddo ; enddo else @@ -323,7 +328,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (khdt_y(i,J) > khdt_max) then khdt_y(i,J) = khdt_max if (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J)) > 0.0) & - Kh_v(i,J) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) + Kh_v(i,J,1) = khdt_y(i,J) / (dt*(G%dx_Cv(i,J)*G%IdyCv(i,J))) endif enddo ; enddo else @@ -393,14 +398,36 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) - do J=js-1,je ; do i=is,ie - Coef_y(i,J) = I_numitts * khdt_y(i,J) - enddo ; enddo - do j=js,je - do I=is-1,ie - Coef_x(I,j) = I_numitts * khdt_x(I,j) + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo enddo enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo + enddo + enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + do k=2,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif do itt=1,num_itts if (CS%show_call_tree) call callTree_waypoint("Calling horizontal boundary diffusion (tracer_hordiff)",itt) @@ -426,14 +453,37 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online else call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) endif - do J=js-1,je ; do i=is,ie - Coef_y(i,J) = I_numitts * khdt_y(i,J) - enddo ; enddo - do j=js,je - do I=is-1,ie - Coef_x(I,j) = I_numitts * khdt_x(I,j) + + do k=1,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = I_numitts * khdt_y(i,J) + enddo + enddo + enddo + do k=1,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = I_numitts * khdt_x(I,j) + enddo enddo enddo + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Coef_y(i,J,K) = Coef_y(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + do k=2,nz+1 + do j=js,je + do I=is-1,ie + Coef_x(I,j,K) = Coef_x(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif do itt=1,num_itts if (CS%show_call_tree) call callTree_waypoint("Calling neutral diffusion (tracer_hordiff)",itt) @@ -467,13 +517,13 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online endif do J=js-1,je ; do i=is,ie - Coef_y(i,J) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & + Coef_y(i,J,1) = ((scale * khdt_y(i,J))*2.0*(h(i,j,k)*h(i,j+1,k))) / & (h(i,j,k)+h(i,j+1,k)+h_neglect) enddo ; enddo do j=js,je do I=is-1,ie - Coef_x(I,j) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & + Coef_x(I,j,1) = ((scale * khdt_x(I,j))*2.0*(h(i,j,k)*h(i+1,j,k))) / & (h(i,j,k)+h(i+1,j,k)+h_neglect) enddo @@ -485,25 +535,25 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online do m=1,ntr do j=js,je ; do i=is,ie dTr(i,j) = Ihdxdy(i,j) * & - ((Coef_x(I-1,j) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - & - Coef_x(I,j) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + & - (Coef_y(i,J-1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - & - Coef_y(i,J) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) + ((Coef_x(I-1,j,1) * (Reg%Tr(m)%t(i-1,j,k) - Reg%Tr(m)%t(i,j,k)) - & + Coef_x(I,j,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k))) + & + (Coef_y(i,J-1,1) * (Reg%Tr(m)%t(i,j-1,k) - Reg%Tr(m)%t(i,j,k)) - & + Coef_y(i,J,1) * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)))) enddo ; enddo if (associated(Reg%Tr(m)%df_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j) & + Reg%Tr(m)%df_x(I,j,k) = Reg%Tr(m)%df_x(I,j,k) + Coef_x(I,j,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J) & + Reg%Tr(m)%df_y(i,J,k) = Reg%Tr(m)%df_y(i,J,k) + Coef_y(i,J,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_x)) then ; do j=js,je ; do I=G%IscB,G%IecB - Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j) & + Reg%Tr(m)%df2d_x(I,j) = Reg%Tr(m)%df2d_x(I,j) + Coef_x(I,j,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i+1,j,k)) * Idt enddo ; enddo ; endif if (associated(Reg%Tr(m)%df2d_y)) then ; do J=G%JscB,G%JecB ; do i=is,ie - Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J) & + Reg%Tr(m)%df2d_y(i,J) = Reg%Tr(m)%df2d_y(i,J) + Coef_y(i,J,1) & * (Reg%Tr(m)%t(i,j,k) - Reg%Tr(m)%t(i,j+1,k)) * Idt enddo ; enddo ; endif do j=js,je ; do i=is,ie @@ -542,43 +592,65 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! post diagnostics for 2d tracer diffusivity if (CS%id_KhTr_u > 0) then do j=js,je ; do I=is-1,ie - Kh_u(I,j) = G%mask2dCu(I,j)*Kh_u(I,j) + Kh_u(I,j,:) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo - call post_data(CS%id_KhTr_u, Kh_u, CS%diag, mask=G%mask2dCu) + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do j=js,je + do I=is-1,ie + Kh_u(I,j,K) = Kh_u(I,j,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i+1,j,k-1) ) + enddo + enddo + enddo + endif + !call post_data(CS%id_KhTr_u, Kh_u, CS%diag, is_static=.false., mask=G%mask2dCu) + call post_data(CS%id_KhTr_u, Kh_u, CS%diag) endif if (CS%id_KhTr_v > 0) then do J=js-1,je ; do i=is,ie - Kh_v(i,J) = G%mask2dCv(i,J)*Kh_v(i,J) + Kh_v(i,J,:) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo - call post_data(CS%id_KhTr_v, Kh_v, CS%diag, mask=G%mask2dCv) + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + do J=js-1,je + do i=is,ie + Kh_v(i,J,K) = Kh_v(i,J,1) * 0.5 * ( VarMix%ebt_struct(i,j,k-1) + VarMix%ebt_struct(i,j+1,k-1) ) + enddo + enddo + enddo + endif + !call post_data(CS%id_KhTr_v, Kh_v, CS%diag, is_static=.false., mask=G%mask2dCv) + call post_data(CS%id_KhTr_v, Kh_v, CS%diag) endif if (CS%id_KhTr_h > 0) then - Kh_h(:,:) = 0.0 + Kh_h(:,:,:) = 0.0 do j=js,je ; do I=is-1,ie - Kh_u(I,j) = G%mask2dCu(I,j)*Kh_u(I,j) + Kh_u(I,j,1) = G%mask2dCu(I,j)*Kh_u(I,j,1) enddo ; enddo do J=js-1,je ; do i=is,ie - Kh_v(i,J) = G%mask2dCv(i,J)*Kh_v(i,J) + Kh_v(i,J,1) = G%mask2dCv(i,J)*Kh_v(i,J,1) enddo ; enddo + do j=js,je ; do i=is,ie normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) - Kh_h(i,j) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j)+Kh_u(I,j)) + & - (Kh_v(i,J-1)+Kh_v(i,J))) + Kh_h(i,j,:) = normalize*G%mask2dT(i,j)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + (Kh_v(i,J-1,1)+Kh_v(i,J,1))) + if (CS%KhTh_use_ebt_struct) then + do K=2,nz+1 + Kh_h(i,j,K) = normalize*G%mask2dT(i,j)*VarMix%ebt_struct(i,j,k-1)*((Kh_u(I-1,j,1)+Kh_u(I,j,1)) + & + (Kh_v(i,J-1,1)+Kh_v(i,J,1))) + enddo + endif enddo ; enddo - call post_data(CS%id_KhTr_h, Kh_h, CS%diag, mask=G%mask2dT) + !call post_data(CS%id_KhTr_h, Kh_h, CS%diag, is_static=.false., mask=G%mask2dT) + call post_data(CS%id_KhTr_h, Kh_h, CS%diag) endif - if (CS%debug) then call uvchksum("After tracer diffusion khdt_[xy]", khdt_x, khdt_y, & G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & scalar_pair=.true.) - if (CS%use_neutral_diffusion) then - call uvchksum("After tracer diffusion Coef_[xy]", Coef_x, Coef_y, & - G%HI, haloshift=0, symmetric=.true., scale=US%L_to_m**2, & - scalar_pair=.true.) - endif endif if (CS%id_khdt_x > 0) call post_data(CS%id_khdt_x, khdt_x, CS%diag) @@ -1489,6 +1561,10 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic call get_param(param_file, mdl, "KHTR", CS%KhTr, & "The background along-isopycnal tracer diffusivity.", & units="m2 s-1", default=0.0, scale=US%m_to_L**2*US%T_to_s) + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.) call get_param(param_file, mdl, "KHTR_SLOPE_CFF", CS%KhTr_Slope_Cff, & "The scaling coefficient for along-isopycnal tracer "//& "diffusivity using a shear-based (Visbeck-like) "//& @@ -1558,11 +1634,11 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic CS%id_KhTr_h = -1 CS%id_CFL = -1 - CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCu1, Time, & + CS%id_KhTr_u = register_diag_field('ocean_model', 'KHTR_u', diag%axesCui, Time, & 'Epipycnal tracer diffusivity at zonal faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCv1, Time, & + CS%id_KhTr_v = register_diag_field('ocean_model', 'KHTR_v', diag%axesCvi, Time, & 'Epipycnal tracer diffusivity at meridional faces of tracer cell', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T) - CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesT1, Time, & + CS%id_KhTr_h = register_diag_field('ocean_model', 'KHTR_h', diag%axesTi, Time, & 'Epipycnal tracer diffusivity at tracer cell center', 'm2 s-1', conversion=US%L_to_m**2*US%s_to_T, & cmor_field_name='diftrelo', & cmor_standard_name= 'ocean_tracer_epineutral_laplacian_diffusivity', & From a588033727ea2e366d3893fe7670b1cda16cb03e Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 31 Jul 2023 10:53:07 -0600 Subject: [PATCH 350/629] Make HBD work with 3D diffusivities Following up on the previous commit, where a vertical dimension was added to the tracer diffusivities, this commit modifies the HBD module to work with this change. To do so, parameter khtr_u (diffusivity times the time step) is calculated at cell centers and then remapped onto the HBD vertical grid. All unit tests in this module were updated to conform with this change. This commit also makes the default value of HBD_DEBUG equal to the value set for DEBUG. --- src/tracer/MOM_hor_bnd_diffusion.F90 | 81 ++++++++++++++++------------ 1 file changed, 47 insertions(+), 34 deletions(-) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index b89552e8e4..4f6f198ff8 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -88,6 +88,7 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba ! local variables character(len=80) :: string ! Temporary strings logical :: boundary_extrap ! controls if boundary extrapolation is used in the HBD code + logical :: debug !< If true, write verbose checksums for debugging purposes if (ASSOCIATED(CS)) then call MOM_error(FATAL, "hor_bnd_diffusion_init called with associated control structure.") @@ -145,9 +146,10 @@ logical function hor_bnd_diffusion_init(Time, G, GV, US, param_file, diag, diaba call initialize_remapping( CS%remap_CS, string, boundary_extrapolation = boundary_extrap ,& check_reconstruction=.false., check_remapping=.false.) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "HBD_DEBUG", CS%debug, & "If true, write out verbose debugging data in the HBD module.", & - default=.false.) + default=debug) id_clock_hbd = cpu_clock_id('(Ocean HBD)', grain=CLOCK_MODULE) @@ -160,17 +162,16 @@ end function hor_bnd_diffusion_init !! 3) remap fluxes to the native grid !! 4) update tracer by adding the divergence of F subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) - type(ocean_grid_type), intent(inout) :: 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(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts - !! (I_numitts in tracer_hordiff) [T ~> s] - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(hbd_CS), pointer :: CS !< Control structure for this module + type(ocean_grid_type), intent(inout) :: 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(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts + !! (I_numitts in tracer_hordiff) [T ~> s] + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(hbd_CS), pointer :: CS !< Control structure for this module ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] @@ -224,9 +225,9 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) do j=G%jsc,G%jec do i=G%isc-1,G%iec if (G%mask2dCu(I,j)>0.) then - call fluxes_layer_method(SURFACE, G%ke, hbl(I,j), hbl(I+1,j), & + call fluxes_layer_method(SURFACE, GV%ke, hbl(I,j), hbl(I+1,j), & h(I,j,:), h(I+1,j,:), tracer%t(I,j,:), tracer%t(I+1,j,:), & - Coef_x(I,j), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & + Coef_x(I,j,:), uFlx(I,j,:), G%areaT(I,j), G%areaT(I+1,j), CS%hbd_u_kmax(I,j), & CS%hbd_grd_u(I,j,:), CS) endif enddo @@ -236,7 +237,7 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) if (G%mask2dCv(i,J)>0.) then call fluxes_layer_method(SURFACE, GV%ke, hbl(i,J), hbl(i,J+1), & h(i,J,:), h(i,J+1,:), tracer%t(i,J,:), tracer%t(i,J+1,:), & - Coef_y(i,J), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & + Coef_y(i,J,:), vFlx(i,J,:), G%areaT(i,J), G%areaT(i,J+1), CS%hbd_v_kmax(i,J), & CS%hbd_grd_v(i,J,:), CS) endif enddo @@ -667,8 +668,8 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real, dimension(ke), intent(in ) :: h_R !< Thicknesses in the native grid (right) [H ~> m or kg m-2] real, dimension(ke), intent(in ) :: phi_L !< Tracer values in the native grid (left) [conc] real, dimension(ke), intent(in ) :: phi_R !< Tracer values in the native grid (right) [conc] - real, intent(in ) :: khtr_u !< Horizontal diffusivities times the time step - !! at a velocity point [L2 ~> m2] + real, dimension(ke+1),intent(in ) :: khtr_u !< Horizontal diffusivities times the time step + !! at a velocity point and vertical interfaces [L2 ~> m2] real, dimension(ke), intent( out) :: F_layer !< Layerwise diffusive flux at U- or V-point !! in the native grid [H L2 conc ~> m3 conc] real, intent(in ) :: area_L !< Area of the horizontal grid (left) [L2 ~> m2] @@ -681,10 +682,12 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real, allocatable :: phi_L_z(:) !< Tracer values in the ztop grid (left) [conc] real, allocatable :: phi_R_z(:) !< Tracer values in the ztop grid (right) [conc] real, allocatable :: F_layer_z(:) !< Diffusive flux at U/V-point in the ztop grid [H L2 conc ~> m3 conc] - real :: h_vel(ke) !< Thicknesses at u- and v-points in the native grid + real, allocatable :: khtr_ul_z(:) !< khtr_u at layer centers in the ztop grid [H L2 conc ~> m3 conc] + real, dimension(ke) :: h_vel !< Thicknesses at u- and v-points in the native grid !! The harmonic mean is used to avoid zero values [H ~> m or kg m-2] + real, dimension(ke) :: khtr_ul !< khtr_u at the vertical layer of the native grid [L2 ~> m2] real :: htot !< Total column thickness [H ~> m or kg m-2] - integer :: k + integer :: k !< Index used in the vertical direction integer :: k_bot_min !< Minimum k-index for the bottom integer :: k_bot_max !< Maximum k-index for the bottom integer :: k_bot_diff !< Difference between bottom left and right k-indices @@ -695,11 +698,12 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ real :: zeta_bot_L, zeta_bot_R !< distance from the bottom of a layer to the boundary !! layer depth in the native grid [nondim] real :: wgt !< weight to be used in the linear transition to the interior [nondim] - real :: a !< coefficient to be used in the linear transition to the interior [nondim] + real :: a !< coefficient used in the linear transition to the interior [nondim] real :: tmp1, tmp2 !< dummy variables [H ~> m or kg m-2] real :: htot_max !< depth below which no fluxes should be applied [H ~> m or kg m-2] F_layer(:) = 0.0 + khtr_ul(:) = 0.0 if (hbl_L == 0. .or. hbl_R == 0.) then return endif @@ -708,6 +712,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ allocate(phi_L_z(nk), source=0.0) allocate(phi_R_z(nk), source=0.0) allocate(F_layer_z(nk), source=0.0) + allocate(khtr_ul_z(nk), source=0.0) ! remap tracer to dz_top call remapping_core_h(CS%remap_cs, ke, h_L(:), phi_L(:), nk, dz_top(:), phi_L_z(:), & @@ -715,6 +720,18 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ call remapping_core_h(CS%remap_cs, ke, h_R(:), phi_R(:), nk, dz_top(:), phi_R_z(:), & CS%H_subroundoff, CS%H_subroundoff) + ! thicknesses at velocity points & khtr_u at layer centers + do k = 1,ke + h_vel(k) = harmonic_mean(h_L(k), h_R(k)) + ! GMM, writting 0.5 * (A(k) + A(k+1)) as A(k) + 0.5 * (A(k+1) - A(k)) to recover + ! answers with depth-independent khtr + khtr_ul(k) = khtr_u(k) + 0.5 * (khtr_u(k+1) - khtr_u(k)) + enddo + + ! remap khtr_ul to khtr_ul_z + call remapping_core_h(CS%remap_cs, ke, h_vel(:), khtr_ul(:), nk, dz_top(:), khtr_ul_z(:), & + CS%H_subroundoff, CS%H_subroundoff) + ! Calculate vertical indices containing the boundary layer in dz_top call boundary_k_range(boundary, nk, dz_top, hbl_L, k_top_L, zeta_top_L, k_bot_L, zeta_bot_L) call boundary_k_range(boundary, nk, dz_top, hbl_R, k_top_R, zeta_top_R, k_bot_R, zeta_bot_R) @@ -728,7 +745,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ if ((CS%linear) .and. (k_bot_diff > 1)) then ! apply linear decay at the base of hbl do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo @@ -741,14 +758,14 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ htot = 0. do k = k_bot_min+1,k_bot_max, 1 wgt = (a*(htot + (dz_top(k) * 0.5))) + 1.0 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) * wgt + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) * wgt htot = htot + dz_top(k) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo else do k = k_bot_min,1,-1 - F_layer_z(k) = -(dz_top(k) * khtr_u) * (phi_R_z(k) - phi_L_z(k)) + F_layer_z(k) = -(dz_top(k) * khtr_ul_z(k)) * (phi_R_z(k) - phi_L_z(k)) if (CS%limiter_remap) call flux_limiter(F_layer_z(k), area_L, area_R, phi_L_z(k), & phi_R_z(k), dz_top(k), dz_top(k)) enddo @@ -757,11 +774,6 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ !GMM, TODO: boundary == BOTTOM - ! thicknesses at velocity points - do k = 1,ke - h_vel(k) = harmonic_mean(h_L(k), h_R(k)) - enddo - ! remap flux to h_vel (native grid) call reintegrate_column(nk, dz_top(:), F_layer_z(:), ke, h_vel(:), F_layer(:)) @@ -792,6 +804,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ deallocate(phi_L_z) deallocate(phi_R_z) deallocate(F_layer_z) + deallocate(khtr_ul_z) end subroutine fluxes_layer_method @@ -805,7 +818,7 @@ logical function near_boundary_unit_tests( verbose ) real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] - real :: khtr_u ! Horizontal diffusivities at U-point [m2 s-1] + real, dimension(nk+1) :: khtr_u ! Horizontal diffusivities at U-point and interfaces[m2 s-1] real :: hbl_L, hbl_R ! Depth of the boundary layer (left and right) [m] real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] character(len=120) :: test_name ! Title of the unit test @@ -983,7 +996,7 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 2.; hbl_R = 2. h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/0.,0./) ; phi_R = (/1.,1./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) @@ -994,7 +1007,7 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 2.; hbl_R = 2. h_L = (/2.,2./) ; h_R = (/2.,2./) phi_L = (/2.,1./) ; phi_R = (/1.,1./) - khtr_u = 0.5 + khtr_u = (/0.5,0.5,0.5/) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) @@ -1005,7 +1018,7 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 2; hbl_R = 2 h_L = (/1.,2./) ; h_R = (/1.,2./) phi_L = (/0.,0./) ; phi_R = (/0.5,2./) - khtr_u = 2. + khtr_u = (/2.,2.,2./) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) @@ -1016,7 +1029,7 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 12; hbl_R = 20 h_L = (/6.,6./) ; h_R = (/10.,10./) phi_L = (/1.,1./) ; phi_R = (/1.,1./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) @@ -1028,7 +1041,7 @@ logical function near_boundary_unit_tests( verbose ) hbl_L = 15; hbl_R = 10. h_L = (/10.,5./) ; h_R = (/10.,0./) phi_L = (/1.,1./) ; phi_R = (/0.,0./) - khtr_u = 1. + khtr_u = (/1.,1.,1./) call hbd_grid_test(SURFACE, hbl_L, hbl_R, h_L, h_R, CS) call fluxes_layer_method(SURFACE, nk, hbl_L, hbl_R, h_L, h_R, phi_L, phi_R, & khtr_u, F_layer, 1., 1., CS%hbd_u_kmax(1,1), CS%hbd_grd_u(1,1,:), CS) From 27518f750f83697c97b4caee718314856cae259f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Mon, 31 Jul 2023 11:17:34 -0600 Subject: [PATCH 351/629] Make neutral diffusion work with 3D diffusivities This commit modifies the neutral diffusion module to work with 3D diffusivities. When the diffusivities are depth dependent (KHTR_USE_EBT_STRUCT=True), a new array (Coef_h, with values at tracer points and at vertical interfaces) with a four-point average between Coef_x and Coef_y is introduced. This array is then used to calculate zonal and meridional neutral fluxes via optional arguments and using an existing four-point average (vertical interfaces of two tracer cells) inside subroutine neutral_surface_flux. The same approach is already used when tapering the neutral diffusive fluxes. In this case, however, the unit of the output from neutral_surface_flux (Flx) is modified because the flux of the tracer between pairs of neutral layers is multiplied by the average of Coef_h. To avoid double counting Coef_h, the code block for updating the tracer concentration from divergence of neutral diffusive flux components also had to be modified for when KHTR_USE_EBT_STRUCT=True. Similar for diagnostics trans_x_2d and trans_y_2d. This commit also makes the default value of NDIFF_DEBUG equal to the value set for DEBUG. --- src/tracer/MOM_neutral_diffusion.F90 | 370 +++++++++++++++++++-------- 1 file changed, 261 insertions(+), 109 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index ee2d5e6a03..3b777c1453 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -56,6 +56,8 @@ module MOM_neutral_diffusion logical :: tapering = .false. !< If true, neutral diffusion linearly decays towards zero within a !! transition zone defined using boundary layer depths. Only available when !! interior_only=true. + logical :: KhTh_use_ebt_struct !< If true, uses the equivalent barotropic structure + !! as the vertical structure of tracer diffusivity. logical :: use_unmasked_transport_bug !< If true, use an older form for the accumulation of !! neutral-diffusion transports that were unmasked, as used prior to Jan 2018. real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] @@ -64,6 +66,8 @@ module MOM_neutral_diffusion !! at cell interfaces real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, !! at cell interfaces + ! Array used when KhTh_use_ebt_struct is true + real, allocatable, dimension(:,:,:) :: Coef_h !< Coef_x and Coef_y averaged at t-points [L2 ~> m2] ! Positions of neutral surfaces in both the u, v directions real, allocatable, dimension(:,:,:) :: uPoL !< Non-dimensional position with left layer uKoL-1, u-point [nondim] real, allocatable, dimension(:,:,:) :: uPoR !< Non-dimensional position with right layer uKoR-1, u-point [nondim] @@ -136,13 +140,15 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - character(len=80) :: string ! Temporary strings + character(len=80) :: string ! Temporary strings integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the answers for remapping from the end of 2018. - ! Otherwise, use more robust forms of the same expressions. - logical :: boundary_extrap + logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that + ! recover the answers for remapping from the end of 2018. + ! Otherwise, use more robust forms of the same expressions. + logical :: debug ! If true, write verbose checksums for debugging purposes. + logical :: boundary_extrap ! Indicate whether high-order boundary + !! extrapolation should be used within boundary cells. if (associated(CS)) then call MOM_error(FATAL, "neutral_diffusion_init called with associated control structure.") @@ -187,6 +193,10 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "a transition zone defined using boundary layer depths. "//& "Only applicable when NDIFF_INTERIOR_ONLY=True", default=.false.) endif + call get_param(param_file, mdl, "KHTR_USE_EBT_STRUCT", CS%KhTh_use_ebt_struct, & + "If true, uses the equivalent barotropic structure "//& + "as the vertical structure of the tracer diffusivity.",& + default=.false.,do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_USE_UNMASKED_TRANSPORT_BUG", CS%use_unmasked_transport_bug, & "If true, use an older form for the accumulation of neutral-diffusion "//& "transports that were unmasked, as used prior to Jan 2018. This is not "//& @@ -257,10 +267,10 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "exiting the iterative loop to find the neutral surface", & default=10) endif + call get_param(param_file, mdl, "DEBUG", debug, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "NDIFF_DEBUG", CS%debug, & "Turns on verbose output for discontinuous neutral "//& - "diffusion routines.", & - default=.false.) + "diffusion routines.", default=debug) call get_param(param_file, mdl, "HARD_FAIL_HEFF", CS%hard_fail_heff, & "Bring down the model if a problem with heff is detected",& default=.true.) @@ -275,10 +285,14 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, endif if (CS%tapering) then - allocate(CS%coeff_l(SZK_(GV)+1), source=0.) - allocate(CS%coeff_r(SZK_(GV)+1), source=0.) + allocate(CS%coeff_l(SZK_(GV)+1), source=1.) + allocate(CS%coeff_r(SZK_(GV)+1), source=1.) endif endif + + if (CS%KhTh_use_ebt_struct) & + allocate(CS%Coef_h(G%isd:G%ied,G%jsd:G%jed,SZK_(GV)+1), source=0.) + ! Store a rescaling factor for use in diagnostic messages. CS%R_to_kg_m3 = US%R_to_kg_m3 @@ -583,16 +597,16 @@ end subroutine neutral_diffusion_calc_coeffs !> Update tracer concentration due to neutral diffusion; layer thickness unchanged by this update. subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] - real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] + real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] !! (I_numitts in tracer_hordiff) - type(tracer_registry_type), pointer :: Reg !< Tracer registry - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure + type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] @@ -606,12 +620,13 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion ! [H L2 conc ~> m3 conc or kg conc] + real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points. + type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer integer :: i, j, k, m, ks, nk real :: Idt ! The inverse of the time step [T-1 ~> s-1] real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff if (.not. CS%continuous_reconstruction) then @@ -620,6 +635,22 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif endif + if (CS%KhTh_use_ebt_struct) then + ! Compute Coef at h points + CS%Coef_h(:,:,:) = 0. + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + normalize = 1.0 / ((G%mask2dCu(I-1,j)+G%mask2dCu(I,j)) + & + (G%mask2dCv(i,J-1)+G%mask2dCv(i,J)) + 1.0e-37) + do k = 1, GV%ke+1 + CS%Coef_h(i,j,k) = normalize*G%mask2dT(i,j)*((Coef_x(I-1,j,k)+Coef_x(I,j,k)) + & + (Coef_y(i,J-1,k)+Coef_y(i,J,k))) + enddo + endif + enddo; enddo + call pass_var(CS%Coef_h,G%Domain) + endif + nk = GV%ke do m = 1,Reg%ntr ! Loop over tracer registry @@ -637,87 +668,179 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) vFlx(:,:,:) = 0. ! x-flux - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - if (CS%tapering) then - ! compute coeff_l and coeff_r and pass them to neutral_surface_flux - call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & - h(I,j,:), h(I+1,j,:)) - - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & - tracer%t(i,j,:), tracer%t(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, h_neglect, & - CS%remap_CS, h_neglect_edge, CS%coeff_l(:), CS%coeff_r(:)) - else - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & - tracer%t(i,j,:), tracer%t(i+1,j,:), & - CS%uPoL(I,j,:), CS%uPoR(I,j,:), & - CS%uKoL(I,j,:), CS%uKoR(I,j,:), & - CS%uhEff(I,j,:), uFlx(I,j,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + if (CS%tapering) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i+1,j,:)) + else + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i+1,j,:)) + endif endif - endif - enddo ; enddo + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then + if (CS%tapering) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & + h(I,j,:), h(I+1,j,:)) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + else + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & + tracer%t(i,j,:), tracer%t(i+1,j,:), & + CS%uPoL(I,j,:), CS%uPoR(I,j,:), & + CS%uKoL(I,j,:), CS%uKoR(I,j,:), & + CS%uhEff(I,j,:), uFlx(I,j,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + endif + enddo ; enddo + endif ! y-flux - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - if (CS%tapering) then - ! compute coeff_l and coeff_r and pass them to neutral_surface_flux - call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & - h(i,J,:), h(i,J+1,:)) - - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & - tracer%t(i,j,:), tracer%t(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, h_neglect, & - CS%remap_CS, h_neglect_edge, CS%coeff_l(:), CS%coeff_r(:)) - else + if (CS%KhTh_use_ebt_struct) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + if (CS%tapering) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & + CS%coeff_r(:)*CS%Coef_h(i,j+1,:)) + else - call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & - tracer%t(i,j,:), tracer%t(i,j+1,:), & - CS%vPoL(i,J,:), CS%vPoR(i,J,:), & - CS%vKoL(i,J,:), CS%vKoR(i,J,:), & - CS%vhEff(i,J,:), vFlx(i,J,:), & - CS%continuous_reconstruction, h_neglect, CS%remap_CS, h_neglect_edge) + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & + CS%Coef_h(i,j+1,:)) + endif endif - endif - enddo ; enddo + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then + if (CS%tapering) then + ! compute coeff_l and coeff_r and pass them to neutral_surface_flux + call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & + h(i,J,:), h(i,J+1,:)) + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & + CS%coeff_r(:)) + else + + call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & + tracer%t(i,j,:), tracer%t(i,j+1,:), & + CS%vPoL(i,J,:), CS%vPoR(i,J,:), & + CS%vKoL(i,J,:), CS%vKoR(i,J,:), & + CS%vhEff(i,J,:), vFlx(i,J,:), & + CS%continuous_reconstruction, h_neglect, & + CS%remap_CS, h_neglect_edge) + endif + endif + enddo ; enddo + endif ! Update the tracer concentration from divergence of neutral diffusive flux components - do j = G%jsc,G%jec ; do i = G%isc,G%iec - if (G%mask2dT(i,j)>0.) then + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 + enddo - dTracer(:) = 0. - do ks = 1,CS%nsurf-1 - k = CS%uKoL(I,j,ks) - dTracer(k) = dTracer(k) + Coef_x(I,j) * uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dTracer(k) = dTracer(k) - Coef_x(I-1,j) * uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dTracer(k) = dTracer(k) + Coef_y(i,J) * vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dTracer(k) = dTracer(k) - Coef_y(i,J-1) * vFlx(i,J-1,ks) - enddo - do k = 1, GV%ke - tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & - ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) - if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 - enddo + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif - if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do i = G%isc,G%iec + if (G%mask2dT(i,j)>0.) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo do k = 1, GV%ke - tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & + ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) + if (abs(tracer%t(i,j,k)) < tracer%conc_underflow) tracer%t(i,j,k) = 0.0 enddo - endif - endif - enddo ; enddo + if (tracer%id_dfxy_conc > 0 .or. tracer%id_dfxy_cont > 0 .or. tracer%id_dfxy_cont_2d > 0 ) then + do k = 1, GV%ke + tendency(i,j,k) = dTracer(k) * G%IareaT(i,j) * Idt + enddo + endif + + endif + enddo ; enddo + endif ! Do user controlled underflow of the tracer concentrations. if (tracer%conc_underflow > 0.0) then @@ -729,30 +852,58 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! Diagnose vertically summed zonal flux, giving zonal tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfx_2d > 0) then - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - trans_x_2d(I,j) = 0. - if (G%mask2dCu(I,j)>0.) then - do ks = 1,CS%nsurf-1 - trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j) * uFlx(I,j,ks) - enddo - trans_x_2d(I,j) = trans_x_2d(I,j) * Idt - endif - enddo ; enddo + + if (CS%KhTh_use_ebt_struct) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + trans_x_2d(I,j) = 0. + if (G%mask2dCu(I,j)>0.) then + do ks = 1,CS%nsurf-1 + trans_x_2d(I,j) = trans_x_2d(I,j) - Coef_x(I,j,1) * uFlx(I,j,ks) + enddo + trans_x_2d(I,j) = trans_x_2d(I,j) * Idt + endif + enddo ; enddo + endif + call post_data(tracer%id_dfx_2d, trans_x_2d(:,:), CS%diag) endif ! Diagnose vertically summed merid flux, giving meridional tracer transport from ndiff. ! Note sign corresponds to downgradient flux convention. if (tracer%id_dfy_2d > 0) then - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - trans_y_2d(i,J) = 0. - if (G%mask2dCv(i,J)>0.) then - do ks = 1,CS%nsurf-1 - trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J) * vFlx(i,J,ks) - enddo - trans_y_2d(i,J) = trans_y_2d(i,J) * Idt - endif - enddo ; enddo + + if (CS%KhTh_use_ebt_struct) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + trans_y_2d(i,J) = 0. + if (G%mask2dCv(i,J)>0.) then + do ks = 1,CS%nsurf-1 + trans_y_2d(i,J) = trans_y_2d(i,J) - Coef_y(i,J,1) * vFlx(i,J,ks) + enddo + trans_y_2d(i,J) = trans_y_2d(i,J) * Idt + endif + enddo ; enddo + endif + call post_data(tracer%id_dfy_2d, trans_y_2d(:,:), CS%diag) endif @@ -2043,7 +2194,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral !! surfaces [H ~> m or kg m-2] - real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers (conc H) + real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers + !! (conc H or conc H L2) logical, intent(in) :: continuous !< True if using continuous reconstruction real, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions [H ~> m or kg m-2] @@ -2051,8 +2203,8 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K !! to create sublayers real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for !! edge value calculations if continuous is false [H ~> m or kg m-2] - real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 T-1 ~> m2 s-1] - real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 T-1 ~> m2 s-1] + real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 ~> m2 or nondim] + real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 ~> m2 or nondim] ! Local variables integer :: k_sublayer, klb, klt, krb, krt From d22b667f78d1013d441737ddae4d1b58db200411 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Jul 2023 07:51:29 -0400 Subject: [PATCH 352/629] +Add find_rho_bottom Added the new subroutine find_rho_bottom to return a 1-d slice of the in situ density averaged over a specified distance from the bottom when in fully non- Boussinesq mode or an array filled with the Boussinesq reference density. This new routine is not yet used with this commit, but it has been tested in another commit that will follow shortly. All answers are bitwise identical, but there is a new public interface. --- src/core/MOM_interface_heights.F90 | 132 +++++++++++++++++++++++++++++ 1 file changed, 132 insertions(+) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index dfd1048b82..1893859fe7 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -19,6 +19,7 @@ module MOM_interface_heights public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple public calc_derived_thermo +public find_rho_bottom !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta @@ -313,6 +314,137 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) end subroutine calc_derived_thermo + +!> Determine the in situ density averaged over a specified distance from the bottom, +!! calculating it as the inverse of the mass-weighted average specific volume. +subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) + 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] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)+1), & + intent(in) :: pres_int !< Pressure at each interface [R L2 T-2 ~> Pa] + real, dimension(SZI_(G)), intent(in) :: dz_avg !< The vertical distance over which to average [Z ~> m] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, intent(in) :: j !< j-index of row to work on + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + + ! Local variables + real :: hb(SZI_(G)) ! Running sum of the thickness in the bottom boundary layer [H ~> m or kg m-2] + real :: SpV_h_bot(SZI_(G)) ! Running sum of the specific volume times thickness in the bottom + ! boundary layer [R-1 H ~> m4 kg-1 or m] + real :: dz_bbl_rem(SZI_(G)) ! Vertical extent of the boundary layer that has yet to be accounted + ! for [Z ~> m] + real :: h_bbl_frac(SZI_(G)) ! Thickness of the fractional layer that makes up the top of the + ! boundary layer [H ~> m or kg m-2] + real :: T_bbl(SZI_(G)) ! Temperature of the fractional layer that makes up the top of the + ! boundary layer [C ~> degC] + real :: S_bbl(SZI_(G)) ! Salinity of the fractional layer that makes up the top of the + ! boundary layer [S ~> ppt] + real :: P_bbl(SZI_(G)) ! Pressure the top of the boundary layer [R L2 T-2 ~> Pa] + real :: dp(SZI_(G)) ! Pressure change across the fractional layer that makes up the top + ! of the boundary layer [R L2 T-2 ~> Pa] + real :: SpV_bbl(SZI_(G)) ! In situ specific volume of the fractional layer that makes up the + ! top of the boundary layer [R-1 ~> m3 kg-1] + real :: frac_in ! The fraction of a layer that is within the bottom boundary layer [nondim] + logical :: do_i(SZI_(G)), do_any + logical :: use_EOS + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state + integer :: i, k, is, ie, nz + + is = G%isc ; ie = G%iec ; nz = GV%ke + + use_EOS = associated(tv%T) .and. associated(tv%S) .and. associated(tv%eqn_of_state) + + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie + rho_bot(i) = GV%Rho0 + enddo + else + ! Check that SpV_avg has been set. + if (tv%valid_SpV_halo < 0) call MOM_error(FATAL, & + "find_rho_bottom called in fully non-Boussinesq mode with invalid values of SpV_avg.") + + ! Set the bottom density to the inverse of the in situ specific volume averaged over the + ! specified distance, with care taken to avoid having compressibility lead to an imprint + ! of the layer thicknesses on this density. + do i=is,ie + hb(i) = 0.0 ; SpV_h_bot(i) = 0.0 + dz_bbl_rem(i) = G%mask2dT(i,j) * max(0.0, dz_avg(i)) + do_i(i) = .true. + if (G%mask2dT(i,j) <= 0.0) then + ! Set acceptable values for calling the equation of state over land. + T_bbl(i) = 0.0 ; S_bbl(i) = 0.0 ; dp(i) = 0.0 ; P_bbl(i) = 0.0 + SpV_bbl(i) = 1.0 ! This value is arbitrary, provided it is non-zero. + h_bbl_frac(i) = 0.0 + do_i(i) = .false. + endif + enddo + + do k=nz,1,-1 + do_any = .false. + do i=is,ie ; if (do_i(i)) then + if (dz(i,k) < dz_bbl_rem(i)) then + ! This layer is fully within the averaging depth. + SpV_h_bot(i) = SpV_h_bot(i) + h(i,j,k) * tv%SpV_avg(i,j,k) + dz_bbl_rem(i) = dz_bbl_rem(i) - dz(i,k) + hb(i) = hb(i) + h(i,j,k) + do_any = .true. + else + if (dz(i,k) > 0.0) then + frac_in = dz_bbl_rem(i) / dz(i,k) + else + frac_in = 0.0 + endif + if (use_EOS) then + ! Store the properties of this layer to determine the average + ! specific volume of the portion that is within the BBL. + T_bbl(i) = tv%T(i,j,k) ; S_bbl(i) = tv%S(i,j,k) + dp(i) = frac_in * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + P_bbl(i) = pres_int(i,K) + (1.0-frac_in) * (GV%g_Earth*GV%H_to_RZ * h(i,j,k)) + else + SpV_bbl(i) = tv%SpV_avg(i,j,k) + endif + h_bbl_frac(i) = frac_in * h(i,j,k) + dz_bbl_rem(i) = 0.0 + do_i(i) = .false. + endif + endif ; enddo + if (.not.do_any) exit + enddo + do i=is,ie ; if (do_i(i)) then + ! The nominal bottom boundary layer is thicker than the water column, but layer 1 is + ! already included in the averages. These values are set so that the call to find + ! the layer-average specific volume will behave sensibly. + if (use_EOS) then + T_bbl(i) = tv%T(i,j,1) ; S_bbl(i) = tv%S(i,j,1) + dp(i) = 0.0 + P_bbl(i) = pres_int(i,1) + else + SpV_bbl(i) = tv%SpV_avg(i,j,1) + endif + h_bbl_frac(i) = 0.0 + endif ; enddo + + if (use_EOS) then + ! Find the average specific volume of the fractional layer atop the BBL. + EOSdom(:) = EOS_domain(G%HI) + call average_specific_vol(T_bbl, S_bbl, P_bbl, dp, SpV_bbl, tv%eqn_of_state, EOSdom) + endif + + do i=is,ie + if (hb(i) + h_bbl_frac(i) < GV%H_subroundoff) h_bbl_frac(i) = GV%H_subroundoff + rho_bot(i) = G%mask2dT(i,j) * (hb(i) + h_bbl_frac(i)) / (SpV_h_bot(i) + h_bbl_frac(i)*SpV_bbl(i)) + enddo + endif + +end subroutine find_rho_bottom + + !> 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. From e4f76c0e2fb121e2e99538925fe5fe8dbf32b396 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 20 Jul 2023 09:31:15 -0400 Subject: [PATCH 353/629] +*Non-Boussinesq internal tide drag uses density Use the in situ near bottom density to calculate the internal tide drag, energy input and energy loss terms when in non-Boussinesq mode. This change includes the addition of an argument containing the near-bottom density to propagate_int_tide, itidal_lowmode_loss and find_N2_bottom. The recently added routine find_rho_bottom is used to calculate this near-bottom density. Several instances where the Boussinesq reference density or GV%Z_to_H were used have been eliminated from use in non-Boussinesq cases by this change, to simplify the code and reduce the dependence on the value of GV%Rho_0 in non-Boussinesq mode. This involved changing the units of 4 internal variables in find_N2_bottom to use thickness units or related units. In some places, GV%Rho0 was replaced with GV%H_to_RZ. It also includes the rescaling of a variable in int_tide_CS, and a new element with the bottom drag in the int_tide_input_type. All answers are bitwise identical in Boussinesq mode, but some solutions will change in non-Boussinesq mode with this change, and there are new arguments to publicly visible subroutines and a new element in a transparent type. --- .../lateral/MOM_internal_tides.F90 | 91 ++++++++++------- .../vertical/MOM_diabatic_driver.F90 | 2 +- .../vertical/MOM_internal_tide_input.F90 | 97 +++++++++++++------ 3 files changed, 121 insertions(+), 69 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 8c56107a4f..788e922ff2 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -78,9 +78,10 @@ module MOM_internal_tides real, allocatable, dimension(:,:,:,:,:) :: TKE_Froude_loss !< energy lost due to wave breaking [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:) :: TKE_itidal_loss_fixed - !< Fixed part of the energy lost due to small-scale drag [R L-2 Z3 ~> kg m-2] here; - !! This will be multiplied by N and the squared near-bottom velocity to get - !! the energy losses in [R Z3 T-3 ~> W m-2] + !< Fixed part of the energy lost due to small-scale drag [R Z3 L-2 ~> kg m-2] here; + !! This will be multiplied by N and the squared near-bottom velocity (and by + !! the near-bottom density in non-Boussinesq mode) to get the energy losses + !! in [R Z4 H-1 L-2 ~> kg m-2 or m] real, allocatable, dimension(:,:,:,:,:) :: TKE_itidal_loss !< energy lost due to small-scale wave drag [R Z3 T-3 ~> W m-2] real, allocatable, dimension(:,:,:,:,:) :: TKE_residual_loss @@ -120,7 +121,7 @@ module MOM_internal_tides real :: cdrag !< The bottom drag coefficient [nondim]. real :: drag_min_depth !< The minimum total ocean thickness that will be used in the denominator !! of the quadratic drag terms for internal tides when - !! INTERNAL_TIDE_QUAD_DRAG is true [Z ~> m] + !! INTERNAL_TIDE_QUAD_DRAG is true [H ~> m or kg m-2] logical :: apply_background_drag !< If true, apply a drag due to background processes as a sink. logical :: apply_bottom_drag @@ -187,7 +188,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, TKE_itidal_input, vel_btTide, Nb, dt, & +subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, 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. @@ -203,6 +204,8 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & 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, dimension(SZI_(G),SZJ_(G)), intent(in) :: Rho_bot !< Near-bottom density or the Boussinesq + !! reference density [R ~> kg m-3]. 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 @@ -228,8 +231,8 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] - 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 :: I_D_here ! The inverse of the local water column thickness [H-1 ~> m-1 or m2 kg-1] + real :: I_mass ! The inverse of the local water mass [R-1 Z-1 ~> m2 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] @@ -244,7 +247,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] character(len=160) :: mesg ! The text of an error message - integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle, nzm + integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) type(group_pass_type), save :: pass_test, pass_En type(time_type) :: time_end @@ -252,8 +255,7 @@ subroutine propagate_int_tide(h, tv, 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 @@ -429,11 +431,20 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo - do j=jsd,jed ; do i=isd,ied - I_D_here = 1.0 / (max(GV%H_to_Z*htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & - tot_En(i,j) * I_rho0 * I_D_here)) * I_D_here - enddo ; enddo + if (GV%Boussinesq) then + ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. + do j=jsd,jed ; do i=isd,ied + I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & + tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + enddo ; enddo + else + do j=jsd,jed ; do i=isd,ied + I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) + drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) + enddo ; enddo + endif do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) @@ -504,7 +515,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, dt, & ! Finally, apply loss if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step - call itidal_lowmode_loss(G, US, CS, Nb, Ub, CS%En, CS%TKE_itidal_loss_fixed, & + call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & CS%TKE_itidal_loss, dt, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later @@ -782,18 +793,21 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, 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 type(int_tide_CS), intent(in) :: CS !< Internal tide control structure real, dimension(G%isd:G%ied,G%jsd:G%jed), & intent(in) :: Nb !< Near-bottom stratification [T-1 ~> s-1]. + real, dimension(G%isd:G%ied,G%jsd:G%jed), & + intent(in) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%nFreq,CS%nMode), & intent(inout) :: Ub !< RMS (over one period) near-bottom horizontal !! mode velocity [L T-1 ~> m s-1]. real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R L-2 Z3 ~> kg m-2] - !! (rho*kappa*h^2). + intent(in) :: TKE_loss_fixed !< Fixed part of energy loss [R Z4 H-1 L-2 ~> kg m-2 or m] + !! (rho*kappa*h^2) or (kappa*h^2). real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & intent(inout) :: En !< Energy density of the internal waves [R Z3 T-2 ~> J m-2]. real, dimension(G%isd:G%ied,G%jsd:G%jed,CS%NAngle,CS%nFreq,CS%nMode), & @@ -830,14 +844,18 @@ subroutine itidal_lowmode_loss(G, US, CS, Nb, Ub, En, TKE_loss_fixed, TKE_loss, enddo ! Calculate TKE loss rate; units of [R Z3 T-3 ~> W m-2] here. - TKE_loss_tot = q_itides * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_loss_tot = q_itides * GV%Z_to_H * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + else + TKE_loss_tot = q_itides * (GV%RZ_to_H * Rho_bot(i,j)) * TKE_loss_fixed(i,j) * Nb(i,j) * Ub(i,j,fr,m)**2 + endif ! Update energy remaining (this is a pseudo implicit calc) ! (E(t+1)-E(t))/dt = -TKE_loss(E(t+1)/E(t)), which goes to zero as E(t+1) goes to zero if (En_tot > 0.0) then do a=1,CS%nAngle frac_per_sector = En(i,j,a,fr,m)/En_tot - TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! Wm-2 + TKE_loss(i,j,a,fr,m) = frac_per_sector*TKE_loss_tot ! [R Z3 T-3 ~> W m-2] loss_rate = TKE_loss(i,j,a,fr,m) / (En(i,j,a,fr,m) + En_negl) ! [T-1 ~> s-1] En(i,j,a,fr,m) = En(i,j,a,fr,m) / (1.0 + dt*loss_rate) enddo @@ -2458,8 +2476,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "INTERNAL_TIDE_DRAG_MIN_DEPTH", CS%drag_min_depth, & "The minimum total ocean thickness that will be used in the denominator "//& "of the quadratic drag terms for internal tides.", & - units="m", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%apply_bottom_drag) - CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff * GV%H_to_Z) + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%apply_bottom_drag) + CS%drag_min_depth = MAX(CS%drag_min_depth, GV%H_subroundoff) call get_param(param_file, mdl, "INTERNAL_TIDE_FROUDE_DRAG", CS%apply_Froude_drag, & "If true, apply wave breaking as a sink.", & default=.false.) @@ -2543,9 +2561,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) else h2(i,j) = max(h2(i,j), 0.0) endif - ! Compute the fixed part; units are [R L-2 Z3 ~> kg m-2] here - ! will be multiplied by N and the squared near-bottom velocity to get into [R Z3 T-3 ~> W m-2] - CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor*GV%Rho0 * US%L_to_Z*kappa_itides * h2(i,j) + ! Compute the fixed part; units are [R Z4 H-1 L-2 ~> kg m-2 or m] here + ! will be multiplied by N and the squared near-bottom velocity (and by the + ! near-bottom density in non-Boussinesq mode) to get into [R Z3 T-3 ~> W m-2] + CS%TKE_itidal_loss_fixed(i,j) = 0.5*kappa_h2_factor* GV%H_to_RZ * US%L_to_Z*kappa_itides * h2(i,j) enddo ; enddo deallocate(h2) @@ -2644,16 +2663,16 @@ 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 + 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 diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 631a47c259..dae52592e9 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -387,7 +387,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & CS%int_tide_input_CSp) 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) + CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 95e33929df..3da21b48fb 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -14,6 +14,7 @@ module MOM_int_tide_input use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_isopycnal_slopes, only : vert_fill_TS use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) use MOM_unit_scaling, only : unit_scale_type @@ -44,7 +45,8 @@ module MOM_int_tide_input !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable, dimension(:,:) :: TKE_itidal_coef - !< The time-invariant field that enters the TKE_itidal input calculation [R Z3 T-2 ~> J m-2]. + !< The time-invariant field that enters the TKE_itidal input calculation noting that the + !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -70,7 +72,8 @@ module MOM_int_tide_input TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. - Nb !< The bottom stratification [T-1 ~> s-1]. + Nb, & !< The bottom stratification [T-1 ~> s-1]. + Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. end type int_tide_input_type contains @@ -90,9 +93,12 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) !! to the internal tide sources. real, intent(in) :: dt !< The time increment [T ~> s]. type(int_tide_input_CS), pointer :: CS !< This module's control structure. + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & N2_bot ! The bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Rho_bot ! The average near-bottom density or the Boussinesq reference density [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & T_f, S_f ! The temperature and salinity in [C ~> degC] and [S ~> ppt] with the values in @@ -121,15 +127,25 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) call vert_fill_TS(h, tv%T, tv%S, CS%kappa_fill*dt, T_f, S_f, G, GV, US, larger_h_denom=.true.) endif - call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot) + call find_N2_bottom(h, tv, T_f, S_f, itide%h2, fluxes, G, GV, US, N2_bot, Rho_bot) avg_enabled = query_averaging_enabled(CS%diag, time_end=time_end) - !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie - itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) - enddo ; enddo + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + itide%TKE_itidal_input(i,j) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) + itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) + itide%TKE_itidal_input(i,j) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), & + CS%TKE_itide_max) + enddo ; enddo + endif if (CS%int_tide_source_test) then itide%TKE_itidal_input(:,:) = 0.0 @@ -171,7 +187,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) end subroutine set_int_tide_input !> Estimates the near-bottom buoyancy frequency (N^2). -subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) +subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bot) 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 @@ -186,55 +202,62 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) type(forcing), intent(in) :: fluxes !< A structure of thermodynamic surface fluxes real, dimension(SZI_(G),SZJ_(G)), intent(out) :: N2_bot !< The squared buoyancy frequency at the !! ocean bottom [T-2 ~> s-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: rho_bot !< The average density near the ocean + !! bottom [R ~> kg m-3] ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. dRho_int ! The unfiltered density differences across interfaces [R ~> kg m-3]. + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Layer thicknesses in depth units [Z ~> m] real, dimension(SZI_(G)) :: & - pres, & ! The pressure at each interface [R L2 T-2 ~> Pa]. Temp_int, & ! The temperature at each interface [C ~> degC] Salin_int, & ! The salinity at each interface [S ~> ppt] drho_bot, & ! The density difference at the bottom of a layer [R ~> kg m-3] h_amp, & ! The amplitude of topographic roughness [Z ~> m]. - hb, & ! The depth below a layer [Z ~> m]. - z_from_bot, & ! The height of a layer center above the bottom [Z ~> m]. + hb, & ! The thickness of the water column below the midpoint of a layer [H ~> m or kg m-2] + z_from_bot, & ! The distance of a layer center from the bottom [Z ~> m] dRho_dT, & ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. - real :: dz_int ! The thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! The gravitation acceleration divided by the Boussinesq - ! density [Z T-2 R-1 ~> m4 s-2 kg-1]. + real :: dz_int ! The vertical extent of water associated with an interface [Z ~> m] + real :: G_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. logical :: do_i(SZI_(G)), do_any integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2*GV%g_Earth) / GV%H_to_RZ EOSdom(:) = EOS_domain(G%HI) ! Find the (limited) density jump across each interface. do i=is,ie dRho_int(i,1) = 0.0 ; dRho_int(i,nz+1) = 0.0 enddo -!$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & -!$OMP h2,N2_bot,G_Rho0,EOSdom) & -!$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & -!$OMP hb,dRho_bot,z_from_bot,do_i,h_amp, & -!$OMP do_any,dz_int) & -!$OMP firstprivate(dRho_int) + + !$OMP parallel do default(none) shared(is,ie,js,je,nz,tv,fluxes,G,GV,US,h,T_f,S_f, & + !$OMP h2,N2_bot,rho_bot,G_Rho0,EOSdom) & + !$OMP private(pres,Temp_Int,Salin_Int,dRho_dT,dRho_dS, & + !$OMP dz,hb,dRho_bot,z_from_bot,do_i,h_amp,do_any,dz_int) & + !$OMP firstprivate(dRho_int) do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo else - do i=is,ie ; pres(i) = 0.0 ; enddo + do i=is,ie ; pres(i,1) = 0.0 ; enddo endif do K=2,nz do i=is,ie - pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:), dRho_dS(:), & + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:), dRho_dS(:), & tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i)*(T_f(i,j,k) - T_f(i,j,k-1)) + & @@ -250,7 +273,7 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) ! Find the bottom boundary layer stratification. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = 0.5*dz(i,nz) do_i(i) = (G%mask2dT(i,j) > 0.0) h_amp(i) = sqrt(h2(i,j)) enddo @@ -258,16 +281,16 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above - hb(i) = hb(i) + dz_int + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) dRho_bot(i) = dRho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -283,6 +306,15 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot) N2_bot(i,j) = (G_Rho0 * dRho_bot(i)) / hb(i) else ; N2_bot(i,j) = 0.0 ; endif enddo + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + rho_bot(i,j) = GV%Rho0 + enddo + else + ! Average the density over the envelope of the topography. + call find_rho_bottom(h, dz, pres, h_amp, tv, j, G, GV, US, Rho_bot(:,j)) + endif enddo end subroutine find_N2_bottom @@ -359,6 +391,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) units="m s-1", default=0.0, scale=US%m_s_to_L_T) allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) + allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) allocate(itide%h2(isd:ied,jsd:jed), source=0.0) allocate(itide%TKE_itidal_input(isd:ied,jsd:jed), source=0.0) allocate(itide%tideamp(isd:ied,jsd:jed), source=utide) @@ -452,8 +485,8 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) - ! Compute the fixed part of internal tidal forcing; units are [R Z3 T-2 ~> J m-2] here. - CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor*GV%Rho0*& + ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. + CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 enddo ; enddo From fd31e01633c176f5c8dcf3df69c3dd3356c900cd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 3 Jul 2023 22:58:10 -0400 Subject: [PATCH 354/629] +(*)Minimum non-Boussinesq answer date of 20230701 Set a minimum answer date of 20230701 when the model is known to be in non-Boussinesq mode, and ignore all ANSWERS_2018 flags in that same mode. This change only applies to the code called from the src directories, and not to code within or called directly from the config_src/drivers directories or from another component model like SIS2 where the information about whether the model is in non-Boussinesq mode is not available. A verticalGrid_type arguemnt was added to porous_barriers_init to support one of these changes. This commit will change answers in some non-Boussinesq configurations, but all answers in existing test cases appear to be bitwise identical. There are fewer entries logged in non-Boussinesq MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 13 +++--- src/ALE/MOM_regridding.F90 | 16 ++++--- src/core/MOM.F90 | 26 ++++++++--- src/core/MOM_porous_barriers.F90 | 13 +++--- src/diagnostics/MOM_diagnostics.F90 | 13 +++--- src/framework/MOM_diag_mediator.F90 | 13 +++--- .../MOM_state_initialization.F90 | 44 +++++++++++++------ .../MOM_tracer_initialization_from_Z.F90 | 24 ++++++---- src/ocean_data_assim/MOM_oda_driver.F90 | 14 +++--- .../lateral/MOM_hor_visc.F90 | 14 +++--- .../lateral/MOM_lateral_mixing_coeffs.F90 | 13 +++--- .../lateral/MOM_thickness_diffuse.F90 | 14 +++--- .../vertical/MOM_ALE_sponge.F90 | 23 ++++++---- .../vertical/MOM_energetic_PBL.F90 | 15 ++++--- .../vertical/MOM_opacity.F90 | 15 ++++--- .../vertical/MOM_regularize_layers.F90 | 13 +++--- .../vertical/MOM_set_diffusivity.F90 | 13 +++--- .../vertical/MOM_set_viscosity.F90 | 13 +++--- .../vertical/MOM_tidal_mixing.F90 | 24 ++++++---- .../vertical/MOM_vert_friction.F90 | 14 +++--- src/tracer/MOM_neutral_diffusion.F90 | 7 +-- src/user/MOM_wave_interface.F90 | 4 +- 22 files changed, 230 insertions(+), 128 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4641747115..2e16933525 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -233,21 +233,24 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call initialize_remapping( CS%remapCS, string, & boundary_extrapolation=remap_boundary_extrap, & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 4cc60d16b2..5c4a76c7e5 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -277,28 +277,32 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) 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) + default=20181231, do_not_log=.not.GV%Boussinesq) ! ### change to default=default_answer_date) + if (.not.GV%Boussinesq) regrid_answer_date = max(regrid_answer_date, 20230701) call set_regrid_params(CS, regrid_answer_date=regrid_answer_date) endif diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 5dd3f45634..2f001305d1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2012,6 +2012,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & integer :: first_direction ! An integer that indicates which direction is to be ! updated first in directionally split parts of the ! calculation. + logical :: non_Bous ! If true, this run is fully non-Boussinesq + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_KPP ! If true, diabatic is using KPP vertical mixing integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations @@ -2075,6 +2078,14 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & default=.false.) endif + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", 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=.true.) + non_Bous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & "If true, the in-situ density is used to calculate the "//& "effective sea level that is returned to the coupler. If false, "//& @@ -2336,20 +2347,23 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & default=99991231) call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=non_Bous) call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", answers_2018, & "If true, use expressions for the surface properties that recover the answers "//& "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinesq cases.", default=default_2018_answers) + "at roundoff for non-Boussinesq cases.", default=default_2018_answers, do_not_log=non_Bous) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (.not.non_Bous) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, "MOM", "SURFACE_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions for the surface properties. Values below "//& "20190101 recover the answers from the end of 2018, while higher values "//& "use updated and more robust forms of the same expressions. "//& "If both SURFACE_2018_ANSWERS and SURFACE_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=non_Bous) + if (non_Bous) CS%answer_date = 99991231 call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, & "If true, uses the wrong calendar time for diabatic processes, as was "//& @@ -3030,7 +3044,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (CS%use_porbar) & - call porous_barriers_init(Time, US, param_file, diag, CS%por_bar_CS) + call porous_barriers_init(Time, GV, US, param_file, diag, CS%por_bar_CS) if (CS%split) then allocate(eta(SZI_(G),SZJ_(G)), source=0.0) diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index ebe3907469..d73d96b242 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -414,12 +414,13 @@ subroutine calc_por_interface(D_min, D_max, D_avg, eta_layer, w_layer, do_next) endif end subroutine calc_por_interface -subroutine porous_barriers_init(Time, US, param_file, diag, CS) - type(porous_barrier_CS), intent(inout) :: CS !< Module control structure - type(param_file_type), intent(in) :: param_file !< structure indicating parameter file to parse +subroutine porous_barriers_init(Time, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< Current model time - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control 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 !< structure indicating parameter file to parse + type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure + type(porous_barrier_CS), intent(inout) :: CS !< Module control structure ! local variables character(len=40) :: mdl = "MOM_porous_barriers" ! This module's name. @@ -439,7 +440,9 @@ subroutine porous_barriers_init(Time, US, param_file, diag, CS) call get_param(param_file, mdl, "PORBAR_ANSWER_DATE", CS%answer_date, & "The vintage of the porous barrier weight function calculations. Values below "//& "20220806 recover the old answers in which the layer averaged weights are not "//& - "strictly limited by an upper-bound of 1.0 .", default=default_answer_date) + "strictly limited by an upper-bound of 1.0 .", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "PORBAR_MASKING_DEPTH", CS%mask_depth, & "If the effective average depth at the velocity cell is shallower than this "//& diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 157c7268bf..c23712d8e7 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1610,21 +1610,24 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 092b12a2d2..58511c866b 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3184,21 +3184,24 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & 'If true, use a grid index coordinate convention for diagnostic axes. ',& default=.false.) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4ccf5b8bac..ddccf4a754 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1171,23 +1171,29 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) default=99991231, do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read) + default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=just_read) + "forms of the same expressions.", & + default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=just_read) + "latter takes precedence.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) else remap_answer_date = 20181231 + if (.not.GV%Boussinesq) remap_answer_date = 20230701 endif if (just_read) return ! All run-time parameters have been read, so return. @@ -2592,7 +2598,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just default=99991231, do_not_log=just_read) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read) + default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & "If true, initial conditions are on the model horizontal grid. " //& "Extrapolation over missing ocean values is done using an ICE-9 "//& @@ -2602,34 +2608,44 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=just_read) + "forms of the same expressions.", & + default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=just_read) + "latter takes precedence.", & + default=default_remap_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & "If true, use the order of arithmetic for horizontal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=just_read) + "forms of the same expressions.", & + default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates for horizontal regridding. default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + if (GV%Boussinesq) then + if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 + if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=just_read) + "latter takes precedence.", & + default=default_hor_reg_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (.not.useALEremapping) then call get_param(PF, mdl, "ADJUST_THICKNESS", correct_thickness, & diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 64f6673371..decd197b2b 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -127,39 +127,45 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ default=99991231) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) if (useALE) then call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) + "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & "If true, use the order of arithmetic for horizonal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal regridding. default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + if (GV%Boussinesq) then + if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 + if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date) + "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (PRESENT(homogenize)) homog=homogenize if (PRESENT(useALEremapping)) useALE=useALEremapping diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 53615b0063..fc67b20e87 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -255,20 +255,24 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) default=99991231) call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(PF, mdl, "ODA_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from original version of the ODA driver. Otherwise, use updated and "//& - "more robust forms of the same expressions.", default=default_2018_answers) + "more robust forms of the same expressions.", & + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(PF, mdl, "ODA_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions used by the ODA driver "//& "Values below 20190101 recover the answers from the end of 2018, while higher "//& "values use updated and more robust forms of the same expressions. "//& "If both ODA_2018_ANSWERS and ODA_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) inputdir = slasher(inputdir) select case(lowercase(trim(assim_method))) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 83809d39db..f9a35c1e3d 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1795,20 +1795,24 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "HOR_VISC_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal viscosity. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the horizontal "//& "viscosity calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& "same expressions. If both HOR_VISC_2018_ANSWERS and HOR_VISC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index df26f3f6a4..d3ee675269 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1507,21 +1507,24 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & "The fractional tolerance for finding the wave speeds.", & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index f24f790d06..1de4c9ba6b 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2248,20 +2248,24 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", MEKE_GEOM_answers_2018, & "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& "answers from the original implementation. Otherwise, use expressions that "//& - "satisfy rotational symmetry.", default=default_2018_answers) + "satisfy rotational symmetry.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for MEKE_geometric. - if (MEKE_GEOM_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.MEKE_GEOM_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (MEKE_GEOM_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.MEKE_GEOM_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& "Values below 20190101 recover the answers from the original implementation, "//& "while higher values use expressions that satisfy rotational symmetry. "//& "If both MEKE_GEOMETRIC_2018_ANSWERS and MEKE_GEOMETRIC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%MEKE_GEOM_answer_date = max(CS%MEKE_GEOM_answer_date, 20230701) endif call get_param(param_file, mdl, "USE_KH_IN_MEKE", CS%Use_KH_in_MEKE, & diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 2a30f68b42..1faeed00ba 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -228,14 +228,16 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + endif if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& @@ -243,22 +245,27 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) + "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) + call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & "If true, use the order of arithmetic for horizontal regridding that recovers "//& "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal regridding. default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + if (GV%Boussinesq) then + if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 + if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + endif call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& "Dates after 20230101 use reproducing sums for global averages. "//& "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date) + "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%hor_regrid_answer_date = max(CS%hor_regrid_answer_date, 20230701) CS%time_varying_sponges = .false. CS%nz = GV%ke diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 2c2f94519a..1556955424 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -2002,21 +2002,24 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "EPBL_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for horizontal viscosity. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "EPBL_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the energetic "//& "PBL calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& "same expressions. If both EPBL_2018_ANSWERS and EPBL_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) - + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "EPBL_ORIGINAL_PE_CALC", CS%orig_PE_calc, & "If true, the ePBL code uses the original form of the "//& diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index a8029d031f..ac93e54785 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -1069,22 +1069,25 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "OPTICS_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated expressions for "//& "handling the absorption of small remaining shortwave fluxes.", & - default=default_2018_answers) + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for optics. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "OPTICS_ANSWER_DATE", optics%answer_date, & "The vintage of the order of arithmetic and expressions in the optics calculations. "//& "Values below 20190101 recover the answers from the end of 2018, while "//& "higher values use updated and more robust forms of the same expressions. "//& "If both OPTICS_2018_ANSWERS and OPTICS_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) - + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) optics%answer_date = max(optics%answer_date, 20230701) call get_param(param_file, mdl, "PEN_SW_FLUX_ABSORB", optics%PenSW_flux_absorb, & "A minimum remaining shortwave heating rate that will be simply absorbed in "//& diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 5380b4cda0..2f2c66eca7 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -762,21 +762,24 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) default=99991231, do_not_log=just_read) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read) + default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(param_file, mdl, "REGULARIZE_LAYERS_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use updated and more robust forms of the "//& - "same expressions.", default=default_2018_answers, do_not_log=just_read) + "same expressions.", default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "REGULARIZE_LAYERS_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the regularize "//& "layers calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& "same expressions. If both REGULARIZE_LAYERS_2018_ANSWERS and "//& "REGULARIZE_LAYERS_ANSWER_DATE are specified, the latter takes precedence.", & - default=default_answer_date) + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) endif call get_param(param_file, mdl, "HMIX_MIN", CS%Hmix_min, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 4fb0791b8f..b3b49e0772 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2048,20 +2048,23 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "SET_DIFF_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "SET_DIFF_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set diffusivity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use updated and more robust forms of the same expressions. "//& "If both SET_DIFF_2018_ANSWERS and SET_DIFF_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. CS%use_tidal_mixing = tidal_mixing_init(Time, G, GV, US, param_file, & diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index f7b1456d46..9ab300560b 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2050,20 +2050,23 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "SET_VISC_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set viscosity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use updated and more robust forms of the same expressions. "//& "If both SET_VISC_2018_ANSWERS and SET_VISC_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date) + "the latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& "law of the form c_drag*|u|*u. The velocity magnitude "//& diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index bcbda88fec..89129ae480 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -296,37 +296,43 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "TIDAL_MIXING_2018_ANSWERS", tide_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for the tidal mixing. default_tide_ans_date = default_answer_date - if (tide_answers_2018 .and. (default_tide_ans_date >= 20190101)) default_tide_ans_date = 20181231 - if (.not.tide_answers_2018 .and. (default_tide_ans_date < 20190101)) default_tide_ans_date = 20190101 + if (GV%Boussinesq) then + if (tide_answers_2018 .and. (default_tide_ans_date >= 20190101)) default_tide_ans_date = 20181231 + if (.not.tide_answers_2018 .and. (default_tide_ans_date < 20190101)) default_tide_ans_date = 20190101 + endif call get_param(param_file, mdl, "TIDAL_MIXING_ANSWER_DATE", CS%tidal_answer_date, & "The vintage of the order of arithmetic and expressions in the tidal mixing "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use updated and more robust forms of the same expressions. "//& "If both TIDAL_MIXING_2018_ANSWERS and TIDAL_MIXING_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_tide_ans_date) + "the latter takes precedence.", default=default_tide_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%tidal_answer_date = max(CS%tidal_answer_date, 20230701) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + if (GV%Boussinesq) then + if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 + if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 + endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) + "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) if (CS%int_tide_dissipation) then diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 6af1dd78a2..133d72fa17 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2182,15 +2182,17 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", answers_2018, & "If true, use the order of arithmetic and expressions that recover the answers "//& "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& "hard-coded maximum viscous coupling coefficient between layers.", & - default=default_2018_answers) + default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + if (GV%Boussinesq) then + if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 + if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 + endif call get_param(param_file, mdl, "VERT_FRICTION_ANSWER_DATE", CS%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, "//& @@ -2199,7 +2201,9 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "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) + "specified, the latter takes precedence.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 479713863f..21201db590 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -193,11 +193,11 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, default=99991231) call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) + default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & "If true, use the order of arithmetic and expressions that recover the "//& "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) + "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) ! Revise inconsistent default answer dates for remapping. if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 @@ -207,7 +207,8 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "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. "//& "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & answer_date=CS%remap_answer_date ) call extract_member_remapping_CS(CS%remap_CS, degree=CS%deg) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 82ed753fb3..321528b739 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -319,7 +319,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) "\t >= 20230101 - More robust expressions for Update_Stokes_Drift\n"//& "\t >= 20230102 - More robust expressions for get_StokesSL_LiFoxKemper\n"//& "\t >= 20230103 - More robust expressions for ust_2_u10_coare3p5", & - default=20221231) ! In due course change the default to default=default_answer_date) + default=20221231, do_not_log=.not.GV%Boussinesq) + !### In due course change the default to default=default_answer_date) + if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! Langmuir number Options call get_param(param_file, mdl, "LA_DEPTH_RATIO", CS%LA_FracHBL, & From 82acb2f81e0095fcd289314afbf7bee56520f49c Mon Sep 17 00:00:00 2001 From: Matthew Thompson Date: Wed, 2 Aug 2023 12:29:11 -0400 Subject: [PATCH 355/629] 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]. From 45cd5c644b6450d921b07e687e69f14f8879c0bd Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 20 Jul 2023 22:40:44 -0400 Subject: [PATCH 356/629] Move file parser inquire calls to root PE MOM_file_parser's open_param_file() contains explicit inquire() calls when assessing the correctness of opening such a file. As written, these could be called by any rank, and are not thread safe. In rare cases (usually related to testing), this would cause a race condition and raise an error. Even ignoring the errors, it is probably better if only one rank makes these calls, rather than all of them. The following patch modifies the function so that only root PE invokes inquire(). There is not much to celebrate about this patch; it does not try to clean up the intrinsic weirdness of the IO handling. But it does appear to fix some of the most apparent problems. --- src/framework/MOM_file_parser.F90 | 40 ++++++++++++++++++------------- 1 file changed, 23 insertions(+), 17 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 35d75cff7f..88fabf0c74 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -152,28 +152,34 @@ subroutine open_param_file(filename, CS, checkable, component, doc_file_dir) ! Check that this file has not already been opened if (CS%nfiles > 0) then reopened_file = .false. - inquire(file=trim(filename), number=iounit) - if (iounit /= -1) then - do i = 1, CS%nfiles - if (CS%iounit(i) == iounit) then - call assert(trim(CS%filename(1)) == trim(filename), & - "open_param_file: internal inconsistency! "//trim(filename)// & - " is registered as open but has the wrong unit number!") - call MOM_error(WARNING, & - "open_param_file: file "//trim(filename)// & - " has already been opened. This should NOT happen!"// & - " Did you specify the same file twice in a namelist?") - reopened_file = .true. - endif ! unit numbers - enddo ! i + + if (is_root_pe()) then + inquire(file=trim(filename), number=iounit) + if (iounit /= -1) then + do i = 1, CS%nfiles + if (CS%iounit(i) == iounit) then + call assert(trim(CS%filename(1)) == trim(filename), & + "open_param_file: internal inconsistency! "//trim(filename)// & + " is registered as open but has the wrong unit number!") + call MOM_error(WARNING, & + "open_param_file: file "//trim(filename)// & + " has already been opened. This should NOT happen!"// & + " Did you specify the same file twice in a namelist?") + reopened_file = .true. + endif ! unit numbers + enddo ! i + endif endif + if (any_across_PEs(reopened_file)) return endif ! Check that the file exists to readstdlog - inquire(file=trim(filename), exist=file_exists) - if (.not.file_exists) call MOM_error(FATAL, & - "open_param_file: Input file '"// trim(filename)//"' does not exist.") + if (is_root_pe()) then + inquire(file=trim(filename), exist=file_exists) + if (.not.file_exists) call MOM_error(FATAL, & + "open_param_file: Input file '"// trim(filename)//"' does not exist.") + endif Netcdf_file = .false. if (strlen > 3) then From f01d256ccce458ce16ca31544b6726bca5645002 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 3 Aug 2023 11:22:19 -0400 Subject: [PATCH 357/629] +Non-Boussinesq revisions to wave_interface The surface gravity waves invariably work with depths in meters to match the units of the horizontal wavenumbers, even in non-Boussinesq mode, so several of the variables that are passed to or used in the MOM_wave_interface module have been revised to use units of [Z ~> m] and not [H ~> m or kg m-2]. There are changes to the names or units of a total of 8 arguments to Stokes_PGF, Update_Stokes_Drift, Get_StokesSL_LiFoxKemper, Get_SL_Average_Prof and get_Langmuir_Number, and a new argument to StokesMixing. To accommodate these changes, there are now calls to thickness_to_dz that precede the Update_Stokes_Drift or Stokes_PGF calls and a new 3d array in step_MOM. Additionally, four hard-coded dimensional constants in Stokes_PGF were given the needed scaling factors to pass dimensional consistency testing. This change also required the addition of a unit_scale_type argument to Stokes_PGF, and corresponding changes to the calls to this routine from step_MOM_dyn_split_RK2. Three comments pointing out probable bugs or instances of inaccurate algorithms were also added. Incorrect units were also fixed in the comments describing one internal variable in Update_Stokes_Drift. Also added the new runtime parameter RHO_SFC_WAVES to set the surface seawater density that is used in comparison with the typical density of air set by RHO_AIR to estimate the 10-meter wind speed from the ocean friction velocity and the COARE 3.5 stress relationships inside of get_StokesSL_LiFoxKemper() when the Li and Fox-Kemper (2017) wave model (i.e. LF17) is used. As a part of this change, there is a new verticalGrid_type argument to the internal routine set_LF17_wave_params(). By default, RHO_SFC_WAVES is set to RHO_0. Other specific changes include: - Changed the units of the publicly visible KvS element of the wave_parameters_CS from [Z2 T-1] to [H Z T-1] - Replaced the layer thickness argument (h with units of [H ~> m or kg m-2]) to Update_Stokes_Drift(), Get_SL_Average_Prof(), get_Langmuir_Number() and Stokes_PGF() with a vertical layer extent argument (dz in units of [Z ~> m]) - Add a vertical layer extent argument (dz) to StokesMixing() - Add a unit_scale_type argument to Stokes_PGF() - Multiply a hard-coded length scale in Stokes_PGF by the correct unit scaling factor and added comments to highlight these hard-coded lengths - Corrected the unit description of the DecayScale internal variable - Changed the units of 3 internal variables and added 1 new internal variable in StokesMixing - Added two new arrays to step_MOM for the layer vertical extent and friction velocity being set via thickness_to_dz and find_ustar and being passed to Update_Stokes_Drift - Added new arrays for the layer vertical extent and calls to thickness_to_dz in KPP_compute_BLD and energetic_PBL, as well as a new dz argument to ePBL_column to provide an altered argument to get_Langmuir_Number - Use find_ustar to set the friction velocity passed to Update_Stokes_Drift - Update fluxes%ustar or fluxes%tau_mag halos as necessary when the waves are in use A total of 28 unit conversion factors were eliminated with these changes. All answers are bitwise identical in Boussinesq mode, but they are changed in non-Boussinesq mode by the use of the layer specific volume to convert between thicknesses and vertical extents. The units of several arguments to publicly visible routines are altered as is a publicly visible element in wave_parameters_CS and there is a new runtime parameter that appears in some MOM_parameter_doc files. --- src/core/MOM.F90 | 26 +++- src/core/MOM_dynamics_split_RK2.F90 | 6 +- .../vertical/MOM_CVMix_KPP.F90 | 19 ++- .../vertical/MOM_energetic_PBL.F90 | 26 ++-- src/user/MOM_wave_interface.F90 | 143 ++++++++++-------- 5 files changed, 132 insertions(+), 88 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2f001305d1..9cbb744560 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -34,7 +34,7 @@ module MOM use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : read_param, get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar use MOM_forcing_type, only : MOM_forcing_chksum, MOM_mech_forcing_chksum use MOM_get_input, only : Get_MOM_Input, directories use MOM_io, only : MOM_io_init, vardesc, var_desc @@ -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, calc_derived_thermo +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz 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 @@ -544,8 +544,13 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! the end of a stepping cycle (whatever that may mean). logical :: therm_reset ! If true, reset running sums of thermodynamic quantities. real :: cycle_time ! The length of the coupled time-stepping cycle [T ~> s]. + real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & + U_star ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(CS%G),SZJ_(CS%G)) :: & ssh ! sea surface height, which may be based on eta_av [Z ~> m] + real, dimension(SZI_(CS%G),SZJ_(CS%G),SZK_(CS%GV)) :: & + dz ! Vertical distance across layers [Z ~> m] real, dimension(:,:,:), pointer :: & u => NULL(), & ! u : zonal velocity component [L T-1 ~> m s-1] @@ -672,13 +677,18 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt = time_interval / real(n_max) dt_therm = dt ; ntstep = 1 + + if (CS%UseWaves .and. associated(fluxes%ustar)) & + call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass, halo=1) + if (CS%UseWaves .and. associated(fluxes%tau_mag)) & + call pass_var(fluxes%tau_mag, G%Domain, clock=id_clock_pass, halo=1) + if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf CS%tv%p_surf => NULL() if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then CS%tv%p_surf => fluxes%p_surf if (allocated(CS%tv%SpV_avg)) call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) endif - if (CS%UseWaves) call pass_var(fluxes%ustar, G%Domain, clock=id_clock_pass) endif if (therm_reset) then @@ -722,12 +732,16 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%UseWaves) then ! Update wave information, which is presently kept static over each call to step_mom call enable_averages(time_interval, Time_start + real_to_time(US%T_to_s*time_interval), CS%diag) - call Update_Stokes_Drift(G, GV, US, Waves, h, forces%ustar, time_interval, do_dyn) + call find_ustar(forces, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) call disable_averaging(CS%diag) endif else ! not do_dyn. if (CS%UseWaves) then ! Diagnostics are not enabled in this call. - call Update_Stokes_Drift(G, GV, US, Waves, h, fluxes%ustar, time_interval, do_dyn) + call find_ustar(fluxes, CS%tv, U_star, G, GV, US, halo=1) + call thickness_to_dz(h, CS%tv, dz, G, GV, US, halo_size=1) + call Update_Stokes_Drift(G, GV, US, Waves, dz, U_star, time_interval, do_dyn) endif endif @@ -3261,7 +3275,7 @@ subroutine finish_MOM_initialization(Time, dirs, CS) ! Write initial conditions if (CS%write_IC) then allocate(restart_CSp_tmp) - restart_CSP_tmp = CS%restart_CS + restart_CSp_tmp = CS%restart_CS call restart_registry_lock(restart_CSp_tmp, unlocked=.true.) allocate(z_interface(SZI_(G),SZJ_(G),SZK_(GV)+1)) call find_eta(CS%h, CS%tv, G, GV, US, z_interface, dZref=G%Z_ref) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 5ce9ec8962..eebb7d6b8a 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -481,7 +481,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s Use_Stokes_PGF = associated(Waves) if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then - call Stokes_PGF(G, GV, h, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv ! will therefore report the sum total PGF and we avoid other @@ -748,7 +749,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s Use_Stokes_PGF = associated(Waves) if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then - call Stokes_PGF(G, GV, h, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) if (.not.Waves%Passive_Stokes_PGF) then do k=1,nz do j=js,je ; do I=Isq,Ieq diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 5e56098c98..d24c3e2954 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -12,6 +12,7 @@ module MOM_CVMix_KPP use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_grid, only : ocean_grid_type, isPointInCell +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -604,7 +605,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & type(ocean_grid_type), intent(in) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + 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 !< Thermodynamics structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: uStar !< Surface friction velocity [Z T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: buoyFlux !< Surface buoyancy flux [L2 T-3 ~> m2 s-3] @@ -863,14 +864,14 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & Kt(i,j,k) = Kt(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,1) Ks(i,j,k) = Ks(i,j,k) + GV%m2_s_to_HZ_T * Kdiffusivity(k,2) Kv(i,j,k) = Kv(i,j,k) + GV%m2_s_to_HZ_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) enddo else ! KPP replaces prior diffusivity when former is non-zero do k=1, GV%ke+1 if (Kdiffusivity(k,1) /= 0.) Kt(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,1) if (Kdiffusivity(k,2) /= 0.) Ks(i,j,k) = GV%m2_s_to_HZ_T * Kdiffusivity(k,2) if (Kviscosity(k) /= 0.) Kv(i,j,k) = GV%m2_s_to_HZ_T * Kviscosity(k) - if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = GV%H_to_Z*Kv(i,j,k) + if (CS%Stokes_Mixing) Waves%KvS(i,j,k) = Kv(i,j,k) enddo endif endif @@ -912,7 +913,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + 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) :: Temp !< potential/cons temp [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: Salt !< Salinity [S ~> ppt] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Velocity i-component [L T-1 ~> m s-1] @@ -924,6 +925,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: lamult !< Langmuir enhancement factor [nondim] ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] + ! Variables for passing to CVMix routines, often in MKS units real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] @@ -940,7 +943,6 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real :: Coriolis ! Coriolis parameter at tracer points in MKS units [s-1] real :: KPP_OBL_depth ! Boundary layer depth calculated by CVMix_kpp_compute_OBL_depth in MKS units [m] - ! Variables for EOS calculations real, dimension( 3*GV%ke ) :: rho_1D ! A column of densities [R ~> kg m-3] real, dimension( 3*GV%ke ) :: pres_1D ! A column of pressures [R L2 T-2 ~> Pa] @@ -996,6 +998,9 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl GoRho = US%Z_to_m*US%s_to_T**2 * GoRho_Z_L2 buoy_scale = US%L_to_m**2*US%s_to_T**3 + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + ! loop over horizontal points on processor !$OMP parallel do default(none) private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & !$OMP surfBuoyFlux, U_H, V_H, Coriolis, pRef, SLdepth_0d, vt2_1d, & @@ -1005,7 +1010,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, & + !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) do j = G%jsc, G%jec do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then @@ -1127,7 +1132,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if ( (CS%LT_K_ENHANCEMENT .or. CS%LT_VT2_ENHANCEMENT) .and. .not. present(lamult)) then MLD_guess = max( CS%MLD_guess_min, abs(CS%OBLdepthprev(i,j) ) ) call get_Langmuir_Number(LA, G, GV, US, MLD_guess, uStar(i,j), i, j, & - H=H(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) + dz=dz(i,j,:), U_H=U_H, V_H=V_H, WAVES=WAVES) CS%La_SL(i,j) = LA endif diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1556955424..06c3915d84 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -12,6 +12,7 @@ module MOM_energetic_PBL use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -309,6 +310,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & h_2d, & ! A 2-d slice of the layer thickness [H ~> m or kg m-2]. + dz_2d, & ! A 2-d slice of the vertical distance across layers [Z ~> m]. T_2d, & ! A 2-d slice of the layer temperatures [C ~> degC]. S_2d, & ! A 2-d slice of the layer salinities [S ~> ppt]. TKE_forced_2d, & ! A 2-d slice of TKE_forced [R Z3 T-2 ~> J m-2]. @@ -320,6 +322,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS Kd_2d ! A 2-d version of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. real, dimension(SZK_(GV)) :: & h, & ! The layer thickness [H ~> m or kg m-2]. + dz, & ! The vertical distance across layers [Z ~> m]. T0, & ! The initial layer temperatures [C ~> degC]. S0, & ! The initial layer salinities [S ~> ppt]. dSV_dT_1d, & ! The partial derivatives of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. @@ -362,7 +365,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then -!!OMP parallel do default(none) shared(is,ie,js,je,CS) + !!OMP parallel do default(none) shared(is,ie,js,je,CS) do j=js,je ; do i=is,ie CS%diag_TKE_wind(i,j) = 0.0 ; CS%diag_TKE_MKE(i,j) = 0.0 CS%diag_TKE_conv(i,j) = 0.0 ; CS%diag_TKE_forcing(i,j) = 0.0 @@ -373,8 +376,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! if (CS%id_Mixing_Length>0) CS%Mixing_Length(:,:,:) = 0.0 ! if (CS%id_Velocity_Scale>0) CS%Velocity_Scale(:,:,:) = 0.0 -!!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & -!!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) + !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & + !!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. do k=1,nz ; do i=is,ie @@ -383,6 +386,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS TKE_forced_2d(i,k) = TKE_forced(i,j,k) dSV_dT_2d(i,k) = dSV_dT(i,j,k) ; dSV_dS_2d(i,k) = dSV_dS(i,j,k) enddo ; enddo + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing @@ -394,7 +398,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Copy the thicknesses and other fields to 1-d arrays. do k=1,nz - h(k) = h_2d(i,k) + GV%H_subroundoff ; u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) + h(k) = h_2d(i,k) + GV%H_subroundoff ; dz(k) = dz_2d(i,k) + GV%dZ_subroundoff + u(k) = u_2d(i,k) ; v(k) = v_2d(i,k) T0(k) = T_2d(i,k) ; S0(k) = S_2d(i,k) ; TKE_forcing(k) = TKE_forced_2d(i,k) dSV_dT_1d(k) = dSV_dT_2d(i,k) ; dSV_dS_1d(k) = dSV_dS_2d(i,k) enddo @@ -421,15 +426,15 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Perhaps provide a first guess for MLD based on a stored previous value. MLD_io = -1.0 - if (CS%MLD_iteration_guess .and. (CS%ML_Depth(i,j) > 0.0)) MLD_io = CS%ML_Depth(i,j) + if (CS%MLD_iteration_guess .and. (CS%ML_depth(i,j) > 0.0)) MLD_io = CS%ML_depth(i,j) if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else - call ePBL_column(h, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j) endif @@ -499,12 +504,13 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & +subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) 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(SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m]. real, dimension(SZK_(GV)), intent(in) :: u !< Zonal velocities interpolated to h points !! [L T-1 ~> m s-1]. real, dimension(SZK_(GV)), intent(in) :: v !< Zonal velocities interpolated to h points @@ -828,7 +834,7 @@ subroutine ePBL_column(h, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, abs !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 MLD_guess_z = GV%H_to_Z*MLD_guess ! Convert MLD from thickness to height coordinates for these calls if (CS%Use_LT) then - call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess_z), u_star_mean, i, j, h, Waves, & + call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess_z), u_star_mean, i, j, dz, Waves, & U_H=u, V_H=v) call find_mstar(CS, US, B_flux, u_star, u_star_Mean, MLD_guess_z, absf, & MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& @@ -1931,7 +1937,7 @@ subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units do j=G%jsc,G%jec ; do i=G%isc,G%iec - MLD(i,j) = scale*CS%ML_Depth(i,j) + MLD(i,j) = scale*CS%ML_depth(i,j) enddo ; enddo end subroutine energetic_PBL_get_MLD diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 321528b739..580e293f4f 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -97,7 +97,7 @@ module MOM_wave_interface !! Horizontal -> V points !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & - KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + KvS !< Viscosity for Stokes Drift shear [H Z T-1 ~> m2 s-1 or Pa s] ! The remainder of this control structure is private integer :: WaveMethod = -99 !< Options for including wave information @@ -197,6 +197,8 @@ module MOM_wave_interface real :: VonKar = -1.0 !< The von Karman coefficient as used in the MOM_wave_interface module [nondim] real :: rho_air !< A typical density of air at sea level, as used in wave calculations [R ~> kg m-3] real :: nu_air !< The viscosity of air, as used in wave calculations [Z2 T-1 ~> m2 s-1] + real :: rho_ocn !< A typical surface density of seawater, as used in wave calculations in + !! comparison with the density of air [R ~> kg m-3]. The default is RHO_0. real :: SWH_from_u10sq !< A factor for converting the square of the 10 m wind speed to the !! significant wave height [Z T2 L-2 ~> s2 m-1] real :: Charnock_min !< The minimum value of the Charnock coefficient, which relates the square of @@ -334,7 +336,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) if (StatisticalWaves) then CS%WaveMethod = LF17 - call set_LF17_wave_params(param_file, mdl, US, CS) + call set_LF17_wave_params(param_file, mdl, GV, US, CS) if (.not.use_waves) return else CS%WaveMethod = NULL_WaveMethod @@ -500,7 +502,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) "Flag to disable updating DHH85 Stokes drift.", default=.false.) case (LF17_STRING) !Li and Fox-Kemper 17 wind-sea Langmuir number CS%WaveMethod = LF17 - call set_LF17_wave_params(param_file, mdl, US, CS) + call set_LF17_wave_params(param_file, mdl, GV, US, CS) case (EFACTOR_STRING) !Li and Fox-Kemper 16 CS%WaveMethod = EFACTOR case default @@ -578,9 +580,10 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag) end subroutine MOM_wave_interface_init !> Set the parameters that are used to determine the averaged Stokes drift and Langmuir numbers -subroutine set_LF17_wave_params(param_file, mdl, US, CS) +subroutine set_LF17_wave_params(param_file, mdl, GV, US, CS) type(param_file_type), intent(in) :: param_file !< Input parameter structure character(len=*), intent(in) :: mdl !< A module name to use in the get_param calls + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(wave_parameters_CS), pointer :: CS !< Wave parameter control structure @@ -596,6 +599,10 @@ subroutine set_LF17_wave_params(param_file, mdl, US, CS) call get_param(param_file, mdl, "RHO_AIR", CS%rho_air, & "A typical density of air at sea level, as used in wave calculations", & units="kg m-3", default=1.225, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RHO_SFC_WAVES", CS%Rho_ocn, & + "A typical surface density of seawater, as used in wave calculations in "//& + "comparison with the density of air. The default is RHO_0.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "WAVE_HEIGHT_SCALE_FACTOR", CS%SWH_from_u10sq, & "A factor relating the square of the 10 m wind speed to the significant "//& "wave height, with a default value based on the Pierson-Moskowitz spectrum.", & @@ -713,13 +720,13 @@ end subroutine Update_Surface_Waves !> Constructs the Stokes Drift profile on the model grid based on !! desired coupling options -subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) +subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) type(wave_parameters_CS), pointer :: CS !< Wave parameter Control structure type(ocean_grid_type), intent(inout) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Thickness [H ~> m or kg m-2] + intent(in) :: dz !< Thickness in height units [Z ~> m] real, dimension(SZI_(G),SZJ_(G)), & intent(in) :: ustar !< Wind friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: dt !< Time-step for computing Stokes-tendency [T ~> s] @@ -728,7 +735,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! Local Variables real :: Top, MidPoint, Bottom ! Positions within the layer [Z ~> m] real :: level_thick ! The thickness of each layer [Z ~> m] - real :: DecayScale ! A vertical decay scale in the test profile [Z ~> m] + real :: DecayScale ! A vertical decay scale in the test profile [Z-1 ~> m-1] real :: CMN_FAC ! A nondimensional factor [nondim] real :: WN ! Model wavenumber [Z-1 ~> m-1] real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] @@ -755,8 +762,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) MidPoint = 0.0 do kk = 1,GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Bottom - 0.25*(dz(II,jj,kk)+dz(IIm1,jj,kk)) + Bottom = Bottom - 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) CS%Us_x(II,jj,kk) = CS%TP_STKX0*exp(MidPoint*DecayScale) enddo enddo @@ -768,8 +775,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) MidPoint = 0.0 do kk = 1,GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + MidPoint = Bottom - 0.25*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) + Bottom = Bottom - 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) CS%Us_y(ii,JJ,kk) = CS%TP_STKY0*exp(MidPoint*DecayScale) enddo enddo @@ -796,7 +803,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) - level_thick = 0.5*GV%H_to_Z*(h(II,jj,kk)+h(IIm1,jj,kk)) + level_thick = 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -854,7 +861,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk = 1,GV%ke Top = Bottom JJm1 = max(JJ-1,1) - level_thick = 0.5*GV%H_to_Z*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + level_thick = 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -908,8 +915,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk = 1,GV%ke Top = Bottom IIm1 = max(II-1,1) - MidPoint = Top - GV%H_to_Z*0.25*(h(II,jj,kk)+h(IIm1,jj,kk)) - Bottom = Top - GV%H_to_Z*0.5*(h(II,jj,kk)+h(IIm1,jj,kk)) + MidPoint = Top - 0.25*(dz(II,jj,kk)+dz(IIm1,jj,kk)) + Bottom = Top - 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) !bgr note that this is using a u-point ii on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non @@ -926,8 +933,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) do kk=1, GV%ke Top = Bottom JJm1 = max(JJ-1,1) - MidPoint = Bottom - GV%H_to_Z*0.25*(h(ii,JJ,kk)+h(ii,JJm1,kk)) - Bottom = Bottom - GV%H_to_Z*0.5*(h(ii,JJ,kk)+h(ii,JJm1,kk)) + MidPoint = Bottom - 0.25*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) + Bottom = Bottom - 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) !bgr note that this is using a v-point jj on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non @@ -965,9 +972,8 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, h, ustar, dt, dynamics_step) ! in the routine it is needed by (e.g. KPP or ePBL). do jj = G%jsc, G%jec do ii = G%isc,G%iec - Top = h(ii,jj,1)*GV%H_to_Z - call get_Langmuir_Number( La, G, GV, US, Top, ustar(ii,jj), ii, jj, & - h(ii,jj,:), CS, Override_MA=.false.) + call get_Langmuir_Number( La, G, GV, US, dz(ii,jj,1), ustar(ii,jj), ii, jj, & + dz(ii,jj,:), CS, Override_MA=.false.) CS%La_turb(ii,jj) = La enddo enddo @@ -1138,7 +1144,7 @@ end subroutine Surface_Bands_by_data_override !! Note this can be called with an unallocated Waves pointer, which is okay if we !! want the wind-speed only dependent Langmuir number. Therefore, we need to be !! careful about what we try to access here. -subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & +subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & U_H, V_H, Override_MA ) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure @@ -1148,7 +1154,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & real, intent(in) :: ustar !< Friction velocity [Z T-1 ~> m s-1] integer, intent(in) :: i !< Meridional index of h-point integer, intent(in) :: j !< Zonal index of h-point - real, dimension(SZK_(GV)), intent(in) :: h !< Grid layer thickness [H ~> m or kg m-2] + real, dimension(SZK_(GV)), intent(in) :: dz !< Grid layer thickness [Z ~> m] type(Wave_parameters_CS), pointer :: Waves !< Surface wave control structure. real, dimension(SZK_(GV)), & optional, intent(in) :: U_H !< Zonal velocity at H point [L T-1 ~> m s-1] or [m s-1] @@ -1161,7 +1167,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & !Local Variables - real :: Top, bottom, midpoint ! Positions within each layer [Z ~> m] + real :: Top, Bottom, MidPoint ! Positions within each layer [Z ~> m] real :: Dpt_LASL ! Averaging depth for Stokes drift [Z ~> m] real :: ShearDirection ! Shear angular direction from atan2 [radians] real :: WaveDirection ! Wave angular direction from atan2 [radians] @@ -1185,8 +1191,11 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & bottom = 0.0 do kk = 1,GV%ke Top = Bottom - MidPoint = Bottom + GV%H_to_Z*0.5*h(kk) - Bottom = Bottom + GV%H_to_Z*h(kk) + MidPoint = Bottom + 0.5*dz(kk) + Bottom = Bottom + dz(kk) + !### Given the sign convention that Dpt_LASL is negative, the next line seems to have a bug. + ! To correct this bug, this line should be changed to: + ! if (MidPoint > abs(Dpt_LASL) .and. (kk > 1) .and. ContinueLoop) then if (MidPoint > Dpt_LASL .and. kk > 1 .and. ContinueLoop) then ShearDirection = atan2(V_H(1)-V_H(kk),U_H(1)-U_H(kk)) ContinueLoop = .false. @@ -1199,8 +1208,8 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) enddo - call Get_SL_Average_Prof( GV, Dpt_LASL, h, US_H, LA_STKx) - call Get_SL_Average_Prof( GV, Dpt_LASL, h, VS_H, LA_STKy) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX*LA_STKX+LA_STKY*LA_STKY) elseif (Waves%WaveMethod==SURFBANDS) then allocate(StkBand_X(Waves%NumBands), StkBand_Y(Waves%NumBands)) @@ -1218,11 +1227,11 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, h, Waves, & US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) enddo - call Get_SL_Average_Prof( GV, Dpt_LASL, h, US_H, LA_STKx) - call Get_SL_Average_Prof( GV, Dpt_LASL, h, VS_H, LA_STKy) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) + call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) LA_STK = sqrt(LA_STKX**2 + LA_STKY**2) elseif (Waves%WaveMethod==LF17) then - call get_StokesSL_LiFoxKemper(ustar, hbl*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) + call get_StokesSL_LiFoxKemper(ustar, HBL*Waves%LA_FracHBL, GV, US, Waves, LA_STK, LA) elseif (Waves%WaveMethod==Null_WaveMethod) then call MOM_error(FATAL, "Get_Langmuir_number called without defining a WaveMethod. "//& "Suggest to make sure USE_LT is set/overridden to False or choose "//& @@ -1322,7 +1331,7 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) ! This code should be revised to minimize the number of divisions and cancel out common factors. ! Computing u10 based on u_star and COARE 3.5 relationships - call ust_2_u10_coare3p5(ustar*sqrt(GV%Rho0/CS%rho_air), u10, GV, US, CS) + call ust_2_u10_coare3p5(ustar*sqrt(CS%rho_ocn/CS%rho_air), u10, GV, US, CS) ! surface Stokes drift UStokes = us_to_u10*u10 ! @@ -1406,19 +1415,19 @@ subroutine get_StokesSL_LiFoxKemper(ustar, hbl, GV, US, CS, UStokes_SL, LA) end subroutine Get_StokesSL_LiFoxKemper !> Get SL Averaged Stokes drift from a Stokes drift Profile -subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) +subroutine Get_SL_Average_Prof( GV, AvgDepth, dz, Profile, Average ) type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid structure - real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m]. + real, intent(in) :: AvgDepth !< Depth to average over (negative) [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: H !< Grid thickness [H ~> m or kg m-2] + intent(in) :: dz !< Grid thickness [Z ~> m] real, dimension(SZK_(GV)), & intent(in) :: Profile !< Profile of quantity to be averaged in arbitrary units [A] !! (used here for Stokes drift) real, intent(out) :: Average !< Output quantity averaged over depth AvgDepth [A] !! (used here for Stokes drift) !Local variables - real :: top, midpoint, bottom ! Depths, negative downward [Z ~> m]. + real :: Top, Bottom ! Depths, negative downward [Z ~> m] real :: Sum ! The depth weighted vertical sum of a quantity [A Z ~> A m] integer :: kk @@ -1429,10 +1438,9 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, H, Profile, Average ) bottom = 0.0 do kk = 1, GV%ke Top = Bottom - MidPoint = Bottom - GV%H_to_Z * 0.5*h(kk) - Bottom = Bottom - GV%H_to_Z * h(kk) + Bottom = Bottom - dz(kk) if (AvgDepth < Bottom) then ! The whole cell is within H_LA - Sum = Sum + Profile(kk) * (GV%H_to_Z * H(kk)) + Sum = Sum + Profile(kk) * dz(kk) elseif (AvgDepth < Top) then ! A partial cell is within H_LA Sum = Sum + Profile(kk) * (Top-AvgDepth) exit @@ -1546,7 +1554,7 @@ end subroutine DHH85_mid !> Explicit solver for Stokes mixing. !! Still in development do not use. -subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) +subroutine StokesMixing(G, GV, dt, h, dz, u, v, Waves ) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & @@ -1554,6 +1562,8 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) real, intent(in) :: dt !< Time step of MOM6 [T ~> s] for explicit solver 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) :: dz !< Vertical distance between interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: u !< Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1561,8 +1571,9 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) type(Wave_parameters_CS), & pointer :: Waves !< Surface wave related control structure. ! Local variables - real :: dTauUp, dTauDn ! Vertical momentum fluxes [Z L T-2 ~> m2 s-2] - real :: h_Lay ! The layer thickness at a velocity point [Z ~> m]. + real :: dTauUp, dTauDn ! Vertical momentum fluxes [H L T-2 ~> m2 s-2 or Pa] + real :: h_lay ! The layer thickness at a velocity point [H ~> m or kg m-2] + real :: dz_lay ! The distance between interfaces at a velocity point [Z ~> m] integer :: i, j, k ! This is a template to think about down-Stokes mixing. @@ -1571,18 +1582,19 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) do k = 1, GV%ke do j = G%jsc, G%jec do I = G%iscB, G%iecB - h_lay = GV%H_to_Z*0.5*(h(i,j,k)+h(i+1,j,k)) + h_lay = 0.5*(h(i,j,k)+h(i+1,j,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i+1,j,k)) dTauUp = 0.0 if (k > 1) & - dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k)) * & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i+1,j,k))) * & (waves%us_x(i,j,k-1)-waves%us_x(i,j,k)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k-1)+h(i+1,j,k-1)) )) + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i+1,j,k-1)) )) dTauDn = 0.0 if (k < GV%ke-1) & - dTauDn = 0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1)) * & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i+1,j,k+1))) * & (waves%us_x(i,j,k)-waves%us_x(i,j,k+1)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k+1)+h(i+1,j,k+1)) )) - u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_Lay + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i+1,j,k+1)) )) + u(i,j,k) = u(i,j,k) + dt * (dTauUp-dTauDn) / h_lay enddo enddo enddo @@ -1590,18 +1602,19 @@ subroutine StokesMixing(G, GV, dt, h, u, v, Waves ) do k = 1, GV%ke do J = G%jscB, G%jecB do i = G%isc, G%iec - h_Lay = GV%H_to_Z*0.5*(h(i,j,k)+h(i,j+1,k)) + h_lay = 0.5*(h(i,j,k)+h(i,j+1,k)) + dz_lay = 0.5*(dz(i,j,k)+dz(i,j+1,k)) dTauUp = 0. if (k > 1) & - dTauUp = 0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k)) * & + dTauUp = (0.5*(waves%Kvs(i,j,k)+waves%Kvs(i,j+1,k))) * & (waves%us_y(i,j,k-1)-waves%us_y(i,j,k)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k-1)+h(i,j+1,k-1)) )) + (0.5*(dz_lay + 0.5*(dz(i,j,k-1)+dz(i,j+1,k-1)) )) dTauDn = 0.0 if (k < GV%ke-1) & - dTauDn =0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1)) * & + dTauDn = (0.5*(waves%Kvs(i,j,k+1)+waves%Kvs(i,j+1,k+1))) * & (waves%us_y(i,j,k)-waves%us_y(i,j,k+1)) / & - (0.5*(h_lay + GV%H_to_Z*0.5*(h(i,j,k+1)+h(i,j+1,k+1)) )) - v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_Lay + (0.5*(dz_lay + 0.5*(dz(i,j,k+1)+dz(i,j+1,k+1)) )) + v(i,J,k) = v(i,J,k) + dt * (dTauUp-dTauDn) / h_lay enddo enddo enddo @@ -1658,13 +1671,15 @@ end subroutine CoriolisStokes !! including analytical integration of Stokes shear using multiple-exponential decay !! Stokes drift profile and vertical integration of the resulting pressure !! anomaly to the total pressure gradient force -subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) +subroutine Stokes_PGF(G, GV, US, dz, u, v, PFu_Stokes, PFv_Stokes, CS ) type(ocean_grid_type), & intent(in) :: G !< Ocean grid type(verticalGrid_type), & intent(in) :: GV !< Ocean vertical grid + type(unit_scale_type), & + intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(G)),& - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + intent(in) :: dz !< Layer thicknesses in height units [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), & intent(in) :: u !< Lagrangian Velocity i-component [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & @@ -1737,12 +1752,13 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) zi_l(1) = 0.0 zi_r(1) = 0.0 do k = 1, G%ke - h_l = h(i,j,k)*GV%H_to_Z - h_r = h(i+1,j,k)*GV%H_to_Z + h_l = dz(i,j,k) + h_r = dz(i+1,j,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - Idz_l(k) = 1./max(0.1,h_l) - Idz_r(k) = 1./max(0.1,h_r) + !### If the code were properly refactored, the following hard-coded constants would be unnecessary. + Idz_l(k) = 1./max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1./max(0.1*US%m_to_Z, h_r) enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the @@ -1830,12 +1846,13 @@ subroutine Stokes_PGF(G, GV, h, u, v, PFu_Stokes, PFv_Stokes, CS ) zi_l(1) = 0.0 zi_r(1) = 0.0 do k = 1, G%ke - h_l = h(i,j,k)*GV%H_to_Z - h_r = h(i,j+1,k)*GV%H_to_Z + h_l = dz(i,j,k) + h_r = dz(i,j+1,k) zi_l(k+1) = zi_l(k) - h_l zi_r(k+1) = zi_r(k) - h_r - Idz_l(k) = 1./max(0.1,h_l) - Idz_r(k) = 1./max(0.1,h_r) + !### If the code were properly refactored, the following hard-coded constants would be unnecessary. + Idz_l(k) = 1. / max(0.1*US%m_to_Z, h_l) + Idz_r(k) = 1. / max(0.1*US%m_to_Z, h_r) enddo do k = 1,G%ke ! Computing (left/right) Eulerian velocities assuming the velocity passed to this routine is the From 8f7cc0e19022ba1bb961e1e874aff5474b60d2fc Mon Sep 17 00:00:00 2001 From: claireyung <61528379+claireyung@users.noreply.github.com> Date: Mon, 7 Aug 2023 19:07:47 +1000 Subject: [PATCH 358/629] Ice shelf melt parameterization fixes (#395) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two fixes to the ice shelf melt parameterization in MOM_ice_shelf.F90: (1) the removal of an extra von Kármán constant which differs from the Holland and Jenkins (1999) formulation. My working is detailed in this document. (2) a modification to the it3 loop in shelf_calc_flux subroutine, which currently does not iterate because wB_flux does not get updated to its new value via the Newton solver method. Instead, the loop either runs 30 times with the same value, or is below the threshold and exits on the first loop. I added a line to update the value of wB_flux. Specific changes include: * Remove KV in n_star_term definition * Add line to ice shelf param it3 to correct iteration * Reinstate von Karman constant and rearrange to remove double division * Remove unneeded salt iteration line that overrides option of using false position method * Change value of ZETA_N to be consistent with Holland & Jenkins 99 * Fix typo, ZETA_N should be 0.13 not 0.013 * Add parameter for ZETA_N * Make RC and VK runtime parameters * Add runtime parameters to fix buoyancy iteration bug and salt overwriting false position method bug * Add runtime parameter for buoyancy iteration Newton's method convergence criteria --- src/ice_shelf/MOM_ice_shelf.F90 | 49 +++++++++++++++++++++++++++------ 1 file changed, 40 insertions(+), 9 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 8e0e58c1b6..d0faeb3aae 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -185,6 +185,14 @@ module MOM_ice_shelf !! salinity [C S-1 ~> degC ppt-1] real :: dTFr_dp !< Partial derivative of freezing temperature with !! pressure [C T2 R-1 L-2 ~> degC Pa-1] + real :: Zeta_N !< The stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. + real :: Vk !< Von Karman's constant - dimensionless + real :: Rc !< critical flux Richardson number. + logical :: buoy_flux_itt_bug !< If true, fixes buoyancy iteration bug + logical :: salt_flux_itt_bug !< If true, fixes salt iteration bug + real :: buoy_flux_itt_threshold !< Buoyancy iteration threshold for convergence + !>@{ Diagnostic handles integer :: id_melt = -1, id_exch_vel_s = -1, id_exch_vel_t = -1, & id_tfreeze = -1, id_tfl_shelf = -1, & @@ -261,10 +269,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) !! interface, positive for melting and negative for freezing [S ~> ppt]. !! This is computed as part of the ISOMIP diagnostics. real :: time_step !< Length of time over which these fluxes will be applied [T ~> s]. - real, parameter :: VK = 0.40 !< Von Karman's constant - dimensionless - real :: ZETA_N = 0.052 !> The fraction of the boundary layer over which the - !! viscosity is linearly increasing [nondim]. (Was 1/8. Why?) - real, parameter :: RC = 0.20 ! critical flux Richardson number. + real :: VK !< Von Karman's constant - dimensionless + real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99 + !! divided by the von Karman constant VK. Was 1/8. [nondim] + real :: RC !< critical flux Richardson number. real :: I_ZETA_N !< The inverse of ZETA_N [nondim]. real :: I_LF !< The inverse of the latent heat of fusion [Q-1 ~> kg J-1]. real :: I_VK !< The inverse of the Von Karman constant [nondim]. @@ -346,6 +354,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) endif ! useful parameters is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; ied = G%ied ; jed = G%jed + ZETA_N = CS%Zeta_N + VK = CS%Vk + RC = CS%Rc I_ZETA_N = 1.0 / ZETA_N I_LF = 1.0 / CS%Lat_fusion SC = CS%kv_molec/CS%kd_molec_salt @@ -527,7 +538,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (wB_flux < 0.0) then ! The buoyancy flux is stabilizing and will reduce the turbulent ! fluxes, and iteration is required. - n_star_term = (ZETA_N/RC) * (hBL_neut * VK) / (ustar_h)**3 + n_star_term = (ZETA_N * hBL_neut * VK) / (RC * ustar_h**3) do it3 = 1,30 ! n_star <= 1.0 is the ratio of working boundary layer thickness ! to the neutral thickness. @@ -558,13 +569,15 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) wT_flux = dT_ustar * I_Gam_T wB_flux_new = dB_dS * (dS_ustar * I_Gam_S) + dB_dT * wT_flux - ! Find the root where wB_flux_new = wB_flux. Make the 1.0e-4 below into a parameter? - if (abs(wB_flux_new - wB_flux) < 1.0e-4*(abs(wB_flux_new) + abs(wB_flux))) exit + ! Find the root where wB_flux_new = wB_flux. + if (abs(wB_flux_new - wB_flux) < CS%buoy_flux_itt_threshold*(abs(wB_flux_new) + abs(wB_flux))) exit dDwB_dwB_in = dG_dwB * (dB_dS * (dS_ustar * I_Gam_S**2) + & dB_dT * (dT_ustar * I_Gam_T**2)) - 1.0 ! This is Newton's method without any bounds. Should bounds be needed? wB_flux_new = wB_flux - (wB_flux_new - wB_flux) / dDwB_dwB_in + ! Update wB_flux + if (CS%buoy_flux_itt_bug) wB_flux = wB_flux_new enddo !it3 endif @@ -637,7 +650,8 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) Sbdry(i,j) = Sbdry_it endif ! Sb_min_set - Sbdry(i,j) = Sbdry_it + if (.not.CS%salt_flux_itt_bug) Sbdry(i,j) = Sbdry_it + endif ! CS%find_salt_root enddo !it1 @@ -1514,7 +1528,24 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "READ_TIDEAMP", read_TIDEAMP, & "If true, read a file (given by TIDEAMP_FILE) containing "//& "the tidal amplitude with INT_TIDE_DISSIPATION.", default=.false.) - + call get_param(param_file, mdl, "ICE_SHELF_LINEAR_SHELF_FRAC", CS%Zeta_N, & + "Ratio of HJ99 stability constant xi_N (ratio of maximum "//& + "mixing length to planetary boundary layer depth in "//& + "neutrally stable conditions) to the von Karman constant", & + units="nondim", default=0.13) + call get_param(param_file, mdl, "ICE_SHELF_VK_CNST", CS%Vk, & + "Von Karman constant.", & + units="nondim", default=0.40) + call get_param(param_file, mdl, "ICE_SHELF_RC", CS%Rc, & + "Critical flux Richardson number for ice melt ", & + units="nondim", default=0.20) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_BUG", CS%buoy_flux_itt_bug, & + "Bug fix of buoyancy iteration", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_SALT_FLUX_ITT_BUG", CS%salt_flux_itt_bug, & + "Bug fix of salt iteration", default=.true.) + call get_param(param_file, mdl, "ICE_SHELF_BUOYANCY_FLUX_ITT_THRESHOLD", CS%buoy_flux_itt_threshold, & + "Convergence criterion of Newton's method for ice shelf "//& + "buoyancy iteration.", units="nondim", default=1.0e-4) if (PRESENT(sfc_state_in)) then allocate(sfc_state) From 46c52622cf1d7a39ea9919279bed0b652aad96b7 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 20 Jun 2023 07:36:26 -0400 Subject: [PATCH 359/629] *Use tv%SpV_avg in non-Boussinesq regridding Use SpV_avg in both hybgen_unmix and regridding_main to estimate the nominal ocean bottom depth in thickness units when in fully non-Boussinesq mode. This change eliminates certain dependencies on the Boussinesq reference density via GV%Z_to_H. Also added a call to calc_derived_thermo in ALE_regrid_accelerated that is necessary for the specific volume to be updated, along with tests for the validity of the specific volume with the 1-point halos that are currently used with ALE regridding and remapping. Also, use the total thickness place of the nominal depth in build_grid_rho and build_grid_sigma when in fully non-Boussinesq mode. This is mathematically equivalent but changes answers at roundoff. All answers are bitwise identical in Boussinesq mode, but ALE-based solutions change in fully non-Boussinesq mode with this commit. --- src/ALE/MOM_ALE.F90 | 5 ++- src/ALE/MOM_hybgen_unmix.F90 | 42 ++++++++++++++++++++----- src/ALE/MOM_regridding.F90 | 61 ++++++++++++++++++++++++++---------- 3 files changed, 83 insertions(+), 25 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 2e16933525..b8f60b2830 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -20,7 +20,7 @@ module MOM_ALE use MOM_hybgen_unmix, only : hybgen_unmix, init_hybgen_unmix, end_hybgen_unmix, hybgen_unmix_CS use MOM_hybgen_regrid, only : hybgen_regrid_CS use MOM_file_parser, only : get_param, param_file_type, log_param -use MOM_interface_heights,only : find_eta +use MOM_interface_heights,only : find_eta, calc_derived_thermo use MOM_open_boundary, only : ocean_OBC_type, OBC_DIRECTION_E, OBC_DIRECTION_W use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_regridding, only : initialize_regridding, regridding_main, end_regridding @@ -659,6 +659,9 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! generate new grid if (CS%do_conv_adj) call convective_adjustment(G, GV, h_loc, tv_local) + ! Update the layer specific volumes if necessary + if (allocated(tv_local%SpV_avg)) call calc_derived_thermo(tv_local, h, G, GV, US, halo=1) + call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) diff --git a/src/ALE/MOM_hybgen_unmix.F90 b/src/ALE/MOM_hybgen_unmix.F90 index 024a9baffa..6ddb828abe 100644 --- a/src/ALE/MOM_hybgen_unmix.F90 +++ b/src/ALE/MOM_hybgen_unmix.F90 @@ -9,6 +9,7 @@ module MOM_hybgen_unmix use MOM_file_parser, only : get_param, param_file_type, log_param use MOM_hybgen_regrid, only : hybgen_column_init use MOM_hybgen_regrid, only : hybgen_regrid_CS, get_hybgen_regrid_params +use MOM_interface_heights, only : calc_derived_thermo use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : ocean_grid_type, thermo_var_ptrs @@ -146,7 +147,8 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) real :: p_col(GV%ke) ! A column of reference pressures [R L2 T-2 ~> Pa] real :: tracer(GV%ke,max(ntr,1)) ! Columns of each tracer [Conc] real :: h_tot ! Total thickness of the water column [H ~> m or kg m-2] - real :: nominalDepth ! Depth of ocean bottom (positive downward) [H ~> m or kg m-2] + real :: dz_tot ! Vertical distance between the top and bottom of the water column [Z ~> m] + real :: nominalDepth ! Depth of ocean bottom in thickness units (positive downward) [H ~> m or kg m-2] real :: h_thin ! A negligibly small thickness to identify essentially ! vanished layers [H ~> m or kg m-2] real :: dilate ! A factor by which to dilate the target positions from z to z* [nondim] @@ -169,6 +171,15 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) h_thin = 1e-6*GV%m_to_H debug_conservation = .false. ! Set this to true for debugging + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "hybgen_unmix called in fully non-Boussinesq mode with "//trim(mesg)) + endif + p_col(:) = CS%ref_pressure do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 ; if (G%mask2dT(i,j)>0.) then @@ -203,13 +214,27 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) endif ! The following block of code is used to trigger z* stretching of the targets heights. - nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H - if (h_tot <= CS%min_dilate*nominalDepth) then - dilate = CS%min_dilate - elseif (h_tot >= CS%max_dilate*nominalDepth) then - dilate = CS%max_dilate + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussiesq version + dz_tot = 0.0 + do k=1,nk + dz_tot = dz_tot + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h_col(k) + enddo + if (dz_tot <= CS%min_dilate*(G%bathyT(i,j)+G%Z_ref)) then + dilate = CS%min_dilate + elseif (dz_tot >= CS%max_dilate*(G%bathyT(i,j)+G%Z_ref)) then + dilate = CS%max_dilate + else + dilate = dz_tot / (G%bathyT(i,j)+G%Z_ref) + endif else - dilate = h_tot / nominalDepth + nominalDepth = (G%bathyT(i,j)+G%Z_ref)*GV%Z_to_H + if (h_tot <= CS%min_dilate*nominalDepth) then + dilate = CS%min_dilate + elseif (h_tot >= CS%max_dilate*nominalDepth) then + dilate = CS%max_dilate + else + dilate = h_tot / nominalDepth + endif endif terrain_following = (h_tot < dilate*CS%dpns) .and. (CS%dpns >= CS%dsns) @@ -268,6 +293,9 @@ subroutine hybgen_unmix(G, GV, US, CS, tv, Reg, ntr, h) endif endif ; enddo ; enddo !i & j. + ! Update the layer properties + if (allocated(tv%SpV_avg)) call calc_derived_thermo(tv, h, G, GV, US, halo=1) + end subroutine hybgen_unmix diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 5c4a76c7e5..c238c2aa61 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -814,20 +814,47 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & ! Local variables real :: nom_depth_H(SZI_(G),SZJ_(G)) !< The nominal ocean depth at each point in thickness units [H ~> m or kg m-2] + real :: tot_h(SZI_(G),SZJ_(G)) !< The total thickness of the water column [H ~> m or kg m-2] + real :: tot_dz(SZI_(G),SZJ_(G)) !< The total distance between the top and bottom of the water column [Z ~> m] real :: Z_to_H ! A conversion factor used by some routines to convert coordinate ! parameters to depth units [H Z-1 ~> nondim or kg m-3] real :: trickGnuCompiler - integer :: i, j + character(len=128) :: mesg ! A string for error messages + integer :: i, j, k if (present(PCM_cell)) PCM_cell(:,:,:) = .false. Z_to_H = US%Z_to_m * GV%m_to_H ! Often this is equivalent to GV%Z_to_H. - do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * Z_to_H - ! Consider using the following instead: - ! nom_depth_H(i,j) = max( (G%bathyT(i,j)+G%Z_ref) * Z_to_H , CS%min_nom_depth ) - ! if (G%mask2dT(i,j)==0.) nom_depth_H(i,j) = 0.0 - enddo ; enddo + + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < 1)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + mesg = "insufficiently large SpV_avg halos of width 0 but 1 is needed." + endif + call MOM_error(FATAL, "Regridding_main called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + if (allocated(tv%SpV_avg)) then ! This is the fully non-Boussinesq case + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = 0.0 ; tot_dz(i,j) = 0.0 + enddo ; enddo + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + tot_h(i,j) = tot_h(i,j) + h(i,j,k) + tot_dz(i,j) = tot_dz(i,j) + GV%H_to_RZ * tv%SpV_avg(i,j,k) * h(i,j,k) + enddo ; enddo ; enddo + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + if ((tot_dz(i,j) > 0.0) .and. (G%bathyT(i,j)+G%Z_ref > 0.0)) then + nom_depth_H(i,j) = (G%bathyT(i,j)+G%Z_ref) * (tot_h(i,j) / tot_dz(i,j)) + else + nom_depth_H(i,j) = 0.0 + endif + enddo ; enddo + else + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + nom_depth_H(i,j) = max((G%bathyT(i,j)+G%Z_ref) * Z_to_H, 0.0) + enddo ; enddo + endif select case ( CS%regridding_scheme ) @@ -1308,12 +1335,12 @@ subroutine build_sigma_grid( CS, G, GV, h, nom_depth_H, dzInterface ) ! In sigma coordinates, the bathymetric depth is only used as an arbitrary offset that ! cancels out when determining coordinate motion, so referencing the column postions to ! the surface is perfectly acceptable, but for preservation of previous answers the - ! referencing is done relative to the bottom when in Boussinesq mode. - ! if (GV%Boussinesq) then + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then nominalDepth = nom_depth_H(i,j) - ! else - ! nominalDepth = totalThickness - ! endif + else + nominalDepth = totalThickness + endif call build_sigma_column(CS%sigma_CS, nominalDepth, totalThickness, zNew) @@ -1436,12 +1463,12 @@ subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, ! In rho coordinates, the bathymetric depth is only used as an arbitrary offset that ! cancels out when determining coordinate motion, so referencing the column postions to ! the surface is perfectly acceptable, but for preservation of previous answers the - ! referencing is done relative to the bottom when in Boussinesq mode. - ! if (GV%Boussinesq) then + ! referencing is done relative to the bottom when in Boussinesq or semi-Boussinesq mode. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then nominalDepth = nom_depth_H(i,j) - ! else - ! nominalDepth = totalThickness - ! endif + else + nominalDepth = totalThickness + endif ! Determine absolute interface positions zOld(nz+1) = - nominalDepth From ba70663e3e2d688e6a11bedd891fe3b5bee7b3fc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 08:38:42 -0400 Subject: [PATCH 360/629] *Non-Boussinesq revision of diabatic_driver This commit completes the non-Boussinesq revision of the diabatic_driver code. The revised code uses thickness_to_dz and works with internal variables in vertical distances in the denominator of diffusive flux calculations in diabatic_ALE_legacy, diabatic_ALE and layered_diabatic. The code now uses find_ustar to extract the friction velocities passed to KPP_compute. The (tiny) boundary layer tracer diffusivity is also rescaled to [H2 T-1]. With this set of changes, all implicit references to Boussinesq reference density are eliminated from the calculations in diabatic_driver when in non-Boussinesq mode. A total of 14 thickness rescaling factors were cancelled out, and there are 15 new or renamed variables in the diabatic routines. 4 new checksum calls are also added to diabatic_ALE_legacy to assist in debugging. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode, but in non-Boussinesq mode the use of the layer averaged specific volume to convert thicknesses to vertical distances leads to changing answers. --- .../vertical/MOM_diabatic_driver.F90 | 170 +++++++++++------- 1 file changed, 107 insertions(+), 63 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index dae52592e9..b2b8527819 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -12,8 +12,9 @@ module MOM_diabatic_driver use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used use MOM_diabatic_aux, only : diabatic_aux_init, diabatic_aux_end, diabatic_aux_CS use MOM_diabatic_aux, only : make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS -use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h, diagnoseMLDbyDensityDifference -use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, diagnoseMLDbyEnergy, set_pen_shortwave +use MOM_diabatic_aux, only : triDiagTS_Eulerian, find_uv_at_h +use MOM_diabatic_aux, only : applyBoundaryFluxesInOut, set_pen_shortwave +use MOM_diabatic_aux, only : diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : post_product_sum_u, post_product_sum_v use MOM_diag_mediator, only : diag_ctrl, time_type, diag_update_remap_grids @@ -36,14 +37,14 @@ module MOM_diabatic_driver use MOM_error_handler, only : MOM_error, FATAL, WARNING, callTree_showQuery,MOM_mesg use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type, read_param -use MOM_forcing_type, only : forcing, MOM_forcing_chksum +use MOM_forcing_type, only : forcing, MOM_forcing_chksum, find_ustar use MOM_forcing_type, only : calculateBuoyancyFlux2d, forcing_SinglePointPrint use MOM_geothermal, only : geothermal_entraining, geothermal_in_place use MOM_geothermal, only : geothermal_init, geothermal_end, geothermal_CS 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, calc_derived_thermo +use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz 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 @@ -145,8 +146,8 @@ module MOM_diabatic_driver !! diffusivity of Kd_min_tr (see below) were operating. real :: Kd_BBL_tr !< A bottom boundary layer tracer diffusivity that !! will allow for explicitly specified bottom fluxes - !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. The entrainment at the bottom is at - !! least sqrt(Kd_BBL_tr*dt) over the same distance. + !! [H2 T-1 ~> m2 s-1 or kg2 m-4 s-2]. The entrainment at the + !! bottom is at least sqrt(Kd_BBL_tr*dt) over the same distance. real :: Kd_min_tr !< A minimal diffusivity that should always be !! applied to tracers, especially in massless layers !! near the bottom [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -170,8 +171,6 @@ module MOM_diabatic_driver 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 - integer, allocatable, dimension(:) :: id_cn ! diagnostic handle for all mode speeds integer :: id_ea = -1, id_eb = -1 ! used by layer diabatic integer :: id_ea_t = -1, id_eb_t = -1, id_ea_s = -1, id_eb_s = -1 integer :: id_Kd_heat = -1, id_Kd_salt = -1, id_Kd_int = -1, id_Kd_ePBL = -1 @@ -530,6 +529,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. @@ -555,6 +555,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & @@ -562,11 +563,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! sufficiently thick that the no-flux boundary conditions have not restricted ! the entrainment - usually sqrt(Kd*dt). - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] - real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: Kd_add_here ! An added diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. @@ -580,7 +581,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim 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 ; h_neglect2 = h_neglect*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 showCallTree = callTree_showQuery() @@ -674,19 +676,22 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif if (associated(Hml)) then @@ -775,15 +780,18 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_shear) endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US) + ! This block sets ent_t and ent_s from h and Kd_int. do j=js,je ; do i=is,ie ent_s(i,j,1) = 0.0 ; ent_s(i,j,nz+1) = 0.0 ent_t(i,j,1) = 0.0 ; ent_t(i,j,nz+1) = 0.0 enddo ; enddo - !$OMP parallel do default(shared) private(I_hval) + !$OMP parallel do default(shared) private(I_dzval) do K=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_int(i,j,K) + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_s(i,j,K) = dt * I_dzval * Kd_int(i,j,K) ent_t(i,j,K) = ent_s(i,j,K) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_s and ent_t from Kd_int (diabatic)") @@ -826,6 +834,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim scale=US%kg_m3_to_R*US%degC_to_C) call hchksum(dSV_dS, "after applyBoundaryFluxes dSV_dS", G%HI, haloshift=0, & scale=US%kg_m3_to_R*US%ppt_to_S) + call hchksum(h, "after applyBoundaryFluxes h", G%HI, haloshift=0, scale=GV%H_to_mks) + call hchksum(tv%T, "after applyBoundaryFluxes tv%T", G%HI, haloshift=0, scale=US%C_to_degC) + call hchksum(tv%S, "after applyBoundaryFluxes tv%S", G%HI, haloshift=0, scale=US%S_to_ppt) + call hchksum(SkinBuoyFlux, "after applyBdryFlux SkinBuoyFlux", G%HI, haloshift=0, & + scale=US%Z_to_m**2*US%s_to_T**3) endif call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -846,6 +859,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) endif + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie if (CS%ePBL_is_additive) then @@ -856,7 +872,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim visc%Kv_shear(i,j,K) = max(visc%Kv_shear(i,j,K), CS%ePBL_Prandtl*Kd_ePBL(i,j,K)) endif - Ent_int = Kd_add_here * (GV%Z_to_H * dt) / (0.5*(h(i,j,k-1) + h(i,j,k)) + h_neglect) + Ent_int = Kd_add_here * dt / (0.5*(dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) ent_s(i,j,K) = ent_s(i,j,K) + Ent_int Kd_int(i,j,K) = Kd_int(i,j,K) + Kd_add_here @@ -877,6 +893,9 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + endif ! endif for CS%use_energetic_PBL ! diagnose the tendencies due to boundary forcing @@ -1002,7 +1021,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je @@ -1021,8 +1040,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_int, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + add_ent = ((dt * CS%Kd_min_tr)) * & + ((dz(i,j,k-1)+dz(i,j,k)+dz_neglect) / (dz(i,j,k-1)*dz(i,j,k)+dz_neglect2)) - & 0.5*(ent_s(i,j,K) + ent_s(i,j,K)) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) @@ -1034,8 +1053,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & - (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) ent_s(i,j,K) = ent_s(i,j,K) + add_ent endif ; endif enddo ; enddo @@ -1045,8 +1064,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,k) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,k)) * GV%Z_to_H) / & - (0.5 * (h(i,j,k-1) + h(i,j,k)) + h_neglect) + add_ent = (dt * Kd_extra_S(i,j,k)) / & + (0.5 * (dz(i,j,k-1) + dz(i,j,k)) + dz_neglect) else add_ent = 0.0 endif @@ -1126,6 +1145,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & h_orig, & ! Initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] dSV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] dSV_dS, & ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. cTKE, & ! convective TKE requirements for each layer [R Z3 T-2 ~> J m-2]. @@ -1151,18 +1171,18 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & in_boundary ! True if there are no massive layers below, where massive is defined as ! sufficiently thick that the no-flux boundary conditions have not restricted ! the entrainment - usually sqrt(Kd*dt). - - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] - real :: I_hval ! The inverse of the thicknesses averaged to interfaces [H-1 ~> m-1 or m2 kg-1] + real :: I_dzval ! The inverse of the thicknesses averaged to interfaces [Z-1 ~> m-1] real :: Tr_ea_BBL ! The diffusive tracer thickness in the BBL that is ! coupled to the bottom within a timestep [H ~> m or kg m-2] real :: htot(SZIB_(G)) ! The summed thickness from the bottom [H ~> m or kg m-2]. @@ -1174,7 +1194,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, 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 ; h_neglect2 = h_neglect*h_neglect + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect + Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 ent_s(:,:,:) = 0.0 ; ent_t(:,:,:) = 0.0 @@ -1276,18 +1297,21 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -1464,17 +1488,20 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo endif + ! Find the vertical distances across layers, which may have been modified by the net surface flux + call thickness_to_dz(h, tv, dz, G, GV, US) + ! set ent_t=dt*Kd_heat/h_int and est_s=dt*Kd_salt/h_int on interfaces for use in the tridiagonal solver. do j=js,je ; do i=is,ie ent_t(i,j,1) = 0. ; ent_t(i,j,nz+1) = 0. ent_s(i,j,1) = 0. ; ent_s(i,j,nz+1) = 0. enddo ; enddo - !$OMP parallel do default(shared) private(I_hval) + !$OMP parallel do default(shared) private(I_dzval) do K=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (h_neglect + 0.5*(h(i,j,k-1) + h(i,j,k))) - ent_t(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_heat(i,j,k) - ent_s(i,j,K) = GV%Z_to_H * dt * I_hval * Kd_salt(i,j,k) + I_dzval = 1.0 / (dz_neglect + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + ent_t(i,j,K) = dt * I_dzval * Kd_heat(i,j,k) + ent_s(i,j,K) = dt * I_dzval * Kd_salt(i,j,k) enddo ; enddo ; enddo if (showCallTree) call callTree_waypoint("done setting ent_t and ent_t from Kd_heat and " //& "Kd_salt (diabatic_ALE)") @@ -1540,7 +1567,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call cpu_clock_begin(id_clock_tracers) if (CS%mix_boundary_tracer_ALE) then - Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -1554,8 +1581,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! bottom, add some mixing of tracers between these layers. This flux is based on the ! harmonic mean of the two thicknesses, following what is done in layered mode. Kd_min_tr ! should be much less than the values in Kd_salt, perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & - ((h(i,j,k-1)+h(i,j,k) + h_neglect) / (h(i,j,k-1)*h(i,j,k) + h_neglect2)) - & + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1)+dz(i,j,k) + dz_neglect) / (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & ent_s(i,j,K) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, (Tr_ea_BBL - htot(i)) - ent_s(i,j,K)) @@ -1648,13 +1675,17 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! one time step [H ~> m or kg m-2] Kd_lay, & ! diapycnal diffusivity of layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] h_orig, & ! initial layer thicknesses [H ~> m or kg m-2] + dz, & ! The vertical distance between interfaces around a layer [Z ~> m] hold, & ! layer thickness before diapycnal entrainment, and later the initial ! layer thicknesses (if a mixed layer is used) [H ~> m or kg m-2] + dz_old, & ! The initial vertical distance between interfaces around a layer + ! or the distance before entrainment [Z ~> m] u_h, & ! Zonal velocities at thickness points after entrainment [L T-1 ~> m s-1] v_h, & ! Meridional velocities at thickness points after entrainment [L T-1 ~> m s-1] temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)) :: & + U_star, & ! The friction velocity [Z T-1 ~> m s-1]. Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & @@ -1697,7 +1728,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2] - real :: h_neglect2 ! h_neglect^2 [H2 ~> m2 or kg2 m-4] + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m] + real :: dz_neglect2 ! dz_neglect^2 [Z2 ~> m2] real :: net_ent ! The net of ea-eb at an interface [H ~> m or kg m-2] real :: add_ent ! Entrainment that needs to be added when mixing tracers [H ~> m or kg m-2] real :: eaval ! eaval is 2*ea at velocity grid points [H ~> m or kg m-2] @@ -1724,7 +1757,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e 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 nkmb = GV%nk_rho_varies - h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect*h_neglect + h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 @@ -1885,17 +1919,20 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo ; enddo endif + ! Determine the friction velocity, perhaps using the evovling surface density. + call find_ustar(fluxes, tv, U_star, G, GV, US) + if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - fluxes%ustar, CS%KPP_buoy_flux, Waves=Waves) + U_star, CS%KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, fluxes%ustar, CS%KPP_buoy_flux, Kd_heat, & + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) endif @@ -2300,8 +2337,15 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixing of passive tracers from massless boundary layers to interior call cpu_clock_begin(id_clock_tracers) + + ! Find the vertical distances across layers. + if (CS%mix_boundary_tracers .or. CS%double_diffuse) & + call thickness_to_dz(h, tv, dz, G, GV, US) + if (CS%double_diffuse) & + call thickness_to_dz(hold, tv, dz_old, G, GV, US) + if (CS%mix_boundary_tracers) then - Tr_ea_BBL = sqrt(dt * GV%Z_to_H * CS%Kd_BBL_tr) + Tr_ea_BBL = sqrt(dt * CS%Kd_BBL_tr) !$OMP parallel do default(shared) private(htot,in_boundary,add_ent) do j=js,je do i=is,ie @@ -2320,9 +2364,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! in the calculation of the fluxes in the first place. Kd_min_tr ! should be much less than the values that have been set in Kd_lay, ! perhaps a molecular diffusivity. - add_ent = ((dt * CS%Kd_min_tr) * GV%Z_to_H) * & - ((h(i,j,k-1)+h(i,j,k)+h_neglect) / & - (h(i,j,k-1)*h(i,j,k)+h_neglect2)) - & + add_ent = (dt * CS%Kd_min_tr) * & + ((dz(i,j,k-1) + dz(i,j,k) + dz_neglect) / & + (dz(i,j,k-1)*dz(i,j,k) + dz_neglect2)) - & 0.5*(ea(i,j,k) + eb(i,j,k-1)) if (htot(i) < Tr_ea_BBL) then add_ent = max(0.0, add_ent, & @@ -2337,9 +2381,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ebtr(i,j,k-1) = eb(i,j,k-1) ; eatr(i,j,k) = ea(i,j,k) endif if (CS%double_diffuse) then ; if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) ebtr(i,j,k-1) = ebtr(i,j,k-1) + add_ent eatr(i,j,k) = eatr(i,j,k) + add_ent endif ; endif @@ -2361,9 +2404,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e !$OMP parallel do default(shared) private(add_ent) do k=nz,2,-1 ; do j=js,je ; do i=is,ie if (Kd_extra_S(i,j,K) > 0.0) then - add_ent = ((dt * Kd_extra_S(i,j,K)) * GV%Z_to_H) / & - (0.25 * ((h(i,j,k-1) + h(i,j,k)) + (hold(i,j,k-1) + hold(i,j,k))) + & - h_neglect) + add_ent = (dt * Kd_extra_S(i,j,K)) / & + (0.25 * ((dz(i,j,k-1) + dz(i,j,k)) + (dz_old(i,j,k-1) + dz_old(i,j,k))) + dz_neglect) else add_ent = 0.0 endif @@ -3095,7 +3137,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di "A bottom boundary layer tracer diffusivity that will "//& "allow for explicitly specified bottom fluxes. The "//& "entrainment at the bottom is at least sqrt(Kd_BBL_tr*dt) "//& - "over the same distance.", units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T) + "over the same distance.", & + units="m2 s-1", default=0., scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) + ! The scaling factor here is usually equivalent to GV%m2_s_to_HZ_T*GV%Z_to_H. endif call get_param(param_file, mdl, "TRACER_TRIDIAG", CS%tracer_tridiag, & From 648012edff219ab8f65d6376d6524b60ac12ed29 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 4 Aug 2023 11:39:28 -0800 Subject: [PATCH 361/629] Adding a knob for strength of brine plume mixing. --- src/parameterizations/vertical/MOM_diabatic_aux.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index f176b0d726..6a5e454d19 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -71,6 +71,7 @@ module MOM_diabatic_aux logical :: do_brine_plume !< If true, insert salt flux below the surface according to !! a parameterization by \cite Nguyen2009. integer :: brine_plume_n !< The exponent in the brine plume parameterization. + real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed layer. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -1425,7 +1426,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Place forcing into this layer by depth for brine plume parameterization. if (k == 1) then dK(i) = 0.5 * h(i,j,k) * GV%H_to_Z ! Depth of center of layer K - plume_flux = - (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) * GV%RZ_to_H + plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H plume_fraction = 1.0 else dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K @@ -1440,8 +1441,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t plume_fraction = min(fraction_left_brine, h2d(i,k)*IforcingDepthScale) endif fraction_left_brine = fraction_left_brine - plume_fraction - plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * fluxes%salt_left_behind(i,j)) & - * GV%RZ_to_H + plume_flux = plume_flux + plume_fraction * (1000.0*US%ppt_to_S * (CS%plume_strength * & + fluxes%salt_left_behind(i,j))) * GV%RZ_to_H else plume_flux = 0.0 endif @@ -1767,6 +1768,9 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call get_param(param_file, mdl, "BRINE_PLUME_EXPONENT", CS%brine_plume_n, & "If using the brine plume parameterization, set the integer exponent.", & default=5, do_not_log=.not.CS%do_brine_plume) + call get_param(param_file, mdl, "BRINE_PLUME_FRACTION", CS%plume_strength, & + "Fraction of the available brine to mix down using the brine plume parameterization.", & + units="nondim", default=1.0, do_not_log=.not.CS%do_brine_plume) if (useALEalgorithm) then CS%id_createdH = register_diag_field('ocean_model',"created_H",diag%axesT1, & From 07713af190222538c08aa7fafa99c46ab226d09e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:50:21 -0400 Subject: [PATCH 362/629] +*Ignore SURFACE_ANSWER_DATE when non-Boussinesq Ignore SURFACE_ANSWER_DATE in non-Boussinesq mode and always allocate tv%SpV_avg in fully non-Boussinesq mode, setting it to the inverse of the layer densities in calc_derived_thermo() if there is no equation of state. Also when in fully non-Boussinesq mode cancelled out some rescaling factors in dz_to_thickness_EOS and dz_to_thickness_tv. Also revised dz_to_thickness_simple in non-Boussinesq and non-layered mode to use RHO_KV_CONVERT instead of RHO_0 to rescale vertical distances to thicknesses. Also set the default value of CALC_RHO_FOR_SEA_LEVEL to true when fully non-Boussinesq. All Boussinesq answers are bitwise identical, but some non-Boussinesq answers do change and become less dependent on the Boussinesq reference density. Because SURFACE_ANSWER_DATE is no longer being used in non-Boussinesq mode, is is no longer being logged in the MOM_parameter_doc files for these experiments. --- src/core/MOM.F90 | 6 ++-- src/core/MOM_interface_heights.F90 | 44 ++++++++++++++++++++++-------- 2 files changed, 36 insertions(+), 14 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9cbb744560..c9b8ea42c0 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2103,7 +2103,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "CALC_RHO_FOR_SEA_LEVEL", CS%calc_rho_for_sea_lev, & "If true, the in-situ density is used to calculate the "//& "effective sea level that is returned to the coupler. If false, "//& - "the Boussinesq parameter RHO_0 is used.", default=.false.) + "the Boussinesq parameter RHO_0 is used.", default=non_Bous) call get_param(param_file, "MOM", "ENABLE_THERMODYNAMICS", use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) @@ -2892,8 +2892,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif endif - ! Allocate any derived equation of state fields. - if (use_temperature .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + ! Allocate any derived densities or other equation of state derived fields. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then allocate(CS%tv%SpV_avg(isd:ied,jsd:jed,nz), source=0.0) CS%tv%valid_SpV_halo = -1 ! This array does not yet have any valid data. endif diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 1893859fe7..0a579db299 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -279,6 +279,8 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) ! 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] + real, dimension(SZK_(GV)) :: SpV_lay ! The specific volume of each layer when no equation of + ! state is used [R-1 ~> m3 kg-1] logical :: do_debug ! If true, write checksums for debugging. integer :: i, j, k, is, ie, js, je, halos, nz @@ -310,6 +312,12 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) call hchksum(tv%T, "derived_thermo T", G%HI, haloshift=halos, scale=US%C_to_degC) call hchksum(tv%S, "derived_thermo S", G%HI, haloshift=halos, scale=US%S_to_ppt) endif + elseif (allocated(tv%Spv_avg)) then + do k=1,nz ; SpV_lay(k) = 1.0 / GV%Rlay(k) ; enddo + do k=1,nz ; do j=js,je ; do i=is,ie + tv%SpV_avg(i,j,k) = SpV_lay(k) + enddo ; enddo ; enddo + tv%valid_SpV_halo = halos endif end subroutine calc_derived_thermo @@ -481,9 +489,7 @@ subroutine dz_to_thickness_tv(dz, tv, h, G, GV, US, halo_size) 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) + h(i,j,k) = (GV%RZ_to_H * GV%Rlay(k)) * dz(i,j,k) enddo ; enddo ; enddo endif endif @@ -551,10 +557,16 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s 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 + ! The following two expressions are mathematically equivalent. + if (GV%semi_Boussinesq) then + do i=is,ie + 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 + else + do i=is,ie + p_bot(i,j) = p_top(i,j) + rho(i) * (GV%g_Earth * dz(i,j,k)) + enddo + endif enddo do itt=1,max_itt @@ -565,9 +577,15 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s 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 + if (GV%semi_Boussinesq) then + 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 + else + do i=is,ie + p_bot(i,j) = p_bot(i,j) + rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) + enddo + endif enddo ; endif enddo @@ -608,7 +626,7 @@ subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) 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 + 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 @@ -616,6 +634,10 @@ subroutine dz_to_thickness_simple(dz, h, G, GV, US, halo_size, layer_mode) 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 + else + do k=1,nz ; do j=js,je ; do i=is,ie + h(i,j,k) = (US%Z_to_m * GV%m_to_H) * dz(i,j,k) + enddo ; enddo ; enddo endif end subroutine dz_to_thickness_simple From 597bbf119e83405c005b98f280c82224a9f535bb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Aug 2023 04:59:06 -0400 Subject: [PATCH 363/629] +*Non-Boussinesq revision of full_convection This commit revises full_convection to avoid any dependency on the Boussinesq reference density when in non-Boussinesq mode. Specifically, it changes the units of the Kddt_smooth argument to full_convection and its counterpart in smoothed_dRdT_dRdS to use units of [H Z ~> m2 or kg s-1], which becomes a mass based diffusivity when in non-Boussinesq mode. This change also uses vertical distances for internal calculations in smoothed_dRdT_dRdS, and includes a call to thickness_to_dz in the full_convection routine. This commit also revises the unit conversion of the (absurdly large) mixing length in unstable points in full_convection and of the (tiny) added smoothing distance used in the denominators of some expressions in smoothed_dRdT_dRdS to avoid division by zero with massless layers so that they are both based on the density used in rescaling input parameters (RHO_KV_CONVERT), and do not depend directly on the Boussinesq reference density (RHO_0). These parameters would have been set via get_param calls, but there is no control structure for full_convection parameters. All Boussinesq answers are bitwise identical, but non-Boussinesq answers are altered by the use of the layer specific volumes, rather than the Boussinesq reference density, to convert layer thicknesses into vertical distances. This commit includes a change to the units of an argument (Kddt_smooth) to a publicly visible interface (full_convection). --- .../vertical/MOM_full_convection.F90 | 44 +++++++++++-------- .../vertical/MOM_set_diffusivity.F90 | 2 +- 2 files changed, 27 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_full_convection.F90 b/src/parameterizations/vertical/MOM_full_convection.F90 index 344511bf29..a5fba3adc6 100644 --- a/src/parameterizations/vertical/MOM_full_convection.F90 +++ b/src/parameterizations/vertical/MOM_full_convection.F90 @@ -3,11 +3,12 @@ module MOM_full_convection ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs, EOS_domain +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs, EOS_domain implicit none ; private @@ -31,15 +32,16 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(out) :: S_adj !< Adjusted salinity [S ~> ppt]. real, dimension(:,:), pointer :: p_surf !< The pressure at the ocean surface [R L2 T-2 ~> Pa] (or NULL). - real, intent(in) :: Kddt_smooth !< A smoothing vertical - !! diffusivity times a timestep [H2 ~> m2 or kg2 m-4]. + real, intent(in) :: Kddt_smooth !< A smoothing vertical diffusivity + !! times a timestep [H Z ~> m2 or kg m-1]. integer, intent(in) :: halo !< Halo width over which to compute ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & dRho_dT, & ! The derivative of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS ! The derivative of density with salinity [R S-1 ~> kg m-3 ppt-1]. - real :: h_neglect, h0 ! A thickness that is so small it is usually lost + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] + real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. ! logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. real, dimension(SZI_(G),SZK0_(G)) :: & @@ -90,15 +92,17 @@ subroutine full_convection(G, GV, US, h, tv, T_adj, S_adj, p_surf, Kddt_smooth, if (.not.associated(tv%eqn_of_state)) return h_neglect = GV%H_subroundoff - mix_len = (1.0e20 * nz) * (G%max_depth * GV%Z_to_H) - h0 = 1.0e-16*sqrt(Kddt_smooth) + h_neglect + mix_len = (1.0e20 * nz) * (G%max_depth * US%Z_to_m * GV%m_to_H) do j=js,je mix(:,:) = 0.0 ; d_b(:,:) = 1.0 ! These would be Te_b(:,:) = tv%T(:,j,:), etc., but the values are not used Te_b(:,:) = 0.0 ; Se_b(:,:) = 0.0 - call smoothed_dRdT_dRdS(h, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV, halo_size=halo) + + call smoothed_dRdT_dRdS(h, dz, tv, Kddt_smooth, dRho_dT, dRho_dS, G, GV, US, j, p_surf, halo) do i=is,ie do_i(i) = (G%mask2dT(i,j) > 0.0) @@ -306,14 +310,16 @@ end function is_unstable !> Returns the partial derivatives of locally referenced potential density with !! temperature and salinity after the properties have been smoothed with a small !! constant diffusivity. -subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, halo) +subroutine smoothed_dRdT_dRdS(h, dz, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, 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 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)), & + intent(in) :: dz !< Height change across layers [Z ~> m] type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various !! thermodynamic variables - real, intent(in) :: Kddt !< A diffusivity times a time increment [H2 ~> m2 or kg2 m-4]. + real, intent(in) :: Kddt !< A diffusivity times a time increment [H Z ~> m2 or kg m-1]. real, dimension(SZI_(G),SZK_(GV)+1), & intent(out) :: dR_dT !< Derivative of locally referenced !! potential density with temperature [R C-1 ~> kg m-3 degC-1] @@ -336,8 +342,9 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h real :: pres(SZI_(G)) ! Interface pressures [R L2 T-2 ~> Pa]. real :: T_EOS(SZI_(G)) ! Filtered and vertically averaged temperatures [C ~> degC] real :: S_EOS(SZI_(G)) ! Filtered and vertically averaged salinities [S ~> ppt] - real :: kap_dt_x2 ! The product of 2*kappa*dt [H2 ~> m2 or kg2 m-4]. - real :: h_neglect, h0 ! Negligible thicknesses to allow for zero thicknesses, + real :: kap_dt_x2 ! The product of 2*kappa*dt [H Z ~> m2 or kg m-1]. + real :: dz_neglect, h0 ! A negligible vertical distances [Z ~> m] + real :: h_neglect ! A negligible thickness to allow for zero thicknesses ! [H ~> m or kg m-2]. real :: h_tr ! The thickness at tracer points, plus h_neglect [H ~> m or kg m-2]. integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -347,6 +354,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h nz = GV%ke h_neglect = GV%H_subroundoff + dz_neglect = GV%dz_subroundoff kap_dt_x2 = 2.0*Kddt if (Kddt <= 0.0) then @@ -354,9 +362,9 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h T_f(i,k) = tv%T(i,j,k) ; S_f(i,k) = tv%S(i,j,k) enddo ; enddo else - h0 = 1.0e-16*sqrt(Kddt) + h_neglect + h0 = 1.0e-16*sqrt(GV%H_to_m*US%m_to_Z*Kddt) + dz_neglect do i=is,ie - mix(i,2) = kap_dt_x2 / ((h(i,j,1)+h(i,j,2)) + h0) + mix(i,2) = kap_dt_x2 / ((dz(i,1)+dz(i,2)) + h0) h_tr = h(i,j,1) + h_neglect b1(i) = 1.0 / (h_tr + mix(i,2)) @@ -365,7 +373,7 @@ subroutine smoothed_dRdT_dRdS(h, tv, Kddt, dR_dT, dR_dS, G, GV, US, j, p_surf, h S_f(i,1) = (b1(i)*h_tr)*tv%S(i,j,1) enddo do k=2,nz-1 ; do i=is,ie - mix(i,K+1) = kap_dt_x2 / ((h(i,j,k)+h(i,j,k+1)) + h0) + mix(i,K+1) = kap_dt_x2 / ((dz(i,k)+dz(i,k+1)) + h0) c1(i,k) = mix(i,K) * b1(i) h_tr = h(i,j,k) + h_neglect diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index b3b49e0772..32553de3d1 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -344,7 +344,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i call cpu_clock_begin(id_clock_kappaShear) if (CS%Vertex_shear) then call full_convection(G, GV, US, h, tv, T_f, S_f, fluxes%p_surf, & - GV%Z_to_H*kappa_dt_fill, halo=1) + kappa_dt_fill, halo=1) call calc_kappa_shear_vertex(u, v, h, T_f, S_f, tv, fluxes%p_surf, visc%Kd_shear, & visc%TKE_turb, visc%Kv_shear_Bu, dt, G, GV, US, CS%kappaShear_CSp) From 3ce1368c64a60f634ec11222392fd50e94132ecb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 1 Aug 2023 23:11:56 -0400 Subject: [PATCH 364/629] +*Non-Boussinesq revision of MOM_vertvisc.F90 Revised the code in MOM_vertvisc.F90 to work internally with thickness-based units for the viscous coupling between layers, which eliminates any dependence on the value of GV%Rho_0 in non-Boussinesq mode. Various kinematic viscosities are replaced with dynamic viscosities in non-Boussinesq configurations, including revising the scaled units of the viscosities to [H Z T-1 ~> m2 s-1 or Pa s]. This commit also modifies the code to explicitly use vertical distances rather than thicknesses when calculating the vertical viscous coupling coefficients in vertvisc_coef and find_coupling_coef. This commit changes the units of numerous variables to use thickness, vertical distance, dynamic viscosity or other related units, including: - 14 elements in the vertvisc_CS type - 6 arguments to the private routine find_coupling_coef - 2 arguments to the private routine find_coupling_coef_gl90 - 1 arguments ("a") to the public routine write_u_accel - 1 arguments ("a") to the public routine write_v_accel - 1 internal variable in vertvisc - 1 internal variable in vertvisc_remnant - 23 internal variables in vertvisc_coef, - 7+4+4+3 internal variables in find_coupling_coef, - 1 internal variable in find_coupling_coef_gl90 Local variables that are no longer needed were eliminated in vertvisc and vertvisc_remnant, while 2 new local variables were added to find_coupling_coef and 6 new local variables were added to vertvisc_coef. In 6 places the Boussinesq reference density was replaced with GV%H_to_RZ, which is equivalent to the reference density in Boussinesq mode, but scales to 1 in non-Boussinesq mode. The previous dimensional rescaling factor for KD_GL90 was incorrect (and inconsistent with the correct scaling factor used when reading in the analagous spatially varying kappa_gl90_2d); this has been corrected in this commit. A total of 59 GV%H_to_Z or GV%Z_to_H unit conversion factors or references to GV%Rho_0 were eliminated with these changes, and in non-Boussinesq mode there is no longer any dependence on the Boussinesq reference density. Replaced the forces argument to find_coupling_coef with an array of the friction velocities and use find_ustar to set them. When in non-Boussinesq mode, this has the effect of using forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 when interpolating the friction velocity and stress magnitude in find_coupling_coef. Revised units used to set the GL90 viscosities and rescale to convert diagnostics of the vertical viscosities in the MOM_vert_friction module, so that they do not depend on RHO_0 when in non-Boussinesq mode. To accomodate this change in vertvisc, the units of the "a" arguments to write_u_accel and write_v_accel were also changed to use thickness-based arguments. Because GV%Z_to_H is an exact power of 2 in Boussinesq mode, all answers are bitwise identical in that mode. In non-Boussinesq mode, the answers are changed by the replacement of the Boussinesq reference density by expressions using the layer-averaged specific volumes. This commit changes the units of 2 arguments in public (diagnostic) subroutine interfaces. --- src/diagnostics/MOM_PointAccel.F90 | 14 +- .../vertical/MOM_vert_friction.F90 | 684 ++++++++++-------- 2 files changed, 403 insertions(+), 295 deletions(-) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index d53b2e6636..e9c1092ed7 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -83,7 +83,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z T-1 ~> m s-1]. + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc [H ~> m or kg m-2]. @@ -223,8 +224,8 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st (vel_scale*ADp%du_other(I,j,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",ES10.3," ")', advance='no') US%Z_to_m*a(I,j,ks)*dt - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(I,j,K)*dt) ; enddo + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(I,j,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(I,j,K)*dt) ; enddo endif if (present(hv)) then write(file,'(/,"hvel: ")', advance='no') @@ -422,7 +423,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real, intent(in) :: vel_rpt !< The velocity magnitude that triggers a report [L T-1 ~> m s-1] real, optional, intent(in) :: str !< The surface wind stress [R L Z T-2 ~> Pa] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), & - optional, intent(in) :: a !< The layer coupling coefficients from vertvisc [Z T-1 ~> m s-1]. + optional, intent(in) :: a !< The layer coupling coefficients from vertvisc + !! [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: hv !< The layer thicknesses at velocity grid points, !! from vertvisc [H ~> m or kg m-2]. @@ -566,8 +568,8 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st (vel_scale*ADp%dv_other(i,J,k)) ; enddo endif if (present(a)) then - write(file,'(/,"a: ",ES10.3," ")', advance='no') US%Z_to_m*a(i,J,ks)*dt - do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (US%Z_to_m*a(i,J,K)*dt) ; enddo + write(file,'(/,"a: ",ES10.3," ")', advance='no') h_scale*a(i,J,ks)*dt + do K=ks+1,ke+1 ; if (do_k(k-1)) write(file,'(ES10.3," ")', advance='no') (h_scale*a(i,J,K)*dt) ; enddo endif if (present(hv)) then write(file,'(/,"hvel: ")', advance='no') diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 133d72fa17..b0b47bf2b1 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -12,7 +12,7 @@ module MOM_vert_friction use MOM_debugging, only : uvchksum, hchksum use MOM_error_handler, only : MOM_error, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : mech_forcing +use MOM_forcing_type, only : mech_forcing, find_ustar use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type use MOM_io, only : MOM_read_data, slasher @@ -28,6 +28,7 @@ module MOM_vert_friction use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS use MOM_lateral_mixing_coeffs, only : VarMix_CS + implicit none ; private #include @@ -44,18 +45,18 @@ module MOM_vert_friction !> The control structure with parameters and memory for the MOM_vert_friction module type, public :: vertvisc_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. - real :: Hmix !< The mixed layer thickness in thickness units [H ~> m or kg m-2]. + real :: Hmix !< The mixed layer thickness [Z ~> m]. real :: Hmix_stress !< The mixed layer thickness over which the wind !! stress is applied with direct_stress [H ~> m or kg m-2]. - real :: Kvml_invZ2 !< The extra vertical viscosity scale in [Z2 T-1 ~> m2 s-1] in a + real :: Kvml_invZ2 !< The extra vertical viscosity scale in [H Z T-1 ~> m2 s-1 or Pa s] in a !! surface mixed layer with a characteristic thickness given by Hmix, !! and scaling proportional to (Hmix/z)^2, where z is the distance !! from the surface; this can get very large with thin layers. - real :: Kv !< The interior vertical viscosity [Z2 T-1 ~> m2 s-1]. - real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. - real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [H ~> m or kg m-2]. + real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: Hbbl !< The static bottom boundary layer thickness [Z ~> m]. + real :: Hbbl_gl90 !< The static bottom boundary layer thickness used for GL90 [Z ~> m]. real :: Kv_extra_bbl !< An extra vertical viscosity in the bottom boundary layer of thickness - !! Hbbl when there is not a bottom drag law in use [Z2 T-1 ~> m2 s-1]. + !! Hbbl when there is not a bottom drag law in use [H Z T-1 ~> m2 s-1 or Pa s]. real :: vonKar !< The von Karman constant as used for mixed layer viscosity [nondim] logical :: use_GL90_in_SSW !< If true, use the GL90 parameterization in stacked shallow water mode (SSW). @@ -65,12 +66,12 @@ module MOM_vert_friction logical :: use_GL90_N2 !< If true, use GL90 vertical viscosity coefficient that is depth-independent; !! this corresponds to a kappa_GM that scales as N^2 with depth. real :: kappa_gl90 !< The scalar diffusivity used in the GL90 vertical viscosity scheme - !! [L2 T-1 ~> m2 s-1] + !! [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] logical :: read_kappa_gl90 !< If true, read a file containing the spatially varying kappa_gl90 real :: alpha_gl90 !< Coefficient used to compute a depth-independent GL90 vertical !! viscosity via Kv_gl90 = alpha_gl90 * f^2. Note that the implied !! Kv_gl90 corresponds to a kappa_gl90 that scales as N^2 with depth. - !! [L2 T ~> m2 s] + !! [H Z T ~> m2 s or kg s m-1] real :: maxvel !< Velocity components greater than maxvel are truncated [L T-1 ~> m s-1]. real :: vel_underflow !< Velocity components smaller than vel_underflow !! are set to 0 [L T-1 ~> m s-1]. @@ -90,21 +91,21 @@ module MOM_vert_friction type(time_type) :: rampStartTime !< The time at which the ramping of CFL_trunc starts real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & - a_u !< The u-drag coefficient across an interface [Z T-1 ~> m s-1]. + a_u !< The u-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NK_INTERFACE_) :: & - a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [Z T-1 ~> m s-1]. + a_u_gl90 !< The u-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & h_u !< The effective layer thickness at u-points [H ~> m or kg m-2]. real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & - a_v !< The v-drag coefficient across an interface [Z T-1 ~> m s-1]. + a_v !< The v-drag coefficient across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NK_INTERFACE_) :: & - a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [Z T-1 ~> m s-1]. + a_v_gl90 !< The v-drag coefficient associated with GL90 across an interface [H T-1 ~> m s-1 or Pa s m-1] real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & h_v !< The effective layer thickness at v-points [H ~> m or kg m-2]. real, pointer, dimension(:,:) :: a1_shelf_u => NULL() !< The u-momentum coupling coefficient under - !! ice shelves [Z T-1 ~> m s-1]. Retained to determine stress under shelves. + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. real, pointer, dimension(:,:) :: a1_shelf_v => NULL() !< The v-momentum coupling coefficient under - !! ice shelves [Z T-1 ~> m s-1]. Retained to determine stress under shelves. + !! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. Retained to determine stress under shelves. logical :: split !< If true, use the split time stepping scheme. logical :: bottomdraglaw !< If true, the bottom stress is calculated with a @@ -158,7 +159,7 @@ module MOM_vert_friction type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. - real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:) :: kappa_gl90_2d !< 2D kappa_gl90 at h-points [L2 H Z-1 T-1 ~> m2 s-1 or Pa s] !>@{ Diagnostic identifiers integer :: id_du_dt_visc = -1, id_dv_dt_visc = -1, id_du_dt_visc_gl90 = -1, id_dv_dt_visc_gl90 = -1 @@ -206,8 +207,8 @@ module MOM_vert_friction subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, VarMix, work_on_u) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Layer thickness used at a velocity - !! grid point [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: hvel !< Distance between interfaces + !! at velocity points [Z ~> m] logical, dimension(SZIB_(G)), intent(in) :: do_i !< If true, determine coupling coefficient !! for a column real, dimension(SZIB_(G),SZK_(GV)+1), intent(in) :: z_i !< Estimate of interface heights above the @@ -215,7 +216,7 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! boundary layer thickness [nondim] real, dimension(SZIB_(G),SZK_(GV)+1), intent(inout) :: a_cpl_gl90 !< Coupling coefficient associated !! with GL90 across interfaces; is not - !! included in a_cpl [Z T-1 ~> m s-1]. + !! included in a_cpl [H T-1 ~> m s-1 or Pa s m-1]. integer, intent(in) :: j !< j-index to find coupling coefficient for type(vertvisc_cs), pointer :: CS !< Vertical viscosity control structure type(VarMix_CS), intent(in) :: VarMix !< Variable mixing coefficients @@ -223,23 +224,19 @@ subroutine find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i, j, G, GV, CS, Va !! otherwise they are v-points. ! local variables - logical :: kdgl90_use_ebt_struct - integer :: i, k, is, ie, nz, Isq, Ieq - real :: f2 !< Squared Coriolis parameter at a - !! velocity grid point [T-2 ~> s-2]. - real :: h_neglect ! A thickness that is so small - !! it is usually lost in roundoff error - !! and can be neglected [H ~> m or kg m-2]. - real :: botfn ! A function that is 1 at the bottom - !! and small far from it [nondim] - real :: z2 ! The distance from the bottom, - !! normalized by Hbbl_gl90 [nondim] + logical :: kdgl90_use_ebt_struct + integer :: i, k, is, ie, nz, Isq, Ieq + real :: f2 !< Squared Coriolis parameter at a velocity grid point [T-2 ~> s-2]. + real :: h_neglect ! A vertical distance that is so small it is usually lost in roundoff error + ! and can be neglected [Z ~> m]. + real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] + real :: z2 ! The distance from the bottom, normalized by Hbbl_gl90 [nondim] is = G%isc ; ie = G%iec Isq = G%IscB ; Ieq = G%IecB nz = GV%ke - h_neglect = GV%H_subroundoff + h_neglect = GV%dZ_subroundoff kdgl90_use_ebt_struct = .false. if (VarMix%use_variable_mixing) then kdgl90_use_ebt_struct = VarMix%kdgl90_use_ebt_struct @@ -348,7 +345,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. + real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. real :: Hmix ! The mixed layer thickness over which stress @@ -356,8 +353,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & real :: I_Hmix ! The inverse of Hmix [H-1 ~> m-1 or m2 kg-1]. real :: Idt ! The inverse of the time step [T-1 ~> s-1]. real :: dt_Rho0 ! The time step divided by the mean density [T H Z-1 R-1 ~> s m3 kg-1 or s]. - real :: dt_Z_to_H ! The time step times the conversion from Z to the - ! units of thickness - [T H Z-1 ~> s or s kg m-3]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -402,7 +397,6 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & I_Hmix = 1.0 / Hmix endif dt_Rho0 = dt / GV%H_to_RZ - dt_Z_to_H = dt*GV%Z_to_H h_neglect = GV%H_subroundoff Idt = 1.0 / dt @@ -464,7 +458,7 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) + Ray(I,k) = visc%Ray_u(I,j,k) enddo ; enddo ; endif ! perform forward elimination on the tridiagonal system @@ -473,9 +467,9 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! and the superdiagonal as c_k. The right-hand side terms are d_k. ! ! ignoring the Rayleigh drag contribution, - ! we have a_k = -dt_Z_to_H * a_u(k) - ! b_k = h_u(k) + dt_Z_to_H * (a_u(k) + a_u(k+1)) - ! c_k = -dt_Z_to_H * a_u(k+1) + ! we have a_k = -dt * a_u(k) + ! b_k = h_u(k) + dt * (a_u(k) + a_u(k+1)) + ! c_k = -dt * a_u(k+1) ! ! for forward elimination, we want to: ! calculate c'_k = - c_k / (b_k + a_k c'_(k-1)) @@ -494,23 +488,23 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & ! and the right-hand-side is destructively updated to be d'_k ! do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) u(I,j,1) = b1(I) * (CS%h_u(I,j,1) * u(I,j,1) + surface_stress(I)) if (associated(ADp%du_dt_str)) & ADp%du_dt_str(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_str(I,j,1) + surface_stress(I)*Idt) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) + c1(I,k) = dt * CS%a_u(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) d1(I) = b_denom_1 * b1(I) u(I,j,k) = (CS%h_u(I,j,k) * u(I,j,k) + & - dt_Z_to_H * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) + dt * CS%a_u(I,j,K) * u(I,j,k-1)) * b1(I) if (associated(ADp%du_dt_str)) & ADp%du_dt_str(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_str(I,j,k) + & - dt_Z_to_H * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) + dt * CS%a_u(I,j,K) * ADp%du_dt_str(I,j,k-1)) * b1(I) endif ; enddo ; enddo ! back substitute to solve for the new velocities @@ -534,17 +528,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (associated(ADp%du_dt_visc_gl90)) then do I=Isq,Ieq ; if (do_i(I)) then b_denom_1 = CS%h_u(I,j,1) ! CS%a_u_gl90(I,j,1) is zero - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u_gl90(I,j,2)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u_gl90(I,j,2)) d1(I) = b_denom_1 * b1(I) ADp%du_dt_visc_gl90(I,j,1) = b1(I) * (CS%h_u(I,j,1) * ADp%du_dt_visc_gl90(I,j,1)) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u_gl90(I,j,K) * b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (CS%a_u_gl90(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u_gl90(I,j,K+1)) + c1(I,k) = dt * CS%a_u_gl90(I,j,K) * b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (CS%a_u_gl90(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u_gl90(I,j,K+1)) d1(I) = b_denom_1 * b1(I) ADp%du_dt_visc_gl90(I,j,k) = (CS%h_u(I,j,k) * ADp%du_dt_visc_gl90(I,j,k) + & - dt_Z_to_H * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) + dt * CS%a_u_gl90(I,j,K) * ADp%du_dt_visc_gl90(I,j,k-1)) * b1(I) endif ; enddo ; enddo ! back substitute to solve for new velocities, held by ADp%du_dt_visc_gl90 do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then @@ -573,15 +567,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; enddo ; endif if (allocated(visc%taux_shelf)) then ; do I=Isq,Ieq - visc%taux_shelf(I,j) = -GV%Rho0*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? + visc%taux_shelf(I,j) = -GV%H_to_RZ*CS%a1_shelf_u(I,j)*u(I,j,1) ! - u_shelf? enddo ; endif if (PRESENT(taux_bot)) then do I=Isq,Ieq - taux_bot(I,j) = GV%Rho0 * (u(I,j,nz)*CS%a_u(I,j,nz+1)) + taux_bot(I,j) = GV%H_to_RZ * (u(I,j,nz)*CS%a_u(I,j,nz+1)) enddo if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - taux_bot(I,j) = taux_bot(I,j) + GV%Rho0 * (Ray(I,k)*u(I,j,k)) + taux_bot(I,j) = taux_bot(I,j) + GV%H_to_RZ * (Ray(I,k)*u(I,j,k)) enddo ; enddo ; endif endif @@ -636,26 +630,26 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; endif ! direct_stress if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) + Ray(i,k) = visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) v(i,J,1) = b1(i) * (CS%h_v(i,J,1) * v(i,J,1) + surface_stress(i)) if (associated(ADp%dv_dt_str)) & ADp%dv_dt_str(i,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_str(i,J,1) + surface_stress(i)*Idt) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) + c1(i,k) = dt * CS%a_v(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) - v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) + v(i,J,k) = (CS%h_v(i,J,k) * v(i,J,k) + dt * CS%a_v(i,J,K) * v(i,J,k-1)) * b1(i) if (associated(ADp%dv_dt_str)) & ADp%dv_dt_str(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_str(i,J,k) + & - dt_Z_to_H * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) + dt * CS%a_v(i,J,K) * ADp%dv_dt_str(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then v(i,J,k) = v(i,J,k) + c1(i,k+1) * v(i,J,k+1) @@ -676,17 +670,17 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & if (associated(ADp%dv_dt_visc_gl90)) then do i=is,ie ; if (do_i(i)) then b_denom_1 = CS%h_v(i,J,1) ! CS%a_v_gl90(i,J,1) is zero - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v_gl90(i,J,2)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v_gl90(i,J,2)) d1(i) = b_denom_1 * b1(i) ADp%dv_dt_visc_gl90(I,J,1) = b1(i) * (CS%h_v(i,J,1) * ADp%dv_dt_visc_gl90(i,J,1)) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v_gl90(i,J,K) * b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (CS%a_v_gl90(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v_gl90(i,J,K+1)) + c1(i,k) = dt * CS%a_v_gl90(i,J,K) * b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (CS%a_v_gl90(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v_gl90(i,J,K+1)) d1(i) = b_denom_1 * b1(i) ADp%dv_dt_visc_gl90(i,J,k) = (CS%h_v(i,J,k) * ADp%dv_dt_visc_gl90(i,J,k) + & - dt_Z_to_H * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) + dt * CS%a_v_gl90(i,J,K) * ADp%dv_dt_visc_gl90(i,J,k-1)) * b1(i) endif ; enddo ; enddo ! back substitute to solve for new velocities, held by ADp%dv_dt_visc_gl90 do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then @@ -716,15 +710,15 @@ subroutine vertvisc(u, v, h, forces, visc, dt, OBC, ADp, CDp, G, GV, US, CS, & enddo ; enddo ; endif if (allocated(visc%tauy_shelf)) then ; do i=is,ie - visc%tauy_shelf(i,J) = -GV%Rho0*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? + visc%tauy_shelf(i,J) = -GV%H_to_RZ*CS%a1_shelf_v(i,J)*v(i,J,1) ! - v_shelf? enddo ; endif if (present(tauy_bot)) then do i=is,ie - tauy_bot(i,J) = GV%Rho0 * (v(i,J,nz)*CS%a_v(i,J,nz+1)) + tauy_bot(i,J) = GV%H_to_RZ * (v(i,J,nz)*CS%a_v(i,J,nz+1)) enddo if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - tauy_bot(i,J) = tauy_bot(i,J) + GV%Rho0 * (Ray(i,k)*v(i,J,k)) + tauy_bot(i,J) = tauy_bot(i,J) + GV%H_to_RZ * (Ray(i,k)*v(i,J,k)) enddo ; enddo ; endif endif @@ -851,10 +845,8 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) real :: b1(SZIB_(G)) ! A variable used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. real :: c1(SZIB_(G),SZK_(GV)) ! A variable used by the tridiagonal solver [nondim]. real :: d1(SZIB_(G)) ! d1=1-c1 is used by the tridiagonal solver [nondim]. - real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [Z T-1 ~> m s-1]. + real :: Ray(SZIB_(G),SZK_(GV)) ! Ray is the Rayleigh-drag velocity [H T-1 ~> m s-1 or Pa s m-1] real :: b_denom_1 ! The first term in the denominator of b1 [H ~> m or kg m-2]. - real :: dt_Z_to_H ! The time step times the conversion from Z to the - ! units of thickness [T H Z-1 ~> s or s kg m-3]. logical :: do_i(SZIB_(G)) integer :: i, j, k, is, ie, Isq, Ieq, Jsq, Jeq, nz @@ -867,8 +859,6 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) if (.not.CS%initialized) call MOM_error(FATAL,"MOM_vert_friction(remant): "// & "Module must be initialized before it is used.") - dt_Z_to_H = dt*GV%Z_to_H - do k=1,nz ; do i=Isq,Ieq ; Ray(i,k) = 0.0 ; enddo ; enddo ! Find the zonal viscous remnant using a modification of a standard tridagonal solver. @@ -877,21 +867,21 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (allocated(visc%Ray_u)) then ; do k=1,nz ; do I=Isq,Ieq - Ray(I,k) = GV%H_to_Z*visc%Ray_u(I,j,k) + Ray(I,k) = visc%Ray_u(I,j,k) enddo ; enddo ; endif do I=Isq,Ieq ; if (do_i(I)) then - b_denom_1 = CS%h_u(I,j,1) + dt_Z_to_H * (Ray(I,1) + CS%a_u(I,j,1)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_u(I,j,2)) + b_denom_1 = CS%h_u(I,j,1) + dt * (Ray(I,1) + CS%a_u(I,j,1)) + b1(I) = 1.0 / (b_denom_1 + dt*CS%a_u(I,j,2)) d1(I) = b_denom_1 * b1(I) visc_rem_u(I,j,1) = b1(I) * CS%h_u(I,j,1) endif ; enddo do k=2,nz ; do I=Isq,Ieq ; if (do_i(I)) then - c1(I,k) = dt_Z_to_H * CS%a_u(I,j,K)*b1(I) - b_denom_1 = CS%h_u(I,j,k) + dt_Z_to_H * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) - b1(I) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_u(I,j,K+1)) + c1(I,k) = dt * CS%a_u(I,j,K)*b1(I) + b_denom_1 = CS%h_u(I,j,k) + dt * (Ray(I,k) + CS%a_u(I,j,K)*d1(I)) + b1(I) = 1.0 / (b_denom_1 + dt * CS%a_u(I,j,K+1)) d1(I) = b_denom_1 * b1(I) - visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt_Z_to_H * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) + visc_rem_u(I,j,k) = (CS%h_u(I,j,k) + dt * CS%a_u(I,j,K) * visc_rem_u(I,j,k-1)) * b1(I) endif ; enddo ; enddo do k=nz-1,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then visc_rem_u(I,j,k) = visc_rem_u(I,j,k) + c1(I,k+1)*visc_rem_u(I,j,k+1) @@ -906,21 +896,21 @@ subroutine vertvisc_remnant(visc, visc_rem_u, visc_rem_v, dt, G, GV, US, CS) do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (allocated(visc%Ray_v)) then ; do k=1,nz ; do i=is,ie - Ray(i,k) = GV%H_to_Z*visc%Ray_v(i,J,k) + Ray(i,k) = visc%Ray_v(i,J,k) enddo ; enddo ; endif do i=is,ie ; if (do_i(i)) then - b_denom_1 = CS%h_v(i,J,1) + dt_Z_to_H * (Ray(i,1) + CS%a_v(i,J,1)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H*CS%a_v(i,J,2)) + b_denom_1 = CS%h_v(i,J,1) + dt * (Ray(i,1) + CS%a_v(i,J,1)) + b1(i) = 1.0 / (b_denom_1 + dt*CS%a_v(i,J,2)) d1(i) = b_denom_1 * b1(i) visc_rem_v(i,J,1) = b1(i) * CS%h_v(i,J,1) endif ; enddo do k=2,nz ; do i=is,ie ; if (do_i(i)) then - c1(i,k) = dt_Z_to_H * CS%a_v(i,J,K)*b1(i) - b_denom_1 = CS%h_v(i,J,k) + dt_Z_to_H * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) - b1(i) = 1.0 / (b_denom_1 + dt_Z_to_H * CS%a_v(i,J,K+1)) + c1(i,k) = dt * CS%a_v(i,J,K)*b1(i) + b_denom_1 = CS%h_v(i,J,k) + dt * (Ray(i,k) + CS%a_v(i,J,K)*d1(i)) + b1(i) = 1.0 / (b_denom_1 + dt * CS%a_v(i,J,K+1)) d1(i) = b_denom_1 * b1(i) - visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt_Z_to_H * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) + visc_rem_v(i,J,k) = (CS%h_v(i,J,k) + dt * CS%a_v(i,J,K) * visc_rem_v(i,J,k-1)) * b1(i) endif ; enddo ; enddo do k=nz-1,1,-1 ; do i=is,ie ; if (do_i(i)) then visc_rem_v(i,J,k) = visc_rem_v(i,J,k) + c1(i,k+1)*visc_rem_v(i,J,k+1) @@ -970,52 +960,65 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_arith, & ! The arithmetic mean thickness [H ~> m or kg m-2]. h_delta, & ! The lateral difference of thickness [H ~> m or kg m-2]. hvel, & ! hvel is the thickness used at a velocity grid point [H ~> m or kg m-2]. - hvel_shelf ! The equivalent of hvel under shelves [H ~> m or kg m-2]. + hvel_shelf, & ! The equivalent of hvel under shelves [H ~> m or kg m-2]. + dz_harm, & ! Harmonic mean of the vertical distances around a velocity grid point, + ! given by 2*(h+ * h-)/(h+ + h-) [Z ~> m]. + dz_arith, & ! The arithmetic mean of the vertical distances around a velocity grid point [Z ~> m] + dz_vel, & ! The vertical distance between interfaces used at a velocity grid point [Z ~> m]. + dz_vel_shelf ! The equivalent of dz_vel under shelves [Z ~> m]. real, dimension(SZIB_(G),SZK_(GV)+1) :: & - a_cpl, & ! The drag coefficients across interfaces [Z T-1 ~> m s-1]. a_cpl times + a_cpl, & ! The drag coefficients across interfaces [H T-1 ~> m s-1 or Pa s m-1]. a_cpl times ! the velocity difference gives the stress across an interface. - a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [Z T-1 ~> m s-1]. + a_cpl_gl90, & ! The drag coefficients across interfaces associated with GL90 [H T-1 ~> m s-1 or Pa s m-1]. ! a_cpl_gl90 times the velocity difference gives the GL90 stress across an interface. ! a_cpl_gl90 is part of a_cpl. a_shelf, & ! The drag coefficients across interfaces in water columns under - ! ice shelves [Z T-1 ~> m s-1]. + ! ice shelves [H T-1 ~> m s-1 or Pa s m-1]. z_i, & ! An estimate of each interface's height above the bottom, ! normalized by the bottom boundary layer thickness [nondim] z_i_gl90 ! An estimate of each interface's height above the bottom, ! normalized by the GL90 bottom boundary layer thickness [nondim] real, dimension(SZIB_(G)) :: & - kv_bbl, & ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. - bbl_thick, & ! The bottom boundary layer thickness [H ~> m or kg m-2]. - I_Hbbl, & ! The inverse of the bottom boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. + kv_bbl, & ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + bbl_thick, & ! The bottom boundary layer thickness [Z ~> m]. + I_Hbbl, & ! The inverse of the bottom boundary layer thickness [Z-1 ~> m-1]. I_Hbbl_gl90, &! The inverse of the bottom boundary layer thickness used for the GL90 scheme - ! [H-1 ~> m-1 or m2 kg-1]. - I_Htbl, & ! The inverse of the top boundary layer thickness [H-1 ~> m-1 or m2 kg-1]. - zcol1, & ! The height of the interfaces to the south of a v-point [H ~> m or kg m-2]. - zcol2, & ! The height of the interfaces to the north of a v-point [H ~> m or kg m-2]. - Ztop_min, & ! The deeper of the two adjacent surface heights [H ~> m or kg m-2]. - Dmin, & ! The shallower of the two adjacent bottom depths converted to - ! thickness units [H ~> m or kg m-2]. + ! [Z-1 ~> m-1]. + I_HTbl, & ! The inverse of the top boundary layer thickness [Z-1 ~> m-1]. + zcol1, & ! The height of the interfaces to the south of a v-point [Z ~> m]. + zcol2, & ! The height of the interfaces to the north of a v-point [Z ~> m]. + Ztop_min, & ! The deeper of the two adjacent surface heights [Z ~> m]. + Dmin, & ! The shallower of the two adjacent bottom depths [Z ~> m]. zh, & ! An estimate of the interface's distance from the bottom - ! based on harmonic mean thicknesses [H ~> m or kg m-2]. - h_ml ! The mixed layer depth [H ~> m or kg m-2]. - real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [H ~> m or kg m-2]. - real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [H ~> m or kg m-2]. - real, allocatable, dimension(:,:,:) :: Kv_u !< Total vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_v !< Total vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_gl90_u !< GL90 vertical viscosity at u-points [Z2 T-1 ~> m2 s-1]. - real, allocatable, dimension(:,:,:) :: Kv_gl90_v !< GL90 vertical viscosity at v-points [Z2 T-1 ~> m2 s-1]. - real :: zcol(SZI_(G)) ! The height of an interface at h-points [H ~> m or kg m-2]. + ! based on harmonic mean thicknesses [Z ~> m]. + h_ml ! The mixed layer depth [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)) :: & + Ustar_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + real, allocatable, dimension(:,:) :: hML_u ! Diagnostic of the mixed layer depth at u points [Z ~> m]. + real, allocatable, dimension(:,:) :: hML_v ! Diagnostic of the mixed layer depth at v points [Z ~> m]. + real, allocatable, dimension(:,:,:) :: Kv_u ! Total vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_v ! Total vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_u ! GL90 vertical viscosity at u-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real, allocatable, dimension(:,:,:) :: Kv_gl90_v ! GL90 vertical viscosity at v-points in + ! thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1]. + real :: zcol(SZI_(G)) ! The height of an interface at h-points [Z ~> m]. real :: botfn ! A function which goes from 1 at the bottom to 0 much more ! than Hbbl into the interior [nondim]. real :: topfn ! A function which goes from 1 at the top to 0 much more ! than Htbl into the interior [nondim]. real :: z2 ! The distance from the bottom, normalized by Hbbl [nondim] real :: z2_wt ! A nondimensional (0-1) weight used when calculating z2 [nondim]. - real :: z_clear ! The clearance of an interface above the surrounding topography [H ~> m or kg m-2]. + real :: z_clear ! The clearance of an interface above the surrounding topography [Z ~> m]. real :: a_cpl_max ! The maximum drag coefficient across interfaces, set so that it will be - ! representable as a 32-bit float in MKS units [Z T-1 ~> m s-1] + ! representable as a 32-bit float in MKS units [H T-1 ~> m s-1 or Pa s m-1] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: I_valBL ! The inverse of a scaling factor determining when water is ! still within the boundary layer, as determined by the sum @@ -1036,10 +1039,11 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, "Module must be initialized before it is used.") h_neglect = GV%H_subroundoff - a_cpl_max = 1.0e37 * US%m_to_Z * US%T_to_s - I_Hbbl(:) = 1.0 / (CS%Hbbl + h_neglect) + dz_neglect = GV%dZ_subroundoff + a_cpl_max = 1.0e37 * GV%m_to_H * US%T_to_s + I_Hbbl(:) = 1.0 / (CS%Hbbl + dz_neglect) if (CS%use_GL90_in_SSW) then - I_Hbbl_gl90 = 1.0 / (CS%Hbbl_gl90 + h_neglect) + I_Hbbl_gl90(:) = 1.0 / (CS%Hbbl_gl90 + dz_neglect) endif I_valBL = 0.0 ; if (CS%harm_BL_val > 0.0) I_valBL = 1.0 / CS%harm_BL_val @@ -1063,15 +1067,18 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, allocate(CS%a1_shelf_v(G%isd:G%ied,G%JsdB:G%JedB), source=0.0) endif - !$OMP parallel do default(private) shared(G,GV,US,CS,visc,Isq,Ieq,nz,u,h,forces,hML_u, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_u,a_cpl_max) & - !$OMP firstprivate(i_hbbl) + call find_ustar(forces, tv, Ustar_2d, G, GV, US, halo=1) + + !$OMP parallel do default(private) shared(G,GV,US,CS,tv,visc,OBC,Isq,Ieq,nz,u,h,dz,forces, & + !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_u,Kv_u, & + !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_u) & + !$OMP firstprivate(I_Hbbl) do j=G%Jsc,G%Jec do I=Isq,Ieq ; do_i(I) = (G%mask2dCu(I,j) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do I=Isq,Ieq - kv_bbl(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) - bbl_thick(I) = visc%bbl_thick_u(I,j) * GV%Z_to_H + h_neglect + kv_bbl(I) = visc%Kv_bbl_u(I,j) + bbl_thick(I) = visc%bbl_thick_u(I,j) + dz_neglect if (do_i(I)) I_Hbbl(I) = 1.0 / bbl_thick(I) enddo ; endif @@ -1079,9 +1086,11 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_harm(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / (h(i,j,k)+h(i+1,j,k)+h_neglect) h_arith(I,k) = 0.5*(h(i+1,j,k)+h(i,j,k)) h_delta(I,k) = h(i+1,j,k) - h(i,j,k) + dz_harm(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / (dz(i,j,k)+dz(i+1,j,k)+dz_neglect) + dz_arith(I,k) = 0.5*(dz(i+1,j,k)+dz(i,j,k)) endif ; enddo ; enddo do I=Isq,Ieq - Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) * GV%Z_to_H + Dmin(I) = min(G%bathyT(i,j), G%bathyT(i+1,j)) zi_dir(I) = 0 enddo @@ -1089,19 +1098,25 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then do I=Isq,Ieq ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * GV%Z_to_H + do k=1,nz + h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(I,k) = 0. + dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) + enddo + Dmin(I) = G%bathyT(i,j) zi_dir(I) = -1 elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do k=1,nz ; h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. ; enddo - Dmin(I) = G%bathyT(i+1,j) * GV%Z_to_H + do k=1,nz + h_harm(I,k) = h(i+1,j,k) ; h_arith(I,k) = h(i+1,j,k) ; h_delta(I,k) = 0. + dz_harm(I,k) = dz(i+1,j,k) ; dz_arith(I,k) = dz(i+1,j,k) + enddo + Dmin(I) = G%bathyT(i+1,j) zi_dir(I) = 1 endif endif ; enddo endif ; endif ! The following block calculates the thicknesses at velocity -! grid points for the vertical viscosity (hvel). Near the +! grid points for the vertical viscosity (hvel and dz_vel). Near the ! bottom an upwind biased thickness is used to control the effect ! of spurious Montgomery potential gradients at the bottom where ! nearly massless layers layers ride over the topography. @@ -1109,19 +1124,21 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do I=Isq,Ieq ; z_i(I,nz+1) = 0.0 ; enddo do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then hvel(I,k) = h_harm(I,k) + dz_vel(I,k) = dz_harm(I,k) if (u(I,j,k) * h_delta(I,k) < 0) then z2 = z_i(I,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(I,k) = (1.0-botfn)*h_harm(I,k) + botfn*h_arith(I,k) + dz_vel(I,k) = (1.0-botfn)*dz_harm(I,k) + botfn*dz_arith(I,k) endif - z_i(I,k) = z_i(I,k+1) + h_harm(I,k)*I_Hbbl(I) + z_i(I,k) = z_i(I,k+1) + dz_harm(I,k)*I_Hbbl(I) endif ; enddo ; enddo ! i & k loops else ! Not harmonic_visc do I=Isq,Ieq ; zh(I) = 0.0 ; z_i(I,nz+1) = 0.0 ; enddo - do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) * GV%Z_to_H ; enddo + do i=Isq,Ieq+1 ; zcol(i) = -G%bathyT(i,j) ; enddo do k=nz,1,-1 - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + h(i,j,k) ; enddo + do i=Isq,Ieq+1 ; zcol(i) = zcol(i) + dz(i,j,k) ; enddo do I=Isq,Ieq ; if (do_i(I)) then - zh(I) = zh(I) + h_harm(I,k) + zh(I) = zh(I) + dz_harm(I,k) z_clear = max(zcol(i),zcol(i+1)) + Dmin(I) if (zi_dir(I) < 0) z_clear = zcol(i) + Dmin(I) @@ -1130,15 +1147,18 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, z_i(I,k) = max(zh(I), z_clear) * I_Hbbl(I) hvel(I,k) = h_arith(I,k) + dz_vel(I,k) = dz_arith(I,k) if (u(I,j,k) * h_delta(I,k) > 0) then if (zh(I) * I_Hbbl(I) < CS%harm_BL_val) then hvel(I,k) = h_harm(I,k) + dz_vel(I,k) = dz_harm(I,k) else z2_wt = 1.0 ; if (zh(I) * I_Hbbl(I) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(I) * I_Hbbl(I) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(I), z_clear) * I_Hbbl(I)) botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(I,k) = (1.0-botfn)*h_arith(I,k) + botfn*h_harm(I,k) + dz_vel(I,k) = (1.0-botfn)*dz_arith(I,k) + botfn*dz_harm(I,k) endif endif @@ -1146,8 +1166,8 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, enddo ! k loop endif - call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.true., OBC=OBC) + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.true., OBC=OBC) a_cpl_gl90(:,:) = 0.0 if (CS%use_GL90_in_SSW) then ! The following block calculates the normalized height above the GL90 @@ -1160,9 +1180,9 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! over topography, small enough to not contaminate the interior. do I=Isq,Ieq ; z_i_gl90(I,nz+1) = 0.0 ; enddo do k=nz,1,-1 ; do I=Isq,Ieq ; if (do_i(I)) then - z_i_gl90(I,k) = z_i_gl90(I,k+1) + h_harm(I,k)*I_Hbbl_gl90(I) + z_i_gl90(I,k) = z_i_gl90(I,k+1) + dz_harm(I,k)*I_Hbbl_gl90(I) endif ; enddo ; enddo ! i & k loops - call find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.true.) endif if (allocated(hML_u)) then @@ -1178,35 +1198,39 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, enddo if (do_any_shelf) then if (CS%harmonic_visc) then - do k=1,nz ; do I=Isq,Ieq ; hvel_shelf(I,k) = hvel(I,k) ; enddo ; enddo + do k=1,nz ; do I=Isq,Ieq + hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) + enddo ; enddo else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. do I=Isq,Ieq ; if (do_i_shelf(I)) then zh(I) = 0.0 ; Ztop_min(I) = min(zcol(i), zcol(i+1)) - I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j)*GV%Z_to_H + h_neglect) + I_HTbl(I) = 1.0 / (visc%tbl_thick_shelf_u(I,j) + dz_neglect) endif ; enddo do k=1,nz - do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - h(i,j,k) ; enddo + do i=Isq,Ieq+1 ; zcol(i) = zcol(i) - dz(i,j,k) ; enddo do I=Isq,Ieq ; if (do_i_shelf(I)) then - zh(I) = zh(I) + h_harm(I,k) + zh(I) = zh(I) + dz_harm(I,k) - hvel_shelf(I,k) = hvel(I,k) + hvel_shelf(I,k) = hvel(I,k) ; dz_vel_shelf(I,k) = dz_vel(I,k) if (u(I,j,k) * h_delta(I,k) > 0) then if (zh(I) * I_HTbl(I) < CS%harm_BL_val) then hvel_shelf(I,k) = min(hvel(I,k), h_harm(I,k)) + dz_vel_shelf(I,k) = min(dz_vel(I,k), dz_harm(I,k)) else z2_wt = 1.0 ; if (zh(I) * I_HTbl(I) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(I) * I_HTbl(I) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(I), Ztop_min(I) - min(zcol(i),zcol(i+1))) * I_HTbl(I)) topfn = 1.0 / (1.0 + 0.09*z2**6) hvel_shelf(I,k) = min(hvel(I,k), (1.0-topfn)*h_arith(I,k) + topfn*h_harm(I,k)) + dz_vel_shelf(I,k) = min(dz_vel(I,k), (1.0-topfn)*dz_arith(I,k) + topfn*dz_harm(I,k)) endif endif endif ; enddo enddo endif - call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, forces, & + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & work_on_u=.true., OBC=OBC, shelf=.true.) do I=Isq,Ieq ; if (do_i_shelf(I)) CS%a1_shelf_u(I,j) = a_shelf(I,1) ; enddo endif @@ -1232,10 +1256,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, endif ; enddo ; enddo else do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then - CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) + CS%a_u(I,j,K) = min(a_cpl_max, a_cpl(I,K) + a_cpl_gl90(I,K)) endif; enddo ; enddo do K=1,nz+1 ; do I=Isq,Ieq ; if (do_i(I)) then - CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) + CS%a_u_gl90(I,j,K) = min(a_cpl_max, a_cpl_gl90(I,K)) endif; enddo ; enddo do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) CS%h_u(I,j,k) = hvel(I,k) + h_neglect ; enddo ; enddo endif @@ -1243,28 +1267,29 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, ! Diagnose total Kv at u-points if (CS%id_Kv_u > 0) then do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) + if (do_i(I)) Kv_u(I,j,k) = 0.5 * (CS%a_u(I,j,K)+CS%a_u(I,j,K+1)) * CS%h_u(I,j,k) enddo ; enddo endif ! Diagnose GL90 Kv at u-points if (CS%id_Kv_gl90_u > 0) then do k=1,nz ; do I=Isq,Ieq - if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * GV%H_to_Z*(CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) + if (do_i(I)) Kv_gl90_u(I,j,k) = 0.5 * (CS%a_u_gl90(I,j,K)+CS%a_u_gl90(I,j,K+1)) * CS%h_u(I,j,k) enddo ; enddo endif enddo ! Now work on v-points. - !$OMP parallel do default(private) shared(G,GV,CS,US,visc,is,ie,Jsq,Jeq,nz,v,h,forces,hML_v, & - !$OMP OBC,h_neglect,dt,I_valBL,Kv_v,a_cpl_max) & - !$OMP firstprivate(i_hbbl) + !$OMP parallel do default(private) shared(G,GV,US,CS,tv,OBC,visc,is,ie,Jsq,Jeq,nz,v,h,dz,forces, & + !$OMP Ustar_2d,h_neglect,dz_neglect,dt,I_valBL,hML_v,Kv_v, & + !$OMP a_cpl_max,I_Hbbl_gl90,Kv_gl90_v) & + !$OMP firstprivate(I_Hbbl) do J=Jsq,Jeq do i=is,ie ; do_i(i) = (G%mask2dCv(i,J) > 0.0) ; enddo if (CS%bottomdraglaw) then ; do i=is,ie - kv_bbl(i) = GV%H_to_Z*visc%Kv_bbl_v(i,J) - bbl_thick(i) = visc%bbl_thick_v(i,J) * GV%Z_to_H + h_neglect + kv_bbl(i) = visc%Kv_bbl_v(i,J) + bbl_thick(i) = visc%bbl_thick_v(i,J) + dz_neglect if (do_i(i)) I_Hbbl(i) = 1.0 / bbl_thick(i) enddo ; endif @@ -1272,9 +1297,11 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, h_harm(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / (h(i,j,k)+h(i,j+1,k)+h_neglect) h_arith(i,k) = 0.5*(h(i,j+1,k)+h(i,j,k)) h_delta(i,k) = h(i,j+1,k) - h(i,j,k) + dz_harm(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / (dz(i,j,k)+dz(i,j+1,k)+dz_neglect) + dz_arith(i,k) = 0.5*(dz(i,j+1,k)+dz(i,j,k)) endif ; enddo ; enddo do i=is,ie - Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) * GV%Z_to_H + Dmin(i) = min(G%bathyT(i,j), G%bathyT(i,j+1)) zi_dir(i) = 0 enddo @@ -1282,12 +1309,18 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz ; h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. ; enddo - Dmin(I) = G%bathyT(i,j) * GV%Z_to_H + do k=1,nz + h_harm(I,k) = h(i,j,k) ; h_arith(I,k) = h(i,j,k) ; h_delta(i,k) = 0. + dz_harm(I,k) = dz(i,j,k) ; dz_arith(I,k) = dz(i,j,k) + enddo + Dmin(I) = G%bathyT(i,j) zi_dir(I) = -1 elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do k=1,nz ; h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. ; enddo - Dmin(i) = G%bathyT(i,j+1) * GV%Z_to_H + do k=1,nz + h_harm(i,k) = h(i,j+1,k) ; h_arith(i,k) = h(i,j+1,k) ; h_delta(i,k) = 0. + dz_harm(i,k) = dz(i,j+1,k) ; dz_arith(i,k) = dz(i,j+1,k) + enddo + Dmin(i) = G%bathyT(i,j+1) zi_dir(i) = 1 endif endif ; enddo @@ -1303,21 +1336,23 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then hvel(i,k) = h_harm(i,k) + dz_vel(i,k) = dz_harm(i,k) if (v(i,J,k) * h_delta(i,k) < 0) then z2 = z_i(i,k+1) ; botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(i,k) = (1.0-botfn)*h_harm(i,k) + botfn*h_arith(i,k) + dz_vel(i,k) = (1.0-botfn)*dz_harm(i,k) + botfn*dz_arith(i,k) endif - z_i(i,k) = z_i(i,k+1) + h_harm(i,k)*I_Hbbl(i) + z_i(i,k) = z_i(i,k+1) + dz_harm(i,k)*I_Hbbl(i) endif ; enddo ; enddo ! i & k loops else ! Not harmonic_visc do i=is,ie zh(i) = 0.0 ; z_i(i,nz+1) = 0.0 - zcol1(i) = -G%bathyT(i,j) * GV%Z_to_H - zcol2(i) = -G%bathyT(i,j+1) * GV%Z_to_H + zcol1(i) = -G%bathyT(i,j) + zcol2(i) = -G%bathyT(i,j+1) enddo do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - zh(i) = zh(i) + h_harm(i,k) - zcol1(i) = zcol1(i) + h(i,j,k) ; zcol2(i) = zcol2(i) + h(i,j+1,k) + zh(i) = zh(i) + dz_harm(i,k) + zcol1(i) = zcol1(i) + dz(i,j,k) ; zcol2(i) = zcol2(i) + dz(i,j+1,k) z_clear = max(zcol1(i),zcol2(i)) + Dmin(i) if (zi_dir(i) < 0) z_clear = zcol1(i) + Dmin(I) @@ -1326,23 +1361,26 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, z_i(I,k) = max(zh(i), z_clear) * I_Hbbl(i) hvel(i,k) = h_arith(i,k) + dz_vel(i,k) = dz_arith(i,k) if (v(i,J,k) * h_delta(i,k) > 0) then if (zh(i) * I_Hbbl(i) < CS%harm_BL_val) then hvel(i,k) = h_harm(i,k) + dz_vel(i,k) = dz_harm(i,k) else z2_wt = 1.0 ; if (zh(i) * I_Hbbl(i) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(i) * I_Hbbl(i) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(i), max(zcol1(i),zcol2(i)) + Dmin(i)) * I_Hbbl(i)) botfn = 1.0 / (1.0 + 0.09*z2*z2*z2*z2*z2*z2) hvel(i,k) = (1.0-botfn)*h_arith(i,k) + botfn*h_harm(i,k) + dz_vel(i,k) = (1.0-botfn)*dz_arith(i,k) + botfn*dz_harm(i,k) endif endif endif ; enddo ; enddo ! i & k loops endif - call find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u=.false., OBC=OBC) + call find_coupling_coef(a_cpl, dz_vel, do_i, dz_harm, bbl_thick, kv_bbl, z_i, h_ml, & + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u=.false., OBC=OBC) a_cpl_gl90(:,:) = 0.0 if (CS%use_GL90_in_SSW) then ! The following block calculates the normalized height above the GL90 @@ -1356,10 +1394,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, do i=is,ie ; z_i_gl90(i,nz+1) = 0.0 ; enddo do k=nz,1,-1 ; do i=is,ie ; if (do_i(i)) then - z_i_gl90(i,k) = z_i_gl90(i,k+1) + h_harm(i,k)*I_Hbbl_gl90(i) + z_i_gl90(i,k) = z_i_gl90(i,k+1) + dz_harm(i,k)*I_Hbbl_gl90(i) endif ; enddo ; enddo ! i & k loops - call find_coupling_coef_gl90(a_cpl_gl90, hvel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) + call find_coupling_coef_gl90(a_cpl_gl90, dz_vel, do_i, z_i_gl90, j, G, GV, CS, VarMix, work_on_u=.false.) endif if ( allocated(hML_v)) then @@ -1374,35 +1412,39 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, enddo if (do_any_shelf) then if (CS%harmonic_visc) then - do k=1,nz ; do i=is,ie ; hvel_shelf(i,k) = hvel(i,k) ; enddo ; enddo + do k=1,nz ; do i=is,ie + hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) + enddo ; enddo else ! Find upwind-biased thickness near the surface. ! Perhaps this needs to be done more carefully, via find_eta. do i=is,ie ; if (do_i_shelf(i)) then zh(i) = 0.0 ; Ztop_min(I) = min(zcol1(i), zcol2(i)) - I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J)*GV%Z_to_H + h_neglect) + I_HTbl(i) = 1.0 / (visc%tbl_thick_shelf_v(i,J) + dz_neglect) endif ; enddo do k=1,nz do i=is,ie ; if (do_i_shelf(i)) then - zcol1(i) = zcol1(i) - h(i,j,k) ; zcol2(i) = zcol2(i) - h(i,j+1,k) - zh(i) = zh(i) + h_harm(i,k) + zcol1(i) = zcol1(i) - dz(i,j,k) ; zcol2(i) = zcol2(i) - dz(i,j+1,k) + zh(i) = zh(i) + dz_harm(i,k) - hvel_shelf(i,k) = hvel(i,k) + hvel_shelf(i,k) = hvel(i,k) ; dz_vel_shelf(i,k) = dz_vel(i,k) if (v(i,J,k) * h_delta(i,k) > 0) then if (zh(i) * I_HTbl(i) < CS%harm_BL_val) then hvel_shelf(i,k) = min(hvel(i,k), h_harm(i,k)) + dz_vel_shelf(i,k) = min(dz_vel(i,k), dz_harm(i,k)) else z2_wt = 1.0 ; if (zh(i) * I_HTbl(i) < 2.0*CS%harm_BL_val) & z2_wt = max(0.0, min(1.0, zh(i) * I_HTbl(i) * I_valBL - 1.0)) z2 = z2_wt * (max(zh(i), Ztop_min(i) - min(zcol1(i),zcol2(i))) * I_HTbl(i)) topfn = 1.0 / (1.0 + 0.09*z2**6) hvel_shelf(i,k) = min(hvel(i,k), (1.0-topfn)*h_arith(i,k) + topfn*h_harm(i,k)) + dz_vel_shelf(i,k) = min(dz_vel(i,k), (1.0-topfn)*dz_arith(i,k) + topfn*dz_harm(i,k)) endif endif endif ; enddo enddo endif - call find_coupling_coef(a_shelf, hvel_shelf, do_i_shelf, h_harm, bbl_thick, & - kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, forces, & + call find_coupling_coef(a_shelf, dz_vel_shelf, do_i_shelf, dz_harm, bbl_thick, & + kv_bbl, z_i, h_ml, dt, j, G, GV, US, CS, visc, Ustar_2d, tv, & work_on_u=.false., OBC=OBC, shelf=.true.) do i=is,ie ; if (do_i_shelf(i)) CS%a1_shelf_v(i,J) = a_shelf(i,1) ; enddo endif @@ -1432,20 +1474,20 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, endif ; enddo ; enddo do K=1,nz+1 ; do i=is,ie ; if (do_i(i)) then CS%a_v_gl90(i,J,K) = min(a_cpl_max, a_cpl_gl90(i,K)) - endif ; enddo ; enddo + endif ; enddo ; enddo do k=1,nz ; do i=is,ie ; if (do_i(i)) CS%h_v(i,J,k) = hvel(i,k) + h_neglect ; enddo ; enddo endif ! Diagnose total Kv at v-points if (CS%id_Kv_v > 0) then do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) + if (do_i(I)) Kv_v(i,J,k) = 0.5 * (CS%a_v(i,J,K)+CS%a_v(i,J,K+1)) * CS%h_v(i,J,k) enddo ; enddo endif ! Diagnose GL90 Kv at v-points if (CS%id_Kv_gl90_v > 0) then do k=1,nz ; do i=is,ie - if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * GV%H_to_Z*(CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) + if (do_i(I)) Kv_gl90_v(i,J,k) = 0.5 * (CS%a_v_gl90(i,J,K)+CS%a_v_gl90(i,J,K+1)) * CS%h_v(i,J,k) enddo ; enddo endif enddo ! end of v-point j loop @@ -1454,10 +1496,10 @@ subroutine vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS, OBC, call uvchksum("vertvisc_coef h_[uv]", CS%h_u, CS%h_v, G%HI, haloshift=0, & scale=GV%H_to_m, scalar_pair=.true.) call uvchksum("vertvisc_coef a_[uv]", CS%a_u, CS%a_v, G%HI, haloshift=0, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(hML_u) .and. allocated(hML_v)) & call uvchksum("vertvisc_coef hML_[uv]", hML_u, hML_v, G%HI, & - haloshift=0, scale=GV%H_to_m, scalar_pair=.true.) + haloshift=0, scale=US%Z_to_m, scalar_pair=.true.) endif ! Offer diagnostic fields for averaging. @@ -1487,32 +1529,38 @@ end subroutine vertvisc_coef !! If BOTTOMDRAGLAW is defined, the minimum of Hbbl and half the adjacent !! layer thicknesses are used to calculate a_cpl near the bottom. subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_ml, & - dt, j, G, GV, US, CS, visc, forces, work_on_u, OBC, shelf) + dt, j, G, GV, US, CS, visc, Ustar_2d, tv, work_on_u, OBC, shelf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZK_(GV)+1), & - intent(out) :: a_cpl !< Coupling coefficient across interfaces [Z T-1 ~> m s-1]. + intent(out) :: a_cpl !< Coupling coefficient across interfaces [H T-1 ~> m s-1 or Pa s m-1] real, dimension(SZIB_(G),SZK_(GV)), & - intent(in) :: hvel !< Thickness at velocity points [H ~> m or kg m-2] + intent(in) :: hvel !< Distance between interfaces at velocity points [Z ~> m] logical, dimension(SZIB_(G)), & intent(in) :: do_i !< If true, determine coupling coefficient for a column real, dimension(SZIB_(G),SZK_(GV)), & intent(in) :: h_harm !< Harmonic mean of thicknesses around a velocity - !! grid point [H ~> m or kg m-2] - real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [H ~> m or kg m-2] + !! grid point [Z ~> m] + real, dimension(SZIB_(G)), intent(in) :: bbl_thick !< Bottom boundary layer thickness [Z ~> m] real, dimension(SZIB_(G)), intent(in) :: kv_bbl !< Bottom boundary layer viscosity, exclusive of !! any depth-dependent contributions from - !! visc%Kv_shear [Z2 T-1 ~> m2 s-1]. + !! visc%Kv_shear [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZIB_(G),SZK_(GV)+1), & intent(in) :: z_i !< Estimate of interface heights above the bottom, !! normalized by the bottom boundary layer thickness [nondim] - real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [H ~> m or kg m-2] + real, dimension(SZIB_(G)), intent(out) :: h_ml !< Mixed layer depth [Z ~> m] integer, intent(in) :: j !< j-index to find coupling coefficient for real, intent(in) :: dt !< Time increment [T ~> s] type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure type(vertvisc_type), intent(in) :: visc !< Structure containing viscosities and bottom drag - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: Ustar_2d !< The wind friction velocity, calculated using + !! the Boussinesq reference density or the + !! time-evolving surface density in non-Boussinesq + !! mode [Z T-1 ~> m s-1] + type(thermo_var_ptrs), intent(in) :: tv !< A structure containing pointers to any available + !! thermodynamic fields. logical, intent(in) :: work_on_u !< If true, u-points are being calculated, !! otherwise they are v-points type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure @@ -1522,38 +1570,38 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Local variables 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] + 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 [H Z T-2 ~> m2 s-2 or Pa] 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]. + rho_av1, & ! The harmonic mean surface layer density at velocity points [R ~> kg m-3] z_t, & ! The distance from the top, sometimes normalized - ! by Hmix, [H ~> m or kg m-2] or [nondim]. - kv_TBL, & ! The viscosity in a top boundary layer under ice [Z2 T-1 ~> m2 s-1]. - tbl_thick ! The thickness of the top boundary layer [H ~> m or kg m-2] + ! by Hmix, [Z ~> m] or [nondim]. + kv_TBL, & ! The viscosity in a top boundary layer under ice [H Z T-1 ~> m2 s-1 or Pa s] + tbl_thick ! The thickness of the top boundary layer [Z ~> m] real, dimension(SZIB_(G),SZK_(GV)+1) :: & - Kv_tot, & ! The total viscosity at an interface [Z2 T-1 ~> m2 s-1]. - Kv_add ! A viscosity to add [Z2 T-1 ~> m2 s-1]. + Kv_tot, & ! The total viscosity at an interface [H Z T-1 ~> m2 s-1 or Pa s] + Kv_add ! A viscosity to add [H Z T-1 ~> m2 s-1 or Pa s] integer, dimension(SZIB_(G)) :: & nk_in_ml ! The index of the deepest interface in the mixed layer. - real :: h_shear ! The distance over which shears occur [H ~> m or kg m-2]. - real :: dhc ! The distance between the center of adjacent layers [H ~> m or kg m-2]. - real :: visc_ml ! The mixed layer viscosity [Z2 T-1 ~> m2 s-1]. - real :: I_Hmix ! The inverse of the mixed layer thickness [H-1 ~> m-1 or m2 kg-1]. + real :: h_shear ! The distance over which shears occur [Z ~> m]. + real :: dhc ! The distance between the center of adjacent layers [Z ~> m]. + real :: visc_ml ! The mixed layer viscosity [H Z T-1 ~> m2 s-1 or Pa s]. + real :: tau_scale ! A scaling factor for the interpolated wind stress magnitude [H R-1 L-1 ~> m3 kg-1 or nondim] + real :: I_Hmix ! The inverse of the mixed layer thickness [Z-1 ~> m-1]. real :: a_ml ! The layer coupling coefficient across an interface in - ! the mixed layer [Z T-1 ~> m s-1]. + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. real :: a_floor ! A lower bound on the layer coupling coefficient across an interface in - ! the mixed layer [Z T-1 ~> m s-1]. - real :: I_amax ! The inverse of the maximum coupling coefficient [T Z-1 ~> s m-1]. - real :: temp1 ! A temporary variable [H Z ~> m2 or kg m-1] + ! the mixed layer [H T-1 ~> m s-1 or Pa s m-1]. + real :: I_amax ! The inverse of the maximum coupling coefficient [T H-1 ~> s m-1 or s m2 kg-1]. + real :: temp1 ! A temporary variable [Z2 ~> m2] real :: ustar2_denom ! A temporary variable in the surface boundary layer turbulence - ! calculations [Z H-1 T-1 ~> s-1 or m3 kg-1 s-1] - real :: h_neglect ! A thickness that is so small it is usually lost - ! in roundoff and can be neglected [H ~> m or kg m-2]. + ! calculations [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: h_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: z2 ! A copy of z_i [nondim] real :: botfn ! A function that is 1 at the bottom and small far from it [nondim] real :: topfn ! A function that is 1 at the top and small far from it [nondim] - real :: kv_top ! A viscosity associated with the top boundary layer [Z2 T-1 ~> m2 s-1] + real :: kv_top ! A viscosity associated with the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: do_shelf, do_OBCs, can_exit integer :: i, k, is, ie, max_nk integer :: nz @@ -1564,13 +1612,15 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, if (work_on_u) then ; is = G%IscB ; ie = G%IecB else ; is = G%isc ; ie = G%iec ; endif nz = GV%ke - h_neglect = GV%H_subroundoff + h_neglect = GV%dZ_subroundoff + + tau_scale = US%L_to_Z * GV%RZ_to_H if (CS%answer_date < 20190101) then ! The maximum coupling coefficient was originally introduced to avoid ! truncation error problems in the tridiagonal solver. Effectively, the 1e-10 ! sets the maximum coupling coefficient increment to 1e10 m per timestep. - I_amax = (1.0e-10*US%Z_to_m) * dt + I_amax = (1.0e-10*GV%H_to_m) * dt else I_amax = 0.0 endif @@ -1609,14 +1659,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! layer thicknesses or the surface wind stresses are added later. if (work_on_u) then do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) + Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i+1,j,k)) endif ; enddo ; enddo if (do_OBCs) then do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i+1,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i+1,j,k) ; enddo endif endif ; enddo endif @@ -1625,14 +1675,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_add(i,K) = GV%H_to_Z*0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) + Kv_add(i,K) = 0.5*(visc%Kv_shear(i,j,k) + visc%Kv_shear(i,j+1,k)) endif ; enddo ; enddo if (do_OBCs) then do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j,k) ; enddo elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - do K=2,nz ; Kv_add(i,K) = GV%H_to_Z*visc%Kv_shear(i,j+1,k) ; enddo + do K=2,nz ; Kv_add(i,K) = visc%Kv_shear(i,j+1,k) ; enddo endif endif ; enddo endif @@ -1648,11 +1698,11 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! to further modify these viscosities here to take OBCs into account. if (work_on_u) then do K=2,nz ; do I=Is,Ie ; If (do_i(I)) then - Kv_tot(I,K) = Kv_tot(I,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(I,K) = Kv_tot(I,K) + 0.5*(visc%Kv_shear_Bu(I,J-1,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo else do K=2,nz ; do i=is,ie ; if (do_i(i)) then - Kv_tot(i,K) = Kv_tot(i,K) + GV%H_to_Z*(0.5)*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) + Kv_tot(i,K) = Kv_tot(i,K) + 0.5*(visc%Kv_shear_Bu(I-1,J,k) + visc%Kv_shear_Bu(I,J,k)) endif ; enddo ; enddo endif endif @@ -1665,9 +1715,9 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! These expressions assume that Kv_tot(i,nz+1) = CS%Kv, consistent with ! the suppression of turbulent mixing by the presence of a solid boundary. if (dhc < bbl_thick(i)) then - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (dhc+h_neglect)*GV%H_to_Z) + a_cpl(i,nz+1) = kv_bbl(i) / ((dhc+h_neglect) + I_amax*kv_bbl(i)) else - a_cpl(i,nz+1) = kv_bbl(i) / (I_amax*kv_bbl(i) + (bbl_thick(i)+h_neglect)*GV%H_to_Z) + a_cpl(i,nz+1) = kv_bbl(i) / ((bbl_thick(i)+h_neglect) + I_amax*kv_bbl(i)) endif endif ; enddo do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then @@ -1685,14 +1735,14 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) endif ; enddo ; enddo ! i & k loops elseif (abs(CS%Kv_extra_bbl) > 0.0) then ! There is a simple enhancement of the near-bottom viscosities, but no adjustment ! of the viscous coupling length scales to give a particular bottom stress. do i=is,ie ; if (do_i(i)) then a_cpl(i,nz+1) = (Kv_tot(i,nz+1) + CS%Kv_extra_bbl) / & - ((0.5*hvel(i,nz)+h_neglect)*GV%H_to_Z + I_amax*(Kv_tot(i,nz+1)+CS%Kv_extra_bbl)) + ((0.5*hvel(i,nz)+h_neglect) + I_amax*(Kv_tot(i,nz+1)+CS%Kv_extra_bbl)) endif ; enddo do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then ! botfn determines when a point is within the influence of the bottom @@ -1704,18 +1754,18 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) endif ; enddo ; enddo ! i & k loops else ! Any near-bottom viscous enhancements were already incorporated into Kv_tot, and there is ! no adjustment of the viscous coupling length scales to give a particular bottom stress. do i=is,ie ; if (do_i(i)) then - a_cpl(i,nz+1) = Kv_tot(i,nz+1) / ((0.5*hvel(i,nz)+h_neglect)*GV%H_to_Z + I_amax*Kv_tot(i,nz+1)) + a_cpl(i,nz+1) = Kv_tot(i,nz+1) / ((0.5*hvel(i,nz)+h_neglect) + I_amax*Kv_tot(i,nz+1)) endif ; enddo do K=nz,2,-1 ; do i=is,ie ; if (do_i(i)) then h_shear = 0.5*(hvel(i,k) + hvel(i,k-1) + h_neglect) ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) endif ; enddo ; enddo ! i & k loops endif @@ -1726,19 +1776,19 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! Set the coefficients to include the no-slip surface stress. do i=is,ie ; if (do_i(i)) then if (work_on_u) then - kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_u(I,j) - tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) * GV%Z_to_H + h_neglect + kv_TBL(i) = visc%Kv_tbl_shelf_u(I,j) + tbl_thick(i) = visc%tbl_thick_shelf_u(I,j) + h_neglect else - kv_TBL(i) = GV%H_to_Z*visc%Kv_tbl_shelf_v(i,J) - tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) * GV%Z_to_H + h_neglect + kv_TBL(i) = visc%Kv_tbl_shelf_v(i,J) + tbl_thick(i) = visc%tbl_thick_shelf_v(i,J) + h_neglect endif z_t(i) = 0.0 ! If a_cpl(i,1) were not already 0, it would be added here. if (0.5*hvel(i,1) > tbl_thick(i)) then - a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i)*GV%H_to_Z + I_amax*kv_TBL(i)) + a_cpl(i,1) = kv_TBL(i) / (tbl_thick(i) + I_amax*kv_TBL(i)) else - a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect)*GV%H_to_Z + I_amax*kv_TBL(i)) + a_cpl(i,1) = kv_TBL(i) / ((0.5*hvel(i,1)+h_neglect) + I_amax*kv_TBL(i)) endif endif ; enddo @@ -1754,35 +1804,78 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif kv_top = topfn * kv_TBL(i) - a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear*GV%H_to_Z + I_amax*kv_top) + a_cpl(i,K) = a_cpl(i,K) + kv_top / (h_shear + I_amax*kv_top) endif ; enddo ; enddo elseif (CS%dynamic_viscous_ML .or. (GV%nkml>0) .or. CS%fixed_LOTW_ML .or. CS%apply_LOTW_floor) then ! Find the friction velocity and the absolute value of the Coriolis parameter at this point. u_star(:) = 0.0 ! Zero out the friction velocity on land points. - if (work_on_u) then - do I=is,ie ; if (do_i(I)) then - u_star(I) = 0.5*(forces%ustar(i,j) + forces%ustar(i+1,j)) - absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & - u_star(I) = forces%ustar(i,j) - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & - u_star(I) = forces%ustar(i+1,j) - endif ; enddo ; endif - else - do i=is,ie ; if (do_i(i)) then - u_star(i) = 0.5*(forces%ustar(i,j) + forces%ustar(i,j+1)) - absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - endif ; enddo - if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & - u_star(i) = forces%ustar(i,j) - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & - u_star(i) = forces%ustar(i,j+1) - endif ; enddo ; endif + tau_mag(:) = 0.0 ! Zero out the friction velocity on land points. + + if (allocated(tv%SpV_avg)) then + rho_av1(:) = 0.0 + if (work_on_u) then + do I=is,ie ; if (do_i(I)) then + u_star(I) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i+1,j)) + rho_av1(I) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i+1,j,1)) + absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + u_star(I) = Ustar_2d(i,j) + rho_av1(I) = 1.0 / tv%SpV_avg(i,j,1) + elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then + u_star(I) = Ustar_2d(i+1,j) + rho_av1(I) = 1.0 / tv%SpV_avg(i+1,j,1) + endif + endif ; enddo ; endif + else ! Work on v-points + do i=is,ie ; if (do_i(i)) then + u_star(i) = 0.5 * (Ustar_2d(i,j) + Ustar_2d(i,j+1)) + rho_av1(i) = 2.0 / (tv%SpV_avg(i,j,1) + tv%SpV_avg(i,j+1,1)) + absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + u_star(i) = Ustar_2d(i,j) + rho_av1(i) = 1.0 / tv%SpV_avg(i,j,1) + elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then + u_star(i) = Ustar_2d(i,j+1) + rho_av1(i) = 1.0 / tv%SpV_avg(i,j+1,1) + endif + endif ; enddo ; endif + endif + do I=is,ie + tau_mag(I) = GV%RZ_to_H*rho_av1(i) * u_star(I)**2 + enddo + else ! (.not.allocated(tv%SpV_avg)) + if (work_on_u) then + do I=is,ie ; if (do_i(I)) then + u_star(I) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i+1,j)) + absf(I) = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do I=is,ie ; if (do_i(I) .and. (OBC%segnum_u(I,j) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) & + u_star(I) = Ustar_2d(i,j) + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) & + u_star(I) = Ustar_2d(i+1,j) + endif ; enddo ; endif + else + do i=is,ie ; if (do_i(i)) then + u_star(i) = 0.5*(Ustar_2d(i,j) + Ustar_2d(i,j+1)) + absf(i) = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + endif ; enddo + if (do_OBCs) then ; do i=is,ie ; if (do_i(i) .and. (OBC%segnum_v(i,J) /= OBC_NONE)) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) & + u_star(i) = Ustar_2d(i,j) + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) & + u_star(i) = Ustar_2d(i,j+1) + endif ; enddo ; endif + endif + do I=is,ie + tau_mag(I) = GV%Z_to_H*u_star(I)**2 + enddo endif ! Determine the thickness of the surface ocean boundary layer and its extent in index space. @@ -1863,12 +1956,16 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, ! The viscosity in visc_ml 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. - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z - ustar2_denom = (CS%vonKar * u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif visc_ml = temp1 * ustar2_denom ! Set the viscous coupling based on the model's vertical resolution. The omission of ! the I_amax factor here is consistent with answer dates above 20190101. - a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) * GV%H_to_Z) + a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect)) ! As a floor on the viscous coupling, assume that the length scale in the denominator can ! not be larger than the distance from the surface, consistent with a logarithmic velocity @@ -1883,8 +1980,12 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then z_t(i) = z_t(i) + hvel(i,k-1) - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z - ustar2_denom = (CS%vonKar * u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) + if (GV%Boussinesq) then + ustar2_denom = (CS%vonKar * GV%Z_to_H*u_star(i)**2) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + else + ustar2_denom = (CS%vonKar * tau_mag(i)) / (absf(i)*temp1 + (h_ml(i)+h_neglect)*u_star(i)) + endif ! As a floor on the viscous coupling, assume that the length scale in the denominator can not ! be larger than the distance from the surface, consistent with a logarithmic velocity profile. @@ -1894,16 +1995,17 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, do K=2,max_nk ; do i=is,ie ; if (k <= nk_in_ml(i)) then z_t(i) = z_t(i) + hvel(i,k-1) - temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i))*GV%H_to_Z + temp1 = (z_t(i)*h_ml(i) - z_t(i)*z_t(i)) ! 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. + ! The following expressions are mathematically equivalent. 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)) + visc_ml = u_star(i) * CS%vonKar * (GV%Z_to_H*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) + a_ml = visc_ml / (0.25*(hvel(i,k)+hvel(i,k-1) + h_neglect) + 0.5*I_amax*visc_ml) ! Choose the largest estimate of a_cpl, but these could be changed to be additive. a_cpl(i,K) = max(a_cpl(i,K), a_ml) @@ -2005,7 +2107,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS enddo ! j-loop else ! Do not report accelerations leading to large velocities. if (CS%CFL_based_trunc) then -!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,dt,G,CS,h,H_report) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do I=Isq,Ieq if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 elseif ((u(I,j,k) * (dt * G%dy_Cu(I,j))) * G%IareaT(i+1,j) < -CS%CFL_trunc) then @@ -2017,7 +2119,7 @@ subroutine vertvisc_limit_vel(u, v, h, ADp, CDp, forces, visc, dt, G, GV, US, CS endif enddo ; enddo ; enddo else -!$OMP parallel do default(none) shared(nz,js,je,Isq,Ieq,u,G,CS,truncvel,maxvel,h,H_report) + !$OMP parallel do default(shared) do k=1,nz ; do j=js,je ; do I=Isq,Ieq if (abs(u(I,j,k)) < CS%vel_underflow) then ; u(I,j,k) = 0.0 elseif (abs(u(I,j,k)) > maxvel) then @@ -2142,8 +2244,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & ! Local variables - real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [Z2 T-1 ~> m2 s-1]. - real :: Hmix_z ! A boundary layer thickness [Z ~> m]. + real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [H Z T-1 ~> m2 s-1 or Pa s] + real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-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 the @@ -2256,17 +2358,16 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) if (GV%nkml < 1) then - call get_param(param_file, mdl, "HMIX_FIXED", Hmix_z, & + call get_param(param_file, mdl, "HMIX_FIXED", CS%Hmix, & "The prescribed depth over which the near-surface viscosity and "//& "diffusivity are elevated when the bulk mixed layer is not used.", & units="m", scale=US%m_to_Z, fail_if_missing=.true.) - CS%Hmix = GV%Z_to_H * Hmix_z endif if (CS%direct_stress) then if (GV%nkml < 1) then call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & - units="m", default=US%Z_to_m*Hmix_z, scale=GV%m_to_H) + units="m", default=US%Z_to_m*CS%Hmix, scale=GV%m_to_H) else call get_param(param_file, mdl, "HMIX_STRESS", CS%Hmix_stress, & "The depth over which the wind stress is applied if DIRECT_STRESS is true.", & @@ -2275,17 +2376,20 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & if (CS%Hmix_stress <= 0.0) call MOM_error(FATAL, "vertvisc_init: " // & "HMIX_STRESS must be set to a positive value if DIRECT_STRESS is true.") endif - call get_param(param_file, mdl, "KV", CS%Kv, & + call get_param(param_file, mdl, "KV", Kv_back_z, & "The background kinematic viscosity in the interior. "//& "The molecular value, ~1e-6 m2 s-1, may be used.", & units="m2 s-1", fail_if_missing=.true., scale=US%m2_s_to_Z2_T) + ! Convert input kinematic viscosity to dynamic viscosity when non-Boussinesq. + CS%Kv = (US%Z2_T_to_m2_s*GV%m2_s_to_HZ_T) * Kv_back_z + call get_param(param_file, mdl, "USE_GL90_IN_SSW", CS%use_GL90_in_SSW, & "If true, use simpler method to calculate 1/N^2 in GL90 vertical "// & "viscosity coefficient. This method is valid in stacked shallow water mode.", & default=.false.) call get_param(param_file, mdl, "KD_GL90", CS%kappa_gl90, & "The scalar diffusivity used in GL90 vertical viscosity scheme.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, & + units="m2 s-1", default=0.0, scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s, & do_not_log=.not.CS%use_GL90_in_SSW) call get_param(param_file, mdl, "READ_KD_GL90", CS%read_kappa_gl90, & "If true, read a file (given by KD_GL90_FILE) containing the "//& @@ -2309,7 +2413,8 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & kappa_gl90_file = trim(inputdir) // trim(kappa_gl90_file) allocate(CS%kappa_gl90_2d(G%isd:G%ied, G%jsd:G%jed), source=0.0) - call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, scale=US%m_to_L**2*US%T_to_s) + call MOM_read_data(kappa_gl90_file, kdgl90_varname, CS%kappa_gl90_2d(:,:), G%domain, & + scale=US%m_to_L*US%Z_to_L*GV%m_to_H*US%T_to_s) call pass_var(CS%kappa_gl90_2d, G%domain) endif call get_param(param_file, mdl, "USE_GL90_N2", CS%use_GL90_N2, & @@ -2332,7 +2437,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "viscosity via Kv_GL90 = alpha_GL90 * f2. Is only used "// & "if USE_GL90_N2 is true. Note that the implied Kv_GL90 "// & "corresponds to a KD_GL90 that scales as N^2 with depth.", & - units="m2 s", default=0.0, scale=US%m_to_Z**2*US%s_to_T, & + units="m2 s", default=0.0, scale=GV%m_to_H*US%m_to_Z*US%s_to_T, & do_not_log=.not.CS%use_GL90_in_SSW) endif call get_param(param_file, mdl, "HBBL_GL90", CS%Hbbl_gl90, & @@ -2340,7 +2445,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "which defines the range over which the GL90 coupling "//& "coefficient is zeroed out, in order to avoid fluxing "//& "momentum into vanished layers over steep topography.", & - units="m", default=5.0, scale=GV%m_to_H, do_not_log=.not.CS%use_GL90_in_SSW) + units="m", default=5.0, scale=US%m_to_Z, do_not_log=.not.CS%use_GL90_in_SSW) CS%Kvml_invZ2 = 0.0 if (GV%nkml < 1) then @@ -2359,19 +2464,20 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & "transmitted through infinitesimally thin surface layers. This is an "//& "older option for numerical convenience without a strong physical basis, "//& "and its use is now discouraged.", & - units="m2 s-1", default=Kv_mks, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=Kv_mks, scale=GV%m2_s_to_HZ_T) endif if (.not.CS%bottomdraglaw) then call get_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=0.0, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T, do_not_log=.true.) if (CS%Kv_extra_bbl == 0.0) then call get_param(param_file, mdl, "KVBBL", Kv_BBL, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=US%Z2_T_to_m2_s*CS%Kv, scale=US%m2_s_to_Z2_T, do_not_log=.true.) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_back_z, scale=GV%m2_s_to_HZ_T, & + do_not_log=.true.) if (abs(Kv_BBL - CS%Kv) > 1.0e-15*abs(CS%Kv)) then call MOM_error(WARNING, "KVBBL is a deprecated parameter. Use KV_EXTRA_BBL instead.") CS%Kv_extra_bbl = Kv_BBL - CS%Kv @@ -2380,14 +2486,14 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call log_param(param_file, mdl, "KV_EXTRA_BBL", CS%Kv_extra_bbl, & "An extra kinematic viscosity in the benthic boundary layer. "//& "KV_EXTRA_BBL is not used if BOTTOMDRAGLAW is true.", & - units="m2 s-1", default=0.0, unscale=US%Z2_T_to_m2_s) + units="m2 s-1", default=0.0, unscale=GV%HZ_T_to_m2_s) endif call get_param(param_file, mdl, "HBBL", CS%Hbbl, & "The thickness of a bottom boundary layer with a viscosity increased by "//& "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& "defined but LINEAR_DRAG is not.", & - units="m", fail_if_missing=.true., scale=GV%m_to_H) + units="m", fail_if_missing=.true., scale=US%m_to_Z) call get_param(param_file, mdl, "MAXVEL", CS%maxvel, & "The maximum velocity allowed before the velocity components are truncated.", & units="m s-1", default=3.0e8, scale=US%m_s_to_L_T) @@ -2447,28 +2553,28 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & 'Slow varying vertical viscosity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) CS%id_Kv_u = register_diag_field('ocean_model', 'Kv_u', diag%axesCuL, Time, & - 'Total vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_v = register_diag_field('ocean_model', 'Kv_v', diag%axesCvL, Time, & - 'Total vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'Total vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_gl90_u = register_diag_field('ocean_model', 'Kv_gl90_u', diag%axesCuL, Time, & - 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'GL90 vertical viscosity at u-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_Kv_gl90_v = register_diag_field('ocean_model', 'Kv_gl90_v', diag%axesCvL, Time, & - 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=US%Z2_T_to_m2_s) + 'GL90 vertical viscosity at v-points', 'm2 s-1', conversion=GV%H_to_m**2*US%s_to_T) CS%id_au_vv = register_diag_field('ocean_model', 'au_visc', diag%axesCui, Time, & - 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Zonal Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_av_vv = register_diag_field('ocean_model', 'av_visc', diag%axesCvi, Time, & - 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Meridional Viscous Vertical Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_au_gl90_vv = register_diag_field('ocean_model', 'au_gl90_visc', diag%axesCui, Time, & - 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Zonal Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_av_gl90_vv = register_diag_field('ocean_model', 'av_gl90_visc', diag%axesCvi, Time, & - 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=US%Z_to_m*US%s_to_T) + 'Meridional Viscous Vertical GL90 Coupling Coefficient', 'm s-1', conversion=GV%H_to_m*US%s_to_T) CS%id_h_u = register_diag_field('ocean_model', 'Hu_visc', diag%axesCuL, Time, & 'Thickness at Zonal Velocity Points for Viscosity', & @@ -2482,11 +2588,11 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_hML_u = register_diag_field('ocean_model', 'HMLu_visc', diag%axesCu1, Time, & 'Mixed Layer Thickness at Zonal Velocity Points for Viscosity', & - thickness_units, conversion=GV%H_to_MKS) + thickness_units, conversion=US%Z_to_m) CS%id_hML_v = register_diag_field('ocean_model', 'HMLv_visc', diag%axesCv1, Time, & 'Mixed Layer Thickness at Meridional Velocity Points for Viscosity', & - thickness_units, conversion=GV%H_to_MKS) + thickness_units, conversion=US%Z_to_m) CS%id_du_dt_visc = register_diag_field('ocean_model', 'du_dt_visc', diag%axesCuL, Time, & 'Zonal Acceleration from Vertical Viscosity', 'm s-2', conversion=US%L_T2_to_m_s2) From c4ff0214f857806e7c1efdb3610ae9d23dbf3b14 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 16:16:39 -0400 Subject: [PATCH 365/629] *+Add forcing%tau_mag_gustless & tau_mag opt args Added the new tau_mag_gustless element to the forcing type, and set this array in set_derived_forcing_fields if it is associated. Also added new tau_mag optional arguments to the public routines allocate_forcing_by_group() and allocate_mech_forcing_by_group(), with similar mandatory arguments added to the private subroutines get_forcing_groups() and get_mech_forcing_groups(). Tests for an associated pointer were added before all calls setting the ustar, tau_mag or ustar_gustless arrays, preparing for these ustar pointers only to be set when the model is run in Boussinesq mode when the ustar actually make sense. Also use specific volume derivatives to calculate non-Boussinesq mode buoyancy fluxes in calculateBuoyancy_Flux1d, leaving the Boussinesq buoyancy flux calculations unchanged. All answers are bitwise identical in Boussinesq mode, but there is a new element in a transparent type and new optional arguments publicly visible subroutines, and answers will change in non-Boussinesq cases that depend on the surface buoyancyFlux that is returned by calculateBuoyancy_Flux1d. --- src/core/MOM_forcing_type.F90 | 226 +++++++++++++++++++++++----------- 1 file changed, 154 insertions(+), 72 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a6d35903ee..c86b9b869f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -11,7 +11,7 @@ module MOM_forcing_type use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field use MOM_diag_mediator, only : time_type, diag_ctrl, safe_alloc_alloc, query_averaging_enabled use MOM_diag_mediator, only : enable_averages, disable_averaging -use MOM_EOS, only : calculate_density_derivs, EOS_domain +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -78,8 +78,11 @@ module MOM_forcing_type 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 + ustar_gustless => NULL(), & !< surface friction velocity scale without any !! any augmentation for gustiness [Z T-1 ~> m s-1]. + tau_mag_gustless => NULL() !< Magnitude of the wind stress averaged over tracer cells, + !! without any augmentation for sub-gridscale variability + !! or gustiness [R L Z T-2 ~> Pa] ! surface buoyancy force, used when temperature is not a state variable real, pointer, dimension(:,:) :: & @@ -989,13 +992,19 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt real, dimension(SZI_(G)) :: pressure ! pressure at the surface [R L2 T-2 ~> Pa] real, dimension(SZI_(G)) :: dRhodT ! density partial derivative wrt temp [R C-1 ~> kg m-3 degC-1] real, dimension(SZI_(G)) :: dRhodS ! density partial derivative wrt saln [R S-1 ~> kg m-3 ppt-1] + real, dimension(SZI_(G)) :: dSpV_dT ! Partial derivative of specific volume with respect + ! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)) :: dSpV_dS ! Partial derivative of specific volume with respect + ! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G),SZK_(GV)+1) :: netPen ! The net penetrating shortwave radiation at each level ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] logical :: useRiverHeatContent logical :: useCalvingHeatContent - real :: GoRho ! The gravitational acceleration divided by mean density times a - ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: GoRho ! The gravitational acceleration divided by mean density times a + ! unit conversion factor [L2 H-1 R-1 T-2 ~> m4 kg-1 s-2 or m7 kg-2 s-2] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R L2 H-1 T-2 ~> kg m-2 s-2 or m s-2] real :: H_limit_fluxes ! A depth scale that specifies when the ocean is shallow that ! it is necessary to eliminate fluxes [H ~> m or kg m-2] integer :: i, k @@ -1005,9 +1014,6 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt useCalvingHeatContent = .False. H_limit_fluxes = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - pressure(:) = 0. - if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif - GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -1027,10 +1033,6 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt call sumSWoverBands(G, GV, US, h(:,j,:), dz, optics_nbands(optics), optics, j, 1.0, & H_limit_fluxes, .true., penSWbnd, netPen) - ! Density derivatives - call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & - tv%eqn_of_state, EOS_domain(G%HI)) - ! Adjust netSalt to reflect dilution effect of FW flux ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netSalt(G%isc:G%iec) = netSalt(G%isc:G%iec) - Salt(G%isc:G%iec,j,1) * netH(G%isc:G%iec) @@ -1041,13 +1043,41 @@ subroutine calculateBuoyancyFlux1d(G, GV, US, fluxes, optics, nsw, h, Temp, Salt !netHeat(:) = netHeatMinusSW(:) + sum( penSWbnd, dim=1 ) netHeat(G%isc:G%iec) = netHeatMinusSW(G%isc:G%iec) + netPen(G%isc:G%iec,1) - ! Convert to a buoyancy flux, excluding penetrating SW heating - buoyancyFlux(G%isc:G%iec,1) = - GoRho * ( dRhodS(G%isc:G%iec) * netSalt(G%isc:G%iec) + & - dRhodT(G%isc:G%iec) * netHeat(G%isc:G%iec) ) ! [L2 T-3 ~> m2 s-3] - ! We also have a penetrative buoyancy flux associated with penetrative SW - do k=2, GV%ke+1 - buoyancyFlux(G%isc:G%iec,k) = - GoRho * ( dRhodT(G%isc:G%iec) * netPen(G%isc:G%iec,k) ) ! [L2 T-3 ~> m2 s-3] - enddo + ! Determine the buoyancy flux + pressure(:) = 0. + if (associated(tv%p_surf)) then ; do i=G%isc,G%iec ; pressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ + + ! Specific volume derivatives + call calculate_specific_vol_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], first excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = g_conv * (dSpV_dS(i) * netSalt(i) + dSpV_dT(i) * netHeat(i)) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = g_conv * ( dSpV_dT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + else + GoRho = (GV%g_Earth * GV%H_to_Z) / GV%Rho0 + + ! Density derivatives + call calculate_density_derivs(Temp(:,j,1), Salt(:,j,1), pressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOS_domain(G%HI)) + + ! Convert to a buoyancy flux [L2 T-3 ~> m2 s-3], excluding penetrating SW heating + do i=G%isc,G%iec + buoyancyFlux(i,1) = - GoRho * ( dRhodS(i) * netSalt(i) + dRhodT(i) * netHeat(i) ) + enddo + ! We also have a penetrative buoyancy flux associated with penetrative SW + do k=2,GV%ke+1 ; do i=G%isc,G%iec + buoyancyFlux(i,k) = - GoRho * ( dRhodT(i) * netPen(i,k) ) ! [L2 T-3 ~> m2 s-3] + enddo ; enddo + endif end subroutine calculateBuoyancyFlux1d @@ -2201,34 +2231,55 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) wt2 = 1.0 - wt1 ! = flux_tmp%dt_buoy_accum / (fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum) fluxes%dt_buoy_accum = fluxes%dt_buoy_accum + flux_tmp%dt_buoy_accum - ! Copy over the pressure fields and accumulate averages of ustar, either from the forcing + ! Copy over the pressure fields and accumulate averages of ustar or tau_mag, either from the forcing ! type or from the temporary fluxes type. if (present(forces)) then do j=js,je ; do i=is,ie fluxes%p_surf(i,j) = forces%p_surf(i,j) fluxes%p_surf_full(i,j) = forces%p_surf_full(i,j) + enddo ; enddo + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*forces%ustar(i,j) + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*forces%tau_mag(i,j) - enddo ; enddo + enddo ; enddo ; endif else do j=js,je ; do i=is,ie fluxes%p_surf(i,j) = flux_tmp%p_surf(i,j) fluxes%p_surf_full(i,j) = flux_tmp%p_surf_full(i,j) + enddo ; enddo + if (associated(fluxes%ustar)) then ; do j=js,je ; do i=is,ie fluxes%ustar(i,j) = wt1*fluxes%ustar(i,j) + wt2*flux_tmp%ustar(i,j) + enddo ; enddo ; endif + if (associated(fluxes%tau_mag)) then ; do j=js,je ; do i=is,ie fluxes%tau_mag(i,j) = wt1*fluxes%tau_mag(i,j) + wt2*flux_tmp%tau_mag(i,j) - enddo ; enddo + enddo ; enddo ; endif endif - ! Average the water, heat, and salt fluxes, and ustar. - do j=js,je ; do i=is,ie + ! Average ustar_gustless. + if (associated(fluxes%ustar_gustless)) then if (fluxes%gustless_accum_bug) then - fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = flux_tmp%ustar_gustless(i,j) + enddo ; enddo else - fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + do j=js,je ; do i=is,ie + fluxes%ustar_gustless(i,j) = wt1*fluxes%ustar_gustless(i,j) + wt2*flux_tmp%ustar_gustless(i,j) + enddo ; enddo endif + endif + if (associated(fluxes%tau_mag_gustless)) then + do j=js,je ; do i=is,ie + fluxes%tau_mag_gustless(i,j) = wt1*fluxes%tau_mag_gustless(i,j) + wt2*flux_tmp%tau_mag_gustless(i,j) + enddo ; enddo + endif + + ! Average the water, heat, and salt fluxes. + do j=js,je ; do i=is,ie fluxes%evap(i,j) = wt1*fluxes%evap(i,j) + wt2*flux_tmp%evap(i,j) fluxes%lprec(i,j) = wt1*fluxes%lprec(i,j) + wt2*flux_tmp%lprec(i,j) fluxes%fprec(i,j) = wt1*fluxes%fprec(i,j) + wt2*flux_tmp%fprec(i,j) @@ -2383,8 +2434,8 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) Irho0 = US%L_to_Z / Rho0 - if (associated(forces%taux) .and. associated(forces%tauy) .and. & - associated(fluxes%ustar_gustless)) then + if ( associated(forces%taux) .and. associated(forces%tauy) .and. & + (associated(fluxes%ustar_gustless) .or. associated(fluxes%tau_mag_gustless)) ) then do j=js,je ; do i=is,ie taux2 = 0.0 if ((G%mask2dCu(I-1,j) + G%mask2dCu(I,j)) > 0.0) & @@ -2397,11 +2448,16 @@ subroutine set_derived_forcing_fields(forces, fluxes, G, US, Rho0) G%mask2dCv(i,J) * forces%tauy(i,J)**2) / & (G%mask2dCv(i,J-1) + G%mask2dCv(i,J)) - if (fluxes%gustless_accum_bug) then - ! This change is just for computational efficiency, but it is wrapped with another change. - fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) - else - fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + if (associated(fluxes%ustar_gustless)) then + if (fluxes%gustless_accum_bug) then + ! This change is just for computational efficiency, but it is wrapped with another change. + fluxes%ustar_gustless(i,j) = sqrt(US%L_to_Z * sqrt(taux2 + tauy2) / Rho0) + else + fluxes%ustar_gustless(i,j) = sqrt(sqrt(taux2 + tauy2) * Irho0) + endif + endif + if (associated(fluxes%tau_mag_gustless)) then + fluxes%tau_mag_gustless(i,j) = sqrt(taux2 + tauy2) endif enddo ; enddo endif @@ -3157,7 +3213,7 @@ end subroutine forcing_diagnostics !> Conditionally allocate fields within the forcing type subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & shelf, iceberg, salt, fix_accum_bug, cfc, waves, & - shelf_sfc_accumulation, lamult, hevap) + shelf_sfc_accumulation, lamult, hevap, tau_mag) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(forcing), intent(inout) :: fluxes !< A structure containing thermodynamic forcing fields logical, optional, intent(in) :: water !< If present and true, allocate water fluxes @@ -3178,6 +3234,7 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & logical, optional, intent(in) :: hevap !< If present and true, allocate heat content evap. !! This field must be allocated when enthalpy is provided !! via coupler. + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag and related fields ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -3197,6 +3254,10 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & call myAlloc(fluxes%ustar_gustless,isd,ied,jsd,jed, ustar) call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, ustar) + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(fluxes%tau_mag,isd,ied,jsd,jed, tau_mag) + call myAlloc(fluxes%tau_mag_gustless,isd,ied,jsd,jed, tau_mag) + call myAlloc(fluxes%evap,isd,ied,jsd,jed, water) call myAlloc(fluxes%lprec,isd,ied,jsd,jed, water) call myAlloc(fluxes%fprec,isd,ied,jsd,jed, water) @@ -3257,20 +3318,20 @@ subroutine allocate_forcing_by_group(G, fluxes, water, heat, ustar, press, & if (present(fix_accum_bug)) fluxes%gustless_accum_bug = .not.fix_accum_bug end subroutine allocate_forcing_by_group - +!> Allocate elements of a new forcing type based on their status in an existing type. subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) - type(forcing), intent(in) :: fluxes_ref !< Reference fluxes - type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes - type(forcing), intent(out) :: fluxes !< Target fluxes + type(forcing), intent(in) :: fluxes_ref !< Reference fluxes + type(ocean_grid_type), intent(in) :: G !< Grid metric of target fluxes + type(forcing), intent(out) :: fluxes !< Target fluxes - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & - do_iceberg, do_heat_added, do_buoy + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes_ref, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & - do_press, do_shelf, do_iceberg, do_salt) + do_press, do_shelf, do_iceberg, do_salt, do_taumag) ! The following fluxes would typically be allocated by the driver call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & @@ -3309,7 +3370,7 @@ end subroutine allocate_forcing_by_ref !> Conditionally allocate fields within the mechanical forcing type using !! control flags. subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & - press, iceberg, waves, num_stk_bands) + press, iceberg, waves, num_stk_bands, tau_mag) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(mech_forcing), intent(inout) :: forces !< Forcing fields structure @@ -3320,6 +3381,7 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & logical, optional, intent(in) :: iceberg !< If present and true, allocate forces for icebergs logical, optional, intent(in) :: waves !< If present and true, allocate wave fields integer, optional, intent(in) :: num_stk_bands !< Number of Stokes bands to allocate + logical, optional, intent(in) :: tau_mag !< If present and true, allocate tau_mag ! Local variables integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -3332,6 +3394,8 @@ subroutine allocate_mech_forcing_by_group(G, forces, stress, ustar, shelf, & call myAlloc(forces%ustar,isd,ied,jsd,jed, ustar) call myAlloc(forces%tau_mag,isd,ied,jsd,jed, ustar) + ! Note that myAlloc can be called safely multiple times for the same pointer. + call myAlloc(forces%tau_mag,isd,ied,jsd,jed, tau_mag) call myAlloc(forces%p_surf,isd,ied,jsd,jed, press) call myAlloc(forces%p_surf_full,isd,ied,jsd,jed, press) @@ -3371,24 +3435,25 @@ subroutine allocate_mech_forcing_from_ref(forces_ref, G, forces) type(ocean_grid_type), intent(in) :: G !< Grid metric of target forcing type(mech_forcing), intent(out) :: forces !< Mechanical forcing fields - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg ! Identify the active fields in the reference forcing - call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_shelf, & - do_press, do_iceberg) + call get_mech_forcing_groups(forces_ref, do_stress, do_ustar, do_tau_mag, do_shelf, & + do_press, do_iceberg) call allocate_mech_forcing(G, forces, do_stress, do_ustar, do_shelf, & - do_press, do_iceberg) + do_press, do_iceberg, tau_mag=do_tau_mag) end subroutine allocate_mech_forcing_from_ref !> Return flags indicating which groups of forcings are allocated -subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & +subroutine get_forcing_groups(fluxes, water, heat, ustar, tau_mag, press, shelf, & iceberg, salt, heat_added, buoy) type(forcing), intent(in) :: fluxes !< Reference flux fields logical, intent(out) :: water !< True if fluxes contains water-based fluxes logical, intent(out) :: heat !< True if fluxes contains heat-based fluxes - logical, intent(out) :: ustar !< True if fluxes contains ustar fluxes + logical, intent(out) :: ustar !< True if fluxes contains ustar + logical, intent(out) :: tau_mag !< True if fluxes contains tau_mag logical, intent(out) :: press !< True if fluxes contains surface pressure logical, intent(out) :: shelf !< True if fluxes contains ice shelf fields logical, intent(out) :: iceberg !< True if fluxes contains iceberg fluxes @@ -3401,6 +3466,7 @@ subroutine get_forcing_groups(fluxes, water, heat, ustar, press, shelf, & ! we handle them here as independent flags. ustar = associated(fluxes%ustar) .and. associated(fluxes%ustar_gustless) + tau_mag = associated(fluxes%tau_mag) .and. associated(fluxes%tau_mag_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) @@ -3414,10 +3480,11 @@ end subroutine get_forcing_groups !> Return flags indicating which groups of mechanical forcings are allocated -subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) +subroutine get_mech_forcing_groups(forces, stress, ustar, tau_mag, shelf, press, iceberg) type(mech_forcing), intent(in) :: forces !< Reference forcing fields logical, intent(out) :: stress !< True if forces contains wind stress fields logical, intent(out) :: ustar !< True if forces contains ustar field + logical, intent(out) :: tau_mag !< True if forces contains tau_mag field logical, intent(out) :: shelf !< True if forces contains ice shelf fields logical, intent(out) :: press !< True if forces contains pressure fields logical, intent(out) :: iceberg !< True if forces contains iceberg fields @@ -3425,6 +3492,7 @@ subroutine get_mech_forcing_groups(forces, stress, ustar, shelf, press, iceberg) stress = associated(forces%taux) & .and. associated(forces%tauy) ustar = associated(forces%ustar) + tau_mag = associated(forces%tau_mag) shelf = associated(forces%rigidity_ice_u) & .and. associated(forces%rigidity_ice_v) & .and. associated(forces%frac_shelf_u) & @@ -3539,17 +3607,21 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) type(forcing), intent(inout) :: fluxes !< Rotated forcing structure integer, intent(in) :: turns !< Number of quarter turns - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf, & do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes_in, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) - if (do_ustar) then + if (associated(fluxes_in%ustar)) & call rotate_array(fluxes_in%ustar, turns, fluxes%ustar) + if (associated(fluxes_in%ustar_gustless)) & call rotate_array(fluxes_in%ustar_gustless, turns, fluxes%ustar_gustless) + + if (associated(fluxes_in%tau_mag)) & call rotate_array(fluxes_in%tau_mag, turns, fluxes%tau_mag) - endif + if (associated(fluxes_in%tau_mag_gustless)) & + call rotate_array(fluxes_in%tau_mag_gustless, turns, fluxes%tau_mag_gustless) if (do_water) then call rotate_array(fluxes_in%evap, turns, fluxes%evap) @@ -3670,19 +3742,19 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) integer, intent(in) :: turns !< Number of quarter-turns type(mech_forcing), intent(inout) :: forces !< Forcing on the rotated domain - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg + logical :: do_stress, do_ustar, do_tau_mag, do_shelf, do_press, do_iceberg - call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_shelf, & + call get_mech_forcing_groups(forces_in, do_stress, do_ustar, do_tau_mag, do_shelf, & do_press, do_iceberg) if (do_stress) & call rotate_vector(forces_in%taux, forces_in%tauy, turns, & forces%taux, forces%tauy) - if (do_ustar) then + if (associated(forces_in%ustar)) & call rotate_array(forces_in%ustar, turns, forces%ustar) + if (associated(forces_in%tau_mag)) & call rotate_array(forces_in%tau_mag, turns, forces%tau_mag) - endif if (do_shelf) then call rotate_array_pair( & @@ -3726,8 +3798,9 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) !! or updated from mean tau. real :: tx_mean, ty_mean ! Mean wind stresses [R L Z T-2 ~> Pa] + real :: tau_mag ! The magnitude of the wind stresses [R L Z T-2 ~> Pa] real :: Irho0 ! Inverse of the mean density rescaled to [Z L-1 R-1 ~> m3 kg-1] - logical :: do_stress, do_ustar, do_shelf, do_press, do_iceberg, tau2ustar + logical :: do_stress, do_ustar, do_taumag, do_shelf, do_press, do_iceberg, tau2ustar integer :: i, j, is, ie, js, je, isB, ieB, jsB, jeB is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isB = G%iscB ; ieB = G%iecB ; jsB = G%jscB ; jeB = G%jecB @@ -3737,7 +3810,7 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) tau2ustar = .false. if (present(UpdateUstar)) tau2ustar = UpdateUstar - call get_mech_forcing_groups(forces, do_stress, do_ustar, do_shelf, & + call get_mech_forcing_groups(forces, do_stress, do_ustar, do_taumag, do_shelf, & do_press, do_iceberg) if (do_stress) then @@ -3750,19 +3823,24 @@ subroutine homogenize_mech_forcing(forces, G, US, Rho0, UpdateUstar) 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) 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 + tau_mag = sqrt(tx_mean**2 + ty_mean**2) + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%tau_mag(i,j) = tau_mag + endif ; enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + forces%ustar(i,j) = sqrt(tau_mag * Irho0) + endif ; enddo ; enddo ; endif 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) + if (associated(forces%ustar)) & + call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & + call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) endif else - if (do_ustar) then + if (associated(forces%ustar)) & call homogenize_field_t(forces%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(forces%tau_mag)) & call homogenize_field_t(forces%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) - endif endif if (do_shelf) then @@ -3793,17 +3871,21 @@ subroutine homogenize_forcing(fluxes, G, GV, US) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - logical :: do_ustar, do_water, do_heat, do_salt, do_press, do_shelf, & - do_iceberg, do_heat_added, do_buoy + logical :: do_ustar, do_taumag, do_water, do_heat, do_salt, do_press, do_shelf + logical :: do_iceberg, do_heat_added, do_buoy - call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_press, & + call get_forcing_groups(fluxes, do_water, do_heat, do_ustar, do_taumag, do_press, & do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) - if (do_ustar) then + if (associated(fluxes%ustar)) & call homogenize_field_t(fluxes%ustar, G, tmp_scale=US%Z_to_m*US%s_to_T) + if (associated(fluxes%ustar_gustless)) & call homogenize_field_t(fluxes%ustar_gustless, G, tmp_scale=US%Z_to_m*US%s_to_T) + + if (associated(fluxes%tau_mag)) & call homogenize_field_t(fluxes%tau_mag, G, tmp_scale=US%RLZ_T2_to_Pa) - endif + if (associated(fluxes%tau_mag_gustless)) & + call homogenize_field_t(fluxes%tau_mag_gustless, G, tmp_scale=US%RLZ_T2_to_Pa) if (do_water) then call homogenize_field_t(fluxes%evap, G, tmp_scale=US%RZ_T_to_kg_m2s) From 23df7138ee41f180851f6fe6d53eb365f283bd85 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Aug 2023 09:55:19 -0400 Subject: [PATCH 366/629] +*Non-Boussinesq revision of tidal_mixing This commit has a set of changes that set the tidal mixing in non-Boussinesq mode without reference to the Boussinesq reference density, by converting thicknesses to depths via a call to thickness_to_dz, by calculating an average near-bottom density explicitly via a call to find_rho_bottom, and by working with an appropriate mix of layer vertical extents and thicknesses. The contents of find_N2, calculate_tidal_mixing, calculate_CVMix_tidal and add_int_tide_diffusivity are all revised to work directly with vertical distances, set via thickness_to_dz, rather than rescaled thicknesses. This includes replacing the 3-d layer thickness argument to calculate_tidal_mixing, calculate_CVMix_tidal and add_int_tide_diffusivity with a 2-d slice of vertical distances across layers. For find_N2, the 2d-slice of vertical distances is a new argument. The revised code also uses the in situ bottom density when adding certain contributions to non-Boussinesq diffusivities. This change includes the addition of a new bottom density argument to find_N2 and calculate_tidal_mixing, along with a call to find_rho_bottom to set this density. There is also a new runtime parameter, DZ_BBL_AVG_MIN, stored in set_diffusivity_CS, that helps determine the vertical extent of that average. There are a total of 6 new (or renamed) internal variables, and 6 new subroutine arguments, with revisions to the rank of one internal variable. The units of 2 internal variables and 1 element of the tidal_mixing_cs type are altered. This commit eliminates 22 factors of GV%H_to_Z and two direct uses of GV%Rho0. All answers are bitwise identical in Boussinesq mode, but solutions will change in non-Boussinesq mode with this commit. There are several new arguments to a publicly visible subroutine, and a new runtime parameter. --- .../vertical/MOM_set_diffusivity.F90 | 79 +++++--- .../vertical/MOM_tidal_mixing.F90 | 190 +++++++++--------- 2 files changed, 147 insertions(+), 122 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 32553de3d1..2aac478086 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -22,6 +22,7 @@ module MOM_set_diffusivity use MOM_forcing_type, only : forcing, optics_type use MOM_full_convection, only : full_convection use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_internal_tides, only : int_tide_CS, get_lowmode_loss use MOM_intrinsic_functions, only : invcosh use MOM_io, only : slasher, MOM_read_data @@ -77,6 +78,8 @@ module MOM_set_diffusivity real :: BBL_effic !< efficiency with which the energy extracted !! by bottom drag drives BBL diffusion [nondim] real :: cdrag !< quadratic drag coefficient [nondim] + real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average + !! bottom boundary layer density [Z ~> m] real :: IMax_decay !< inverse of a maximum decay scale for !! bottom-drag driven turbulence [Z-1 ~> m-1]. real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] @@ -242,8 +245,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! local variables - real, dimension(SZI_(G)) :: & - N2_bot ! bottom squared buoyancy frequency [T-2 ~> s-2] + real :: N2_bot(SZI_(G)) ! Bottom squared buoyancy frequency [T-2 ~> s-2] + real :: rho_bot(SZI_(G)) ! In situ near-bottom density [T-2 ~> s-2] type(diffusivity_diags) :: dd ! structure with arrays of available diags @@ -254,6 +257,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i real, dimension(SZI_(G),SZK_(GV)) :: & N2_lay, & !< Squared buoyancy frequency associated with layers [T-2 ~> s-2] Kd_lay_2d, & !< The layer diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + dz, & !< Height change across layers [Z ~> m] maxTKE, & !< Energy required to entrain to h_max [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_to_Kd !< Conversion rate (~1.0 / (G_Earth + dRho_lay)) between !< TKE dissipated within a layer and Kd in that layer @@ -396,13 +400,13 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! be an appropriate place to add a depth-dependent parameterization or another explicit ! parameterization of Kd. - !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,& - !$OMP N2_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb)& + !$OMP parallel do default(shared) private(dRho_int,N2_lay,Kd_lay_2d,Kd_int_2d,Kv_bkgnd,N2_int,dz, & + !$OMP N2_bot,rho_bot,KT_extra,KS_extra,TKE_to_Kd,maxTKE,dissip,kb) & !$OMP if(.not. CS%use_CVMix_ddiff) do j=js,je ! Set up variables related to the stratification. - call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot) + call find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, N2_lay, N2_int, N2_bot, rho_bot) if (associated(dd%N2_3d)) then do K=1,nz+1 ; do i=is,ie ; dd%N2_3d(i,j,K) = N2_int(i,K) ; enddo ; enddo @@ -496,13 +500,17 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i enddo ; enddo endif + if (CS%ML_radiation .or. CS%use_tidal_mixing .or. associated(dd%Kd_work)) then + call thickness_to_dz(h, tv, dz, j, G, GV) + endif + ! Add the ML_Rad diffusivity. if (CS%ML_radiation) & call add_MLrad_diffusivity(h, fluxes, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) ! Add the Nikurashin and / or tidal bottom-driven mixing if (CS%use_tidal_mixing) & - call calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, & + call calculate_tidal_mixing(dz, j, N2_bot, rho_bot, N2_lay, N2_int, TKE_to_Kd, & maxTKE, G, GV, US, CS%tidal_mixing, & CS%Kd_max, visc%Kv_slow, Kd_lay_2d, Kd_int_2d) @@ -869,7 +877,7 @@ end subroutine find_TKE_to_Kd !> Calculate Brunt-Vaisala frequency, N^2. subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & - N2_lay, N2_int, N2_bot) + N2_lay, N2_int, N2_bot, Rho_bot) 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 @@ -894,24 +902,28 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & real, dimension(SZI_(G),SZK_(GV)), & intent(out) :: N2_lay !< The squared buoyancy frequency of the layers [T-2 ~> s-2]. real, dimension(SZI_(G)), intent(out) :: N2_bot !< The near-bottom squared buoyancy frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(out) :: Rho_bot !< Near-bottom density [R ~> kg m-3]. + ! Local variables real, dimension(SZI_(G),SZK_(GV)+1) :: & + pres, & ! pressure at each interface [R L2 T-2 ~> Pa] dRho_int_unfilt, & ! unfiltered density differences across interfaces [R ~> kg m-3] dRho_dT, & ! partial derivative of density wrt temp [R C-1 ~> kg m-3 degC-1] dRho_dS ! partial derivative of density wrt saln [R S-1 ~> kg m-3 ppt-1] - + real, dimension(SZI_(G),SZK_(GV)) :: & + dz ! Height change across layers [Z ~> m] real, dimension(SZI_(G)) :: & - pres, & ! pressure at each interface [R L2 T-2 ~> Pa] Temp_int, & ! temperature at each interface [C ~> degC] Salin_int, & ! salinity at each interface [S ~> ppt] drho_bot, & ! A density difference [R ~> kg m-3] h_amp, & ! The topographic roughness amplitude [Z ~> m]. - hb, & ! The thickness of the bottom layer [Z ~> m]. - z_from_bot ! The hieght above the bottom [Z ~> m]. + dz_BBL_avg, & ! The distance over which to average to find the near-bottom density [Z ~> m] + hb, & ! The thickness of the bottom layer [H ~> m or kg m-2] + z_from_bot ! The height above the bottom [Z ~> m] - real :: dz_int ! thickness associated with an interface [Z ~> m]. - real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density - ! times some unit conversion factors [Z T-2 R-1 ~> m4 s-2 kg-1]. + real :: dz_int ! Vertical distance associated with an interface [Z ~> m] + real :: G_Rho0 ! Gravitational acceleration, perhaps divided by Boussinesq reference density, + ! times some unit conversion factors [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. real :: H_neglect ! A negligibly small thickness [H ~> m or kg m-2] logical :: do_i(SZI_(G)), do_any @@ -919,7 +931,7 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & integer :: i, k, is, ie, nz is = G%isc ; ie = G%iec ; nz = GV%ke - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 + G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ H_neglect = GV%H_subroundoff ! Find the (limited) density jump across each interface. @@ -929,24 +941,24 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then - do i=is,ie ; pres(i) = fluxes%p_surf(i,j) ; enddo + do i=is,ie ; pres(i,1) = fluxes%p_surf(i,j) ; enddo else - do i=is,ie ; pres(i) = 0.0 ; enddo + do i=is,ie ; pres(i,1) = 0.0 ; enddo endif EOSdom(:) = EOS_domain(G%HI) do K=2,nz do i=is,ie - pres(i) = pres(i) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) + pres(i,K) = pres(i,K-1) + (GV%g_Earth*GV%H_to_RZ)*h(i,j,k-1) Temp_Int(i) = 0.5 * (T_f(i,j,k) + T_f(i,j,k-1)) Salin_Int(i) = 0.5 * (S_f(i,j,k) + S_f(i,j,k-1)) enddo - call calculate_density_derivs(Temp_int, Salin_int, pres, dRho_dT(:,K), dRho_dS(:,K), & + call calculate_density_derivs(Temp_int, Salin_int, pres(:,K), dRho_dT(:,K), dRho_dS(:,K), & tv%eqn_of_state, EOSdom) do i=is,ie dRho_int(i,K) = max(dRho_dT(i,K)*(T_f(i,j,k) - T_f(i,j,k-1)) + & dRho_dS(i,K)*(S_f(i,j,k) - S_f(i,j,k-1)), 0.0) dRho_int_unfilt(i,K) = max(dRho_dT(i,K)*(tv%T(i,j,k) - tv%T(i,j,k-1)) + & - dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) + dRho_dS(i,K)*(tv%S(i,j,k) - tv%S(i,j,k-1)), 0.0) enddo enddo else @@ -955,21 +967,24 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo ; enddo endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + ! Set the buoyancy frequencies. do k=1,nz ; do i=is,ie N2_lay(i,k) = G_Rho0 * 0.5*(dRho_int(i,K) + dRho_int(i,K+1)) / & - (GV%H_to_Z*(h(i,j,k) + H_neglect)) + (h(i,j,k) + H_neglect) enddo ; enddo do i=is,ie ; N2_int(i,1) = 0.0 ; N2_int(i,nz+1) = 0.0 ; enddo do K=2,nz ; do i=is,ie N2_int(i,K) = G_Rho0 * dRho_int(i,K) / & - (0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k) + H_neglect)) + (0.5*(h(i,j,k-1) + h(i,j,k) + H_neglect)) enddo ; enddo ! Find the bottom boundary layer stratification, and use this in the deepest layers. do i=is,ie hb(i) = 0.0 ; dRho_bot(i) = 0.0 ; h_amp(i) = 0.0 - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = 0.5*dz(i,nz) do_i(i) = (G%mask2dT(i,j) > 0.0) enddo if (CS%use_tidal_mixing) call tidal_mixing_h_amp(h_amp, G, j, CS%tidal_mixing) @@ -977,16 +992,16 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above - hb(i) = hb(i) + dz_int + hb(i) = hb(i) + 0.5*(h(i,j,k) + h(i,j,k-1)) drho_bot(i) = drho_bot(i) + dRho_int(i,K) if (z_from_bot(i) > h_amp(i)) then if (k>2) then ! Always include at least one full layer. - hb(i) = hb(i) + 0.5*GV%H_to_Z*(h(i,j,k-1) + h(i,j,k-2)) + hb(i) = hb(i) + 0.5*(h(i,j,k-1) + h(i,j,k-2)) drho_bot(i) = drho_bot(i) + dRho_int(i,K-1) endif do_i(i) = .false. @@ -1001,14 +1016,14 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & if (hb(i) > 0.0) then N2_bot(i) = (G_Rho0 * drho_bot(i)) / hb(i) else ; N2_bot(i) = 0.0 ; endif - z_from_bot(i) = 0.5*GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = 0.5*dz(i,nz) do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz,2,-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dz_int = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j,k-1)) + dz_int = 0.5*(dz(i,k) + dz(i,k-1)) z_from_bot(i) = z_from_bot(i) + dz_int ! middle of the layer above N2_int(i,K) = N2_bot(i) @@ -1030,6 +1045,10 @@ subroutine find_N2(h, tv, T_f, S_f, fluxes, j, G, GV, US, CS, dRho_int, & enddo ; enddo endif + ! Average over the larger of the envelope of the topography or a minimal distance. + do i=is,ie ; dz_BBL_avg(i) = max(h_amp(i), CS%dz_BBL_avg_min) ; enddo + call find_rho_bottom(h, dz, pres, dz_BBL_avg, tv, j, G, GV, US, Rho_bot) + end subroutine find_N2 !> This subroutine sets the additional diffusivities of temperature and @@ -2172,6 +2191,10 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ CS%id_Kd_BBL = register_diag_field('ocean_model', 'Kd_BBL', diag%axesTi, Time, & 'Bottom Boundary Layer Diffusivity', 'm2 s-1', conversion=GV%HZ_T_to_m2_s) + call get_param(param_file, mdl, "DZ_BBL_AVG_MIN", CS%dz_BBL_avg_min, & + "A minimal distance over which to average to determine the average bottom "//& + "boundary layer density.", units="m", default=0.0, scale=US%m_to_Z) + TKE_to_Kd_used = (CS%use_tidal_mixing .or. CS%ML_radiation .or. & (CS%bottomdraglaw .and. .not.CS%use_LOTW_BBL_diffusivity)) call get_param(param_file, mdl, "SIMPLE_TKE_TO_KD", CS%simple_TKE_to_Kd, & diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 89129ae480..95ffe19afb 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -157,8 +157,9 @@ module MOM_tidal_mixing ! Data containers real, allocatable :: TKE_Niku(:,:) !< Lee wave driven Turbulent Kinetic Energy input !! [R Z3 T-3 ~> W m-2] - real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided - !! by the bottom stratification [R Z3 T-2 ~> J m-2]. + real, allocatable :: TKE_itidal(:,:) !< The internal Turbulent Kinetic Energy input divided by + !! the bottom stratification and in non-Boussinesq mode by + !! the near-bottom density [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] real, allocatable :: Nb(:,:) !< The near bottom buoyancy frequency [T-1 ~> s-1]. real, allocatable :: mask_itidal(:,:) !< A mask of where internal tide energy is input [nondim] real, allocatable :: h2(:,:) !< Squared bottom depth variance [Z2 ~> m2]. @@ -553,8 +554,8 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di utide = CS%tideamp(i,j) ! Compute the fixed part of internal tidal forcing. - ! The units here are [R Z3 T-2 ~> J m-2 = kg s-2] here. - CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%Rho0 * & + ! The units here are [R Z4 H-1 T-2 ~> J m-2 or m3 s-2] here. (Note that J m-2 = kg s-2.) + CS%TKE_itidal(i,j) = 0.5 * CS%kappa_h2_factor * GV%H_to_RZ * & CS%kappa_itides * CS%h2(i,j) * utide*utide enddo ; enddo @@ -684,14 +685,14 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di 'Vertical flux of tidal turbulent dissipation (from propagating low modes)', & 'm3 s-3', conversion=(GV%H_to_m*US%Z_to_m**2*US%s_to_T**3)) - CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale',diag%axesT1,Time, & + CS%id_Polzin_decay_scale = register_diag_field('ocean_model','Polzin_decay_scale', diag%axesT1, Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme', & - 'm', conversion=US%Z_to_m) + units='m', conversion=US%Z_to_m) CS%id_Polzin_decay_scale_scaled = register_diag_field('ocean_model', & 'Polzin_decay_scale_scaled', diag%axesT1, Time, & 'Vertical decay scale for the tidal turbulent dissipation with Polzin scheme, '// & - 'scaled by N2_bot/N2_meanz', 'm', conversion=US%Z_to_m) + 'scaled by N2_bot/N2_meanz', units='m', conversion=US%Z_to_m) CS%id_N2_bot = register_diag_field('ocean_model','N2_b',diag%axesT1,Time, & 'Bottom Buoyancy frequency squared', 's-2', conversion=US%s_to_T**2) @@ -727,16 +728,16 @@ end function tidal_mixing_init !> Depending on whether or not CVMix is active, calls the associated subroutine to compute internal !! tidal dissipation and to add the effect of internal-tide-driven mixing to the layer or interface !! diffusivities. -subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & +subroutine calculate_tidal_mixing(dz, j, N2_bot, Rho_bot, N2_lay, N2_int, TKE_to_Kd, max_TKE, & G, GV, US, CS, Kd_max, Kv, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure 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] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy frequency at the @@ -765,9 +766,9 @@ subroutine calculate_tidal_mixing(h, j, N2_bot, N2_lay, N2_int, TKE_to_Kd, max_T if (CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation .or. CS%Lowmode_itidal_dissipation) then if (CS%use_CVMix_tidal) then - call calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) + call calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) else - call add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & + call add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & G, GV, US, CS, Kd_max, Kd_lay, Kd_int) endif endif @@ -776,13 +777,12 @@ end subroutine calculate_tidal_mixing !> Calls the CVMix routines to compute tidal dissipation and to add the effect of internal-tide-driven !! mixing to the interface diffusivities. -subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) +subroutine calculate_CVMix_tidal(dz, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< Grid structure. type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(in) :: N2_int !< The squared buoyancy !! frequency at the interfaces [T-2 ~> s-2]. @@ -832,7 +832,7 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int hcorr = 0.0 ! Compute cell center depth and cell bottom in meters (negative values in the ocean) do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness @@ -920,8 +920,8 @@ subroutine calculate_CVMix_tidal(h, j, N2_int, G, GV, US, CS, Kv, Kd_lay, Kd_int hcorr = 0.0 ! Compute heights at cell center and interfaces, and rescale layer thicknesses do k=1,GV%ke - h_m(k) = h(i,j,k)*GV%H_to_m ! Rescale thicknesses to m for use by CVmix. - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + h_m(k) = dz(i,k)*US%Z_to_m ! Rescale thicknesses to m for use by CVmix. + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness @@ -1025,16 +1025,16 @@ end subroutine calculate_CVMix_tidal !! low modes (rays) of the internal tide ("lowmode"), and (3) local dissipation of internal lee waves. !! Will eventually need to add diffusivity due to other wave-breaking processes (e.g. Bottom friction, !! Froude-number-depending breaking, PSI, etc.). -subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & +subroutine add_int_tide_diffusivity(dz, j, N2_bot, Rho_bot, N2_lay, TKE_to_Kd, max_TKE, & G, GV, US, CS, Kd_max, Kd_lay, Kd_int) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure 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] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< The vertical distance across layers [Z ~> m] integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G)), intent(in) :: N2_bot !< The near-bottom squared buoyancy frequency !! frequency [T-2 ~> s-2]. + real, dimension(SZI_(G)), intent(in) :: Rho_bot !< The near-bottom in situ density [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: N2_lay !< The squared buoyancy frequency of the !! layers [T-2 ~> s-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: TKE_to_Kd !< The conversion rate between the TKE @@ -1060,16 +1060,15 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! local real, dimension(SZI_(G)) :: & - htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - htot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m]. + dztot, & ! Vertical distance between the top and bottom of the ocean [Z ~> m] + dztot_WKB, & ! WKB scaled distance from top to bottom [Z ~> m] TKE_itidal_bot, & ! internal tide TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_Niku_bot, & ! lee-wave TKE at ocean bottom [H Z2 T-3 ~> m3 s-3 or W m-2] TKE_lowmode_bot, & ! internal tide TKE at ocean bottom lost from all remote low modes [H Z2 T-3 ~> m3 s-3 or W m-2] Inv_int, & ! inverse of TKE decay for int tide over the depth of the ocean [nondim] Inv_int_lee, & ! inverse of TKE decay for lee waves over the depth of the ocean [nondim] Inv_int_low, & ! inverse of TKE decay for low modes over the depth of the ocean [nondim] - z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m]. + z0_Polzin, & ! TKE decay scale in Polzin formulation [Z ~> m] z0_Polzin_scaled, & ! TKE decay scale in Polzin formulation [Z ~> m]. ! multiplied by N2_bot/N2_meanz to be coherent with the WKB scaled z ! z*=int(N2/N2_bot) * N2_bot/N2_meanz = int(N2/N2_meanz) @@ -1082,19 +1081,19 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & TKE_frac_top_lee, & ! fraction of bottom TKE that should appear at top of a layer [nondim] TKE_frac_top_lowmode, & ! fraction of bottom TKE that should appear at top of a layer [nondim] - z_from_bot, & ! distance from bottom [Z ~> m]. - z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m]. + z_from_bot, & ! distance from bottom [Z ~> m] + z_from_bot_WKB ! WKB scaled distance from bottom [Z ~> m] real :: Kd_add ! Diffusivity to add in a layer [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: TKE_itide_lay ! internal tide TKE imparted to a layer (from barotropic) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_Niku_lay ! lee-wave TKE imparted to a layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_lowmode_lay ! internal tide TKE imparted to a layer (from low mode) [H Z2 T-3 ~> m3 s-3 or W m-2] real :: frac_used ! fraction of TKE that can be used in a layer [nondim] - real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1]. - real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1]. - real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3]. + real :: Izeta ! inverse of TKE decay scale [Z-1 ~> m-1] + real :: Izeta_lee ! inverse of TKE decay scale for lee waves [Z-1 ~> m-1] + real :: z0Ps_num ! The numerator of the unlimited z0_Polzin_scaled [Z T-3 ~> m s-3] real :: z0Ps_denom ! The denominator of the unlimited z0_Polzin_scaled [T-3 ~> s-3]. - real :: z0_psl ! temporary variable [Z ~> m]. + real :: z0_psl ! temporary variable [Z ~> m] real :: TKE_lowmode_tot ! TKE from all low modes [R Z3 T-3 ~> W m-2] logical :: use_Polzin, use_Simmons @@ -1104,9 +1103,9 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (.not.(CS%Int_tide_dissipation .or. CS%Lee_wave_dissipation)) return - do i=is,ie ; htot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ;enddo + do i=is,ie ; dztot(i) = 0.0 ; Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) + dztot(i) = dztot(i) + dz(i,k) enddo ; enddo use_Polzin = ((CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09)) .or. & @@ -1126,21 +1125,21 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if (allocated(CS%dd%N2_bot)) & CS%dd%N2_bot(i,j) = N2_bot(i) if ( CS%Int_tide_dissipation ) then - if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) endif endif if ( CS%Lee_wave_dissipation ) then - if (Izeta_lee*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*htot(i))) + if (Izeta_lee*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_lee(i) = 1.0 / (1.0 - exp(-Izeta_lee*dztot(i))) endif endif if ( CS%Lowmode_itidal_dissipation) then - if (Izeta*htot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. - Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*htot(i))) + if (Izeta*dztot(i) > 1.0e-14) then ! L'Hospital's version of Adcroft's reciprocal rule. + Inv_int_low(i) = 1.0 / (1.0 - exp(-Izeta*dztot(i))) endif endif - z_from_bot(i) = GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = dz(i,nz) enddo endif ! Simmons @@ -1149,109 +1148,109 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! WKB scaling of the vertical coordinate do i=is,ie ; N2_meanz(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie - N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * GV%H_to_Z * h(i,j,k) + N2_meanz(i) = N2_meanz(i) + N2_lay(i,k) * dz(i,k) enddo ; enddo do i=is,ie - N2_meanz(i) = N2_meanz(i) / (htot(i) + GV%dz_subroundoff) + N2_meanz(i) = N2_meanz(i) / (dztot(i) + GV%dz_subroundoff) if (allocated(CS%dd%N2_meanz)) & CS%dd%N2_meanz(i,j) = N2_meanz(i) enddo ! WKB scaled z*(z=H) z* at the surface using the modified Polzin WKB scaling - do i=is,ie ; htot_WKB(i) = htot(i) ; enddo -! do i=is,ie ; htot_WKB(i) = 0.0 ; enddo + do i=is,ie ; dztot_WKB(i) = dztot(i) ; enddo +! do i=is,ie ; dztot_WKB(i) = 0.0 ; enddo ! do k=1,nz ; do i=is,ie -! htot_WKB(i) = htot_WKB(i) + GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) +! dztot_WKB(i) = dztot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) ! enddo ; enddo - ! htot_WKB(i) = htot(i) ! Nearly equivalent and simpler + ! dztot_WKB(i) = dztot(i) ! Nearly equivalent and simpler do i=is,ie CS%Nb(i,j) = sqrt(N2_bot(i)) if (CS%tidal_answer_date < 20190101) then if ((CS%tideamp(i,j) > 0.0) .and. & (CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 > 1.0e-14*US%T_to_s**3) ) then - z0_polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & + z0_Polzin(i) = CS%Polzin_decay_scale_factor * CS%Nu_Polzin * & CS%Nbotref_Polzin**2 * CS%tideamp(i,j) / & ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j)**3 ) - if (z0_polzin(i) < CS%Polzin_min_decay_scale) & - z0_polzin(i) = CS%Polzin_min_decay_scale + if (z0_Polzin(i) < CS%Polzin_min_decay_scale) & + z0_Polzin(i) = CS%Polzin_min_decay_scale if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z0_polzin_scaled(i) = z0_polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) + z0_Polzin_scaled(i) = z0_Polzin(i)*CS%Nb(i,j)**2 / N2_meanz(i) else - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif - if (z0_polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * htot(i)) ) & - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + if (z0_Polzin_scaled(i) > (CS%Polzin_decay_scale_max_factor * dztot(i)) ) & + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif else z0Ps_num = (CS%Polzin_decay_scale_factor * CS%Nu_Polzin * CS%Nbotref_Polzin**2) * CS%tideamp(i,j) z0Ps_denom = ( CS%kappa_itides**2 * CS%h2(i,j) * CS%Nb(i,j) * N2_meanz(i) ) if ((CS%tideamp(i,j) > 0.0) .and. & - (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * htot(i))) then - z0_polzin_scaled(i) = z0Ps_num / z0Ps_denom + (z0Ps_num < z0Ps_denom * CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin_scaled(i) = z0Ps_num / z0Ps_denom - if (abs(N2_meanz(i) * z0_polzin_scaled(i)) < & - CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * htot(i))) then - z0_polzin(i) = z0_polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) + if (abs(N2_meanz(i) * z0_Polzin_scaled(i)) < & + CS%Nb(i,j)**2 * (CS%Polzin_decay_scale_max_factor * dztot(i))) then + z0_Polzin(i) = z0_Polzin_scaled(i) * (N2_meanz(i) / CS%Nb(i,j)**2) else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif else - z0_polzin(i) = CS%Polzin_decay_scale_max_factor * htot(i) - z0_polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * htot(i) + z0_Polzin(i) = CS%Polzin_decay_scale_max_factor * dztot(i) + z0_Polzin_scaled(i) = CS%Polzin_decay_scale_max_factor * dztot(i) endif endif if (allocated(CS%dd%Polzin_decay_scale)) & - CS%dd%Polzin_decay_scale(i,j) = z0_polzin(i) + CS%dd%Polzin_decay_scale(i,j) = z0_Polzin(i) if (allocated(CS%dd%Polzin_decay_scale_scaled)) & - CS%dd%Polzin_decay_scale_scaled(i,j) = z0_polzin_scaled(i) + CS%dd%Polzin_decay_scale_scaled(i,j) = z0_Polzin_scaled(i) if (allocated(CS%dd%N2_bot)) & CS%dd%N2_bot(i,j) = CS%Nb(i,j)*CS%Nb(i,j) if (CS%tidal_answer_date < 20190101) then ! These expressions use dimensional constants to avoid NaN values. if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (htot_WKB(i) > 1.0e-14*US%m_to_Z) & - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (dztot_WKB(i) > 1.0e-14*US%m_to_Z) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif else ! These expressions give values of Inv_int < 10^14 using a variant of Adcroft's reciprocal rule. Inv_int(i) = 0.0 ; Inv_int_lee(i) = 0.0 ; Inv_int_low(i) = 0.0 if ( CS%Int_tide_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif if ( CS%lee_wave_dissipation .and. (CS%lee_wave_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int_lee(i) = ( z0_polzin_scaled(i)*CS%Decay_scale_factor_lee / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_lee(i) = ( z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee / dztot_WKB(i) ) + 1.0 endif if ( CS%Lowmode_itidal_dissipation .and. (CS%int_tide_profile == POLZIN_09) ) then - if (z0_polzin_scaled(i) < 1.0e14 * htot_WKB(i)) & - Inv_int_low(i) = ( z0_polzin_scaled(i) / htot_WKB(i) ) + 1.0 + if (z0_Polzin_scaled(i) < 1.0e14 * dztot_WKB(i)) & + Inv_int_low(i) = ( z0_Polzin_scaled(i) / dztot_WKB(i) ) + 1.0 endif endif - z_from_bot(i) = GV%H_to_Z*h(i,j,nz) + z_from_bot(i) = dz(i,nz) ! Use the new formulation for WKB scaling. N2 is referenced to its vertical mean. if (CS%tidal_answer_date < 20190101) then if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) / N2_meanz(i) + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif else - if (GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * htot_WKB(i))) then - z_from_bot_WKB(i) = GV%H_to_Z*h(i,j,nz) * N2_lay(i,nz) / N2_meanz(i) + if (dz(i,nz) * N2_lay(i,nz) < N2_meanz(i) * (1.0e14 * dztot_WKB(i))) then + z_from_bot_WKB(i) = dz(i,nz) * N2_lay(i,nz) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif endif enddo @@ -1261,7 +1260,12 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & ! Both Polzin and Simmons: do i=is,ie ! Dissipation of locally trapped internal tide (non-propagating high modes) - TKE_itidal_bot(i) = min(CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + TKE_itidal_bot(i) = min(GV%Z_to_H*CS%TKE_itidal(i,j)*CS%Nb(i,j), CS%TKE_itide_max) + else + TKE_itidal_bot(i) = min(GV%RZ_to_H*Rho_bot(i) * (CS%TKE_itidal(i,j)*CS%Nb(i,j)), & + CS%TKE_itide_max) + endif if (allocated(CS%dd%TKE_itidal_used)) & CS%dd%TKE_itidal_used(i,j) = TKE_itidal_bot(i) TKE_itidal_bot(i) = (GV%RZ_to_H * CS%Mu_itides * CS%Gamma_itides) * TKE_itidal_bot(i) @@ -1292,7 +1296,7 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if ( use_Simmons ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + dz(i,k) ! Fraction of bottom flux predicted to reach top of this layer TKE_frac_top(i) = Inv_int(i) * exp(-Izeta * z_from_bot(i)) @@ -1376,26 +1380,24 @@ subroutine add_int_tide_diffusivity(h, j, N2_bot, N2_lay, TKE_to_Kd, max_TKE, & if ( use_Polzin ) then do k=nz-1,2,-1 ; do i=is,ie if (max_TKE(i,k) <= 0.0) cycle - z_from_bot(i) = z_from_bot(i) + GV%H_to_Z*h(i,j,k) + z_from_bot(i) = z_from_bot(i) + dz(i,k) if (CS%tidal_answer_date < 20190101) then if (N2_meanz(i) > 1.0e-14*US%T_to_s**2 ) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) & - + GV%H_to_Z * h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) else ; z_from_bot_WKB(i) = 0 ; endif else - if (GV%H_to_Z*h(i,j,k) * N2_lay(i,k) < (1.0e14 * htot_WKB(i)) * N2_meanz(i)) then - z_from_bot_WKB(i) = z_from_bot_WKB(i) + & - GV%H_to_Z*h(i,j,k) * N2_lay(i,k) / N2_meanz(i) + if (dz(i,k) * N2_lay(i,k) < (1.0e14 * dztot_WKB(i)) * N2_meanz(i)) then + z_from_bot_WKB(i) = z_from_bot_WKB(i) + dz(i,k) * N2_lay(i,k) / N2_meanz(i) endif endif ! Fraction of bottom flux predicted to reach top of this layer - TKE_frac_top(i) = ( Inv_int(i) * z0_polzin_scaled(i) ) / & - ( z0_polzin_scaled(i) + z_from_bot_WKB(i) ) - z0_psl = z0_polzin_scaled(i)*CS%Decay_scale_factor_lee + TKE_frac_top(i) = ( Inv_int(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) + z0_psl = z0_Polzin_scaled(i)*CS%Decay_scale_factor_lee TKE_frac_top_lee(i) = (Inv_int_lee(i) * z0_psl) / (z0_psl + z_from_bot_WKB(i)) - TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_polzin_scaled(i) ) / & - ( z0_polzin_scaled(i) + z_from_bot_WKB(i) ) + TKE_frac_top_lowmode(i) = ( Inv_int_low(i) * z0_Polzin_scaled(i) ) / & + ( z0_Polzin_scaled(i) + z_from_bot_WKB(i) ) ! Actual influx at bottom of layer minus predicted outflux at top of layer to give ! predicted power expended From 9e756afbe1b96051dcf2f06441a93e848e49f9d8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Aug 2023 06:36:07 -0400 Subject: [PATCH 367/629] *Fix allocate_forcing_by_ref tau_mag_gustless bug Added the name to the do_taumag argument in a call to allocate_forcing_type in allocate_forcing_by_ref to account for the fact that there are unused wave-related optional arguments in this interface. When this was omitted in the current code, the wrong arrays are being allocated during rotation tests with resultant segmentation faults in those tests. This commit corrects a bug that was recently added with MOM6 dev/gfdl PR #445. --- src/core/MOM_forcing_type.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index c86b9b869f..f4e9960cd8 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3331,7 +3331,7 @@ subroutine allocate_forcing_by_ref(fluxes_ref, G, fluxes) do_shelf, do_iceberg, do_salt, do_heat_added, do_buoy) call allocate_forcing_type(G, fluxes, do_water, do_heat, do_ustar, & - do_press, do_shelf, do_iceberg, do_salt, do_taumag) + do_press, do_shelf, do_iceberg, do_salt, tau_mag=do_taumag) ! The following fluxes would typically be allocated by the driver call myAlloc(fluxes%sw_vis_dir, G%isd, G%ied, G%jsd, G%jed, & From 2642c1cb6e202e42a857323f76fa70a2b03fbb90 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 14 Jun 2023 02:29:38 -0400 Subject: [PATCH 368/629] Fix rescaling in regularize_surface debugging Add missing dimensional rescaling factors for hard-coded temperature and salinity offsets in debugging conservation checks in regularize_surface. All answers are bitwise identical, but without this change some configurations can erroneously give fatal errors for some rescaling settings when DEBUG=True. --- src/parameterizations/vertical/MOM_regularize_layers.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index 2f2c66eca7..d4034d699c 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -576,14 +576,14 @@ subroutine regularize_surface(h, tv, dt, ea, eb, G, GV, US, CS) trim(mesg), .true.) fatal_error = .true. endif - if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*(Th_tot1(i)+10.0*h_tot1(i))) then + if (abs(Th_tot1(i) - Th_tot2(i)) > 1e-12*abs(Th_tot1(i) + 10.0*US%degC_to_C*h_tot1(i))) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & Th_tot1(i), Th_tot2(i), (Th_tot1(i) - Th_tot2(i)), (Th_tot1(i) - Th_tot3(i)) call MOM_error(WARNING, "regularize_surface: Heat non-conservation."//& trim(mesg), .true.) fatal_error = .true. endif - if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*(Sh_tot1(i)+10.0*h_tot1(i))) then + if (abs(Sh_tot1(i) - Sh_tot2(i)) > 1e-12*abs(Sh_tot1(i) + 10.0*US%ppt_to_S*h_tot1(i))) then write(mesg,'(ES11.4," became ",ES11.4," diff ",ES11.4," int diff ",ES11.4)') & Sh_tot1(i), Sh_tot2(i), (Sh_tot1(i) - Sh_tot2(i)), (Sh_tot1(i) - Sh_tot3(i)) call MOM_error(WARNING, "regularize_surface: Salinity non-conservation."//& From f847b3cfd4c6732d65b399d030ea0805df107b98 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Aug 2023 14:46:44 -0400 Subject: [PATCH 369/629] *Non-Boussinesq revision of 3 MOM_CVMix modules This commit revises MOM_CVMix_conv, MOM_CVMix_ddiff and MOM_CVMix_shear to work in an appropriate mixture of thickness and vertical extent variables to enable their use in non-Boussinesq mode, using thickness_to_dz to convert between the two, while retaining the previous answers in Boussinesq mode. This includes the use of a layer thicknesses rather than a vertical distance in the denominator of the calculation of the buoyancy frequency and to the units of the internal rescaled gravity variable in CVMix_conv. This commit eliminates any direct or indirect dependency on the Boussinesq reference density in these 3 modules when in non-Boussinesq mode. This set of changes includes changing the units of 7 internal variables and the addition, renaming, or change in the dimensions of 4 internal variables. One element in the CVMix_ddiff_cs type is rescaled to use thickness units. These changes lead to the removal of 4 factors of GV%H_to_Z in these 3 modules. Answers will change in non-Boussinesq mode when USE_CVMix_CONVECTION, USE_CVMIX_DDIFF, USE_PP81 or USE_LMD94 are true, but they are bitwise identical in all Boussinesq test cases. --- .../vertical/MOM_CVMix_conv.F90 | 36 +++++++++++-------- .../vertical/MOM_CVMix_ddiff.F90 | 18 +++++----- .../vertical/MOM_CVMix_shear.F90 | 20 ++++++++--- 3 files changed, 46 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_conv.F90 b/src/parameterizations/vertical/MOM_CVMix_conv.F90 index c95b967681..19744cb6c5 100644 --- a/src/parameterizations/vertical/MOM_CVMix_conv.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_conv.F90 @@ -11,6 +11,7 @@ module MOM_CVMix_conv use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -163,23 +164,27 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) real, dimension(SZK_(GV)+1) :: N2 !< Squared buoyancy frequency [s-2] real, dimension(SZK_(GV)+1) :: kv_col !< Viscosities at interfaces in the column [m2 s-1] real, dimension(SZK_(GV)+1) :: kd_col !< Diffusivities at interfaces in the column [m2 s-1] - real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [m] + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [Z ~> m] + real, dimension(SZK_(GV)) :: cellHeight !< Height of cell centers [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: & kd_conv, & !< Diffusivity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] kv_conv, & !< Viscosity added by convection for diagnostics [Z2 T-1 ~> m2 s-1] N2_3d !< Squared buoyancy frequency for diagnostics [T-2 ~> s-2] integer :: kOBL !< level of ocean boundary layer extent - real :: g_o_rho0 ! Gravitational acceleration divided by density times unit conversion factors - ! [Z s-2 R-1 ~> m4 s-2 kg-1] + real :: g_o_rho0 ! Gravitational acceleration, perhaps divided by density, times unit conversion factors + ! [H s-2 R-1 ~> m4 s-2 kg-1 or m s-2] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: rhok, rhokm1 ! In situ densities of the layers above and below at the interface pressure [R ~> kg m-3] - real :: hbl_KPP ! The depth of the ocean boundary as used by KPP [m] - real :: dz ! A thickness [Z ~> m] + real :: dh_int ! The distance between layer centers [H ~> m or kg m-2] real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] integer :: i, j, k - g_o_rho0 = US%L_to_Z**2*US%s_to_T**2 * GV%g_Earth / GV%Rho0 + if (GV%Boussinesq) then + g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%Z_to_H) * GV%g_Earth / GV%Rho0 + else + g_o_rho0 = (US%L_to_Z**2*US%s_to_T**2*GV%RZ_to_H) * GV%g_Earth + endif ! initialize dummy variables rho_lwr(:) = 0.0 ; rho_1d(:) = 0.0 @@ -192,6 +197,10 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) if (CS%id_kd_conv > 0) Kd_conv(:,:,:) = 0.0 do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ! skip calling at land points @@ -206,8 +215,8 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) call calculate_density(tv%t(i,j,k), tv%s(i,j,k), pRef, rhok, tv%eqn_of_state) call calculate_density(tv%t(i,j,k-1), tv%s(i,j,k-1), pRef, rhokm1, tv%eqn_of_state) - dz = ((0.5*(h(i,j,k-1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) - N2(K) = g_o_rho0 * (rhok - rhokm1) / dz ! Can be negative + dh_int = 0.5*(h(i,j,k-1) + h(i,j,k)) + GV%H_subroundoff + N2(K) = g_o_rho0 * (rhok - rhokm1) / dh_int ! Can be negative enddo @@ -215,17 +224,16 @@ subroutine calculate_CVMix_conv(h, tv, G, GV, US, CS, hbl, Kd, Kv, Kd_aux) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in the units of heights + dh = dz(i,k) ! Nominal thickness to use for increment, in the units of heights dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max(dh, CS%min_thickness) ! Limited increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! gets index of the level and interface above hbl - hbl_KPP = US%Z_to_m*hbl(i,j) ! Convert to the units used by CVMix. - kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl_KPP) + kOBL = CVMix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) kv_col(:) = 0.0 ; kd_col(:) = 0.0 call CVMix_coeffs_conv(Mdiff_out=kv_col(:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index c2bf357559..af17e0287f 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -35,7 +35,7 @@ module MOM_CVMix_ddiff real :: kappa_ddiff_param1 !< exterior coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param2 !< middle coefficient in diffusive convection regime [nondim] real :: kappa_ddiff_param3 !< interior coefficient in diffusive convection regime [nondim] - real :: min_thickness !< Minimum thickness allowed [Z ~> m] + real :: min_thickness !< Minimum thickness allowed [H ~> m or kg-2] character(len=4) :: diff_conv_type !< type of diffusive convection to use. Options are Marmorino & !! Caldwell 1976 ("MC76"; default) and Kelley 1988, 1990 ("K90") logical :: debug !< If true, turn on debugging @@ -83,7 +83,7 @@ logical function CVMix_ddiff_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) call get_param(param_file, mdl, 'MIN_THICKNESS', CS%min_thickness, & - units="m", scale=US%m_to_Z, default=0.001, do_not_log=.True.) + units="m", scale=GV%m_to_H, default=0.001, do_not_log=.True.) call openParameterBlock(param_file,'CVMIX_DDIFF') @@ -162,7 +162,7 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) ! Local variables real, dimension(SZK_(GV)) :: & - cellHeight, & !< Height of cell centers [m] + cellHeight, & !< Height of cell centers relative to the sea surface [H ~> m or kg m-2] dRho_dT, & !< partial derivatives of density with temperature [R C-1 ~> kg m-3 degC-1] dRho_dS, & !< partial derivatives of density with salinity [R S-1 ~> kg m-3 ppt-1] pres_int, & !< pressure at each interface [R L2 T-2 ~> Pa] @@ -176,8 +176,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) Kd1_T, & !< Diapycanal diffusivity of temperature [m2 s-1]. Kd1_S !< Diapycanal diffusivity of salinity [m2 s-1]. - real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces [m] - real :: dh, hcorr ! Limited thicknesses and a cumulative correction [Z ~> m] + real, dimension(SZK_(GV)+1) :: iFaceHeight !< Height of interfaces relative to the sea surface [H ~> m or kg m-2] + real :: dh, hcorr ! Limited thicknesses and a cumulative correction [H ~> m or kg m-2] integer :: i, k ! initialize dummy variables @@ -237,16 +237,16 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) hcorr = 0.0 ! compute heights at cell center and interfaces do k=1,GV%ke - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment, in height units + dh = h(i,j,k) ! Nominal thickness to use for increment, in height units dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness - cellHeight(k) = iFaceHeight(k) - 0.5 * US%Z_to_m*dh - iFaceHeight(k+1) = iFaceHeight(k) - US%Z_to_m*dh + cellHeight(k) = iFaceHeight(k) - 0.5 * dh + iFaceHeight(k+1) = iFaceHeight(k) - dh enddo ! gets index of the level and interface above hbl - !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, GV%Z_to_H*hbl(i,j)) Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & diff --git a/src/parameterizations/vertical/MOM_CVMix_shear.F90 b/src/parameterizations/vertical/MOM_CVMix_shear.F90 index 2e23787555..829318b606 100644 --- a/src/parameterizations/vertical/MOM_CVMix_shear.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_shear.F90 @@ -10,6 +10,7 @@ module MOM_CVMix_shear use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -76,11 +77,12 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) real :: GoRho ! Gravitational acceleration divided by density [Z T-2 R-1 ~> m4 s-2 kg-1] real :: pref ! Interface pressures [R L2 T-2 ~> Pa] real :: DU, DV ! Velocity differences [L T-1 ~> m s-1] - real :: DZ ! Grid spacing around an interface [Z ~> m] + real :: dz_int ! Grid spacing around an interface [Z ~> m] real :: N2 ! Buoyancy frequency at an interface [T-2 ~> s-2] real :: S2 ! Shear squared at an interface [T-2 ~> s-2] real :: dummy ! A dummy variable [nondim] real :: dRho ! Buoyancy differences [Z T-2 ~> m s-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension(2*(GV%ke)) :: pres_1d ! A column of interface pressures [R L2 T-2 ~> Pa] real, dimension(2*(GV%ke)) :: temp_1d ! A column of temperatures [C ~> degC] real, dimension(2*(GV%ke)) :: salt_1d ! A column of salinities [S ~> ppt] @@ -96,6 +98,10 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) epsln = 1.e-10 * GV%m_to_H do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ! skip calling for land points @@ -132,10 +138,14 @@ subroutine calculate_CVMix_shear(u_H, v_H, h, tv, kd, kv, G, GV, US, CS ) kk = 2*(k-1) DU = u_h(i,j,k) - u_h(i,j,km1) DV = v_h(i,j,k) - v_h(i,j,km1) - DRHO = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) - DZ = (0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z - N2 = DRHO / DZ - S2 = US%L_to_Z**2*(DU*DU+DV*DV)/(DZ*DZ) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + dRho = GoRho * (rho_1D(kk+1) - rho_1D(kk+2)) + else + dRho = (US%L_to_Z**2 * GV%g_Earth) * (rho_1D(kk+1) - rho_1D(kk+2)) / (0.5*(rho_1D(kk+1) + rho_1D(kk+2))) + endif + dz_int = 0.5*(dz(i,km1) + dz(i,k)) + GV%dZ_subroundoff + N2 = DRHO / dz_int + S2 = US%L_to_Z**2*(DU*DU + DV*DV) / (dz_int*dz_int) Ri_Grad(k) = max(0., N2) / max(S2, 1.e-10*US%T_to_s**2) ! fill 3d arrays, if user asks for diagnostics From 22a370c56fa8d14c4cd6bd418865175b679aa35c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Aug 2023 04:46:09 -0400 Subject: [PATCH 370/629] *Non-Boussinesq revision of MOM_CVMix_KPP This commit revises MOM_CVMix_KPP to work in an appropriate mixture of thickness and vertical extent variables to enable their use in non-Boussinesq mode, using thickness_to_dz to convert between the two, while retaining the previous answers in Boussinesq mode. This includes the use of a layer thicknesses rather than a vertical distance in the denominator of the calculation of the buoyancy frequency and the replacement of the layer thickness argument (h) to KPP_smooth_BLD with a layer vertical extent (dz). When in non-Boussinesq mode, the buoyancy difference between layers is normalized by the average of the density of the two layers rather than the Boussinesq reference density. This commit eliminates any direct or indirect dependency on the Boussinesq reference density in CVMix_KPP when in non-Boussinesq mode. This set of changes includes changing the units of 1 internal variables and the addition of 2 new internal variables, and a change to the name and units of one argument to KPP_smooth_BLD. These changes lead to the removal of 5 factors of GV%H_to_Z. Answers will change in non-Boussinesq mode when USE_KPP is true, but they are bitwise identical in all Boussinesq test cases. --- .../vertical/MOM_CVMix_KPP.F90 | 54 ++++++++++++------- 1 file changed, 35 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index d24c3e2954..303e41fc3d 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -625,6 +625,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & ! Local variables integer :: i, j, k ! Loop indices + real, dimension(SZI_(G),SZK_(GV)) :: dz ! Height change across layers [Z ~> m] real, dimension( GV%ke ) :: cellHeight ! Cell center heights referenced to surface [Z ~> m] (negative in ocean) real, dimension( GV%ke+1 ) :: iFaceHeight ! Interface heights referenced to surface [Z ~> m] (negative in ocean) real, dimension( GV%ke ) :: z_cell ! Cell center heights referenced to surface [m] (negative in ocean) @@ -663,13 +664,17 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & buoy_scale = US%L_to_m**2*US%s_to_T**3 !$OMP parallel do default(none) firstprivate(nonLocalTrans) & - !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, cellHeight, & + !$OMP private(surfFricVel, iFaceHeight, hcorr, dh, dz, cellHeight, & !$OMP surfBuoyFlux, Kdiffusivity, Kviscosity, LangEnhK, sigma, & !$OMP sigmaRatio, z_inter, z_cell) & - !$OMP shared(G, GV, CS, US, uStar, h, buoy_scale, buoyFlux, Kt, & + !$OMP shared(G, GV, CS, US, tv, uStar, h, buoy_scale, buoyFlux, Kt, & !$OMP Ks, Kv, nonLocalTransHeat, nonLocalTransScalar, Waves, lamult) ! loop over horizontal points on processor do j = G%jsc, G%jec + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then ! things independent of position within the column @@ -680,7 +685,7 @@ subroutine KPP_calculate(CS, G, GV, US, h, tv, uStar, buoyFlux, Kt, Ks, Kv, & do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment + dh = dz(i,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -930,6 +935,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Variables for passing to CVMix routines, often in MKS units real, dimension( GV%ke ) :: Ws_1d ! Profile of vertical velocity scale for scalars in MKS units [m s-1] real, dimension( GV%ke ) :: deltaRho ! delta Rho in numerator of Bulk Ri number [R ~> kg m-3] + real, dimension( GV%ke ) :: deltaBuoy ! Change in Buoyancy based on deltaRho [m s-2] real, dimension( GV%ke ) :: deltaU2 ! square of delta U (shear) in denominator of Bulk Ri [m2 s-2] real, dimension( GV%ke ) :: surfBuoyFlux2 ! Surface buoyancy flux in MKS units [m2 s-3] real, dimension( GV%ke ) :: BulkRi_1d ! Bulk Richardson number for each layer [nondim] @@ -954,8 +960,8 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl real, dimension( GV%ke+1 ) :: N2_1d ! Brunt-Vaisala frequency squared, at interfaces [T-2 ~> s-2] real :: zBottomMinusOffset ! Height of bottom plus a little bit [Z ~> m] real :: GoRho ! Gravitational acceleration in MKS units divided by density [m s-2 R-1 ~> m4 kg-1 s-2] - real :: GoRho_Z_L2 ! Gravitational acceleration divided by density times aspect ratio - ! rescaling [Z T-2 R-1 ~> m4 kg-1 s-2] + real :: GoRho_Z_L2 ! Gravitational acceleration, perhaps divided by density, times aspect ratio + ! rescaling [H T-2 R-1 ~> m4 kg-1 s-2 or m s-2] real :: pRef ! The interface pressure [R L2 T-2 ~> Pa] real :: Uk, Vk ! Layer velocities relative to their averages in the surface layer [L T-1 ~> m s-1] real :: SLdepth_0d ! Surface layer depth = surf_layer_ext*OBLdepth [Z ~> m] @@ -994,8 +1000,12 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl call cpu_clock_begin(id_clock_KPP_compute_BLD) ! some constants - GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth / GV%Rho0 - GoRho = US%Z_to_m*US%s_to_T**2 * GoRho_Z_L2 + GoRho = US%Z_to_m*US%s_to_T**2 * (US%L_to_Z**2 * GV%g_Earth / GV%Rho0) + if (GV%Boussinesq) then + GoRho_Z_L2 = US%L_to_Z**2 * GV%Z_to_H * GV%g_Earth / GV%Rho0 + else + GoRho_Z_L2 = US%L_to_Z**2 * GV%g_Earth * GV%RZ_to_H + endif buoy_scale = US%L_to_m**2*US%s_to_T**3 ! Find the vertical distances across layers. @@ -1008,7 +1018,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !$OMP surfHvS, hTot, delH, surftemp, surfsalt, surfu, surfv, & !$OMP surfUs, surfVs, Uk, Vk, deltaU2, km1, kk, pres_1D, N_col, & !$OMP Temp_1D, salt_1D, surfBuoyFlux2, MLD_guess, LA, rho_1D, & - !$OMP deltarho, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & + !$OMP deltarho, deltaBuoy, N2_1d, ws_1d, LangEnhVT2,KPP_OBL_depth, z_cell, & !$OMP z_inter, OBL_depth, BulkRi_1d, zBottomMinusOffset) & !$OMP shared(G, GV, CS, US, uStar, h, dz, buoy_scale, buoyFlux, & !$OMP Temp, Salt, waves, tv, GoRho, GoRho_Z_L2, u, v, lamult) @@ -1037,7 +1047,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment + dh = dz(i,j,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness @@ -1066,7 +1076,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl do ktmp = 1,ksfc ! SLdepth_0d can be between cell interfaces - delH = min( max(0.0, SLdepth_0d - hTot), h(i,j,ktmp)*GV%H_to_Z ) + delH = min( max(0.0, SLdepth_0d - hTot), dz(i,j,ktmp) ) ! surface layer thickness hTot = hTot + delH @@ -1147,8 +1157,14 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl km1 = max(1, k-1) kk = 3*(k-1) deltaRho(k) = rho_1D(kk+2) - rho_1D(kk+1) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + deltaBuoy(k) = GoRho*(rho_1D(kk+2) - rho_1D(kk+1)) + else + deltaBuoy(k) = (US%Z_to_m*US%s_to_T**2) * (US%L_to_Z**2 * GV%g_Earth) * & + ( (rho_1D(kk+2) - rho_1D(kk+1)) / (0.5 * (rho_1D(kk+2) + rho_1D(kk+1))) ) + endif N2_1d(k) = (GoRho_Z_L2 * (rho_1D(kk+2) - rho_1D(kk+3)) ) / & - ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)*GV%H_to_Z) + ((0.5*(h(i,j,km1) + h(i,j,k))+GV%H_subroundoff)) CS%N(i,j,k) = sqrt( max( N2_1d(k), 0.) ) enddo N2_1d(GV%ke+1 ) = 0.0 @@ -1202,7 +1218,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl ! Calculate Bulk Richardson number from eq (21) of LMD94 BulkRi_1d = CVmix_kpp_compute_bulk_Richardson( & zt_cntr=z_cell, & ! Depth of cell center [m] - delta_buoy_cntr=GoRho*deltaRho, & ! Bulk buoyancy difference, Br-B(z) [m s-2] + delta_buoy_cntr=deltaBuoy, & ! Bulk buoyancy difference, Br-B(z) [m s-2] delta_Vsqr_cntr=deltaU2, & ! Square of resolved velocity difference [m2 s-2] ws_cntr=Ws_1d, & ! Turbulent velocity scale profile [m s-1] N_iface=N_col, & ! Buoyancy frequency [s-1] @@ -1256,7 +1272,7 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl !BGR consider if LTEnhancement is wanted for diagnostics if (CS%id_Ws > 0) then call CVMix_kpp_compute_turbulent_scales( & - -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate + -cellHeight(:)/CS%OBLdepth(i,j), & ! (in) Normalized boundary layer coordinate [nondim] US%Z_to_m*CS%OBLdepth(i,j), & ! (in) OBL depth [m] surfBuoyFlux, & ! (in) Buoyancy flux at surface [m2 s-3] surfFricVel, & ! (in) Turbulent friction velocity at surface [m s-1] @@ -1296,19 +1312,19 @@ subroutine KPP_compute_BLD(CS, G, GV, US, h, Temp, Salt, u, v, tv, uStar, buoyFl if (CS%id_Vt2 > 0) call post_data(CS%id_Vt2, CS%Vt2, CS%diag) ! BLD smoothing: - if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, h) + if (CS%n_smooth > 0) call KPP_smooth_BLD(CS, G, GV, US, dz) end subroutine KPP_compute_BLD !> Apply a 1-1-4-1-1 Laplacian filter one time on BLD to reduce any horizontal two-grid-point noise -subroutine KPP_smooth_BLD(CS, G, GV, US, h) +subroutine KPP_smooth_BLD(CS, G, GV, US, dz) ! Arguments type(KPP_CS), pointer :: CS !< Control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer/level thicknesses [H ~> m or kg m-2] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: dz !< Layer thicknesses [Z ~> m] ! local real, dimension(SZI_(G),SZJ_(G)) :: OBLdepth_prev ! OBLdepth before s.th smoothing iteration [Z ~> m] @@ -1333,7 +1349,7 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) OBLdepth_prev = CS%OBLdepth ! apply smoothing on OBL depth - !$OMP parallel do default(none) shared(G, GV, US, CS, h, OBLdepth_prev) & + !$OMP parallel do default(none) shared(G, GV, US, CS, dz, OBLdepth_prev) & !$OMP private(wc, ww, we, wn, ws, dh, hcorr, cellHeight, iFaceHeight) do j = G%jsc, G%jec do i = G%isc, G%iec ; if (G%mask2dT(i,j) > 0.0) then @@ -1343,7 +1359,7 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, h) do k=1,GV%ke ! cell center and cell bottom in meters (negative values in the ocean) - dh = h(i,j,k) * GV%H_to_Z ! Nominal thickness to use for increment + dh = dz(i,j,k) ! Nominal thickness to use for increment dh = dh + hcorr ! Take away the accumulated error (could temporarily make dh<0) hcorr = min( dh - CS%min_thickness, 0. ) ! If inflating then hcorr<0 dh = max( dh, CS%min_thickness ) ! Limit increment dh>=min_thickness From c80390451296812d4903baceb526633bcde68592 Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Mon, 14 Aug 2023 17:03:54 -0400 Subject: [PATCH 371/629] Bugfix for MOM_tracer_advect for ad_x/y and ad2d_x/y diagnostic fields - Tracer advection diagnostics in symmetric mode had errors at processor boundaries because they were computed over only the tracer indices. The tracer advection diagnostics have been updated to compute over a range of indices identical to the fluxes, which allows it to also work on the u/v point indices in both non-symmetric and symmetric mode. - These code updates only impact the tracer diagnostics, and in no cases were the model solutions impacted by the bug outside of these select diagnostic fields. - The corrected diagnostics reproduce the old non-symmetric mode results in both symmetric and non-symmetric mode. - Some logic has been updated and comments were added to improve the code, but none of these changes impact the model solution. --- src/tracer/MOM_tracer_advect.F90 | 45 ++++++++++++++++++-------------- 1 file changed, 25 insertions(+), 20 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index 5abca6e578..dde110f959 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -655,7 +655,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ! diagnostics - if (associated(Tr(m)%ad_x)) then ; do i=is,ie ; if (do_i(i,j)) then + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j)) then Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt endif ; enddo ; endif @@ -682,13 +682,13 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & ! compute ad2d_x diagnostic outside above j-loop so as to make the summation ordered when OMP is active. !$OMP ordered - do j=js,je ; if (domore_u_initial(j,k)) then - do m=1,ntr - if (associated(Tr(m)%ad2d_x)) then ; do i=is,ie ; if (do_i(i,j)) then + do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then + do j=js,je ; if (domore_u_initial(j,k)) then + do I=is-1,ie ; if (do_i(i,j)) then Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt - endif ; enddo ; endif - enddo - endif ; enddo ! End of j-loop. + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. !$OMP end ordered end subroutine advect_x @@ -756,6 +756,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical :: usePLMslope integer :: i, j, j2, m, n, j_up, stencil type(OBC_segment_type), pointer :: segment=>NULL() + logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v usePLMslope = .not. (usePPM .and. useHuynh) ! stencil for calculating slope values @@ -778,6 +779,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & ! this would require an additional loop, etc. do_j_tr(:) = .false. do J=js-1,je ; if (domore_v(J,k)) then ; do j2=1-stencil,stencil ; do_j_tr(j+j2) = .true. ; enddo ; endif ; enddo + domore_v_initial(:) = domore_v(:,k) ! Calculate the j-direction profiles (slopes) of each tracer that ! is being advected. @@ -1034,11 +1036,6 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & (flux_y(i,m,J) - flux_y(i,m,J-1))) * Ihnew(i) endif ; enddo - ! diagnostics - if (associated(Tr(m)%ad_y)) then ; do i=is,ie ; if (do_i(i,j)) then - Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt - endif ; enddo ; endif - ! diagnose convergence of flux_y and add to convergence of flux_x. ! division by areaT to get into W/m2 for heat and kg/(s*m2) for salt. if (associated(Tr(m)%advection_xy)) then @@ -1058,16 +1055,24 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & enddo ; enddo endif ; enddo - ! compute ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. - + ! compute ad_y and ad2d_y diagnostic outside above j-loop so as to make the summation ordered when OMP is active. !$OMP ordered - do j=js,je ; if (do_j_tr(j)) then - do m=1,ntr - if (associated(Tr(m)%ad2d_y)) then ; do i=is,ie ; if (do_i(i,j)) then + do m=1,ntr ; if (associated(Tr(m)%ad_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + ! (The logical test could be "do_i(i,j) .or. do_i(i+1,j)" to be clearer, but not needed) + do i=is,ie ; if (do_i(i,j)) then + Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. + + do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then + do J=js-1,je ; if (domore_v_initial(J)) then + do i=is,ie ; if (do_i(i,j)) then Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt - endif ; enddo ; endif - enddo - endif ; enddo ! End of j-loop. + endif ; enddo + endif ; enddo + endif ; enddo ! End of m-loop. !$OMP end ordered end subroutine advect_y From a8088819a223a939f6a63150d3804c82147b7aa5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 16 Jun 2023 10:34:44 -0400 Subject: [PATCH 372/629] *Non-Boussinesq interface_filter Refactored interface_filter when in non-Boussinesq mode to avoid any dependencies on the Boussinesq reference density, and to translate the volume streamfunction into the mass streamfunction using an appropriately defined in-situ density averaged to the interfaces at velocity points. This form is similar to the one that is used in thickness_diffuse. No public interfaces are changed, and all answers are bitwise identical in Boussinesq or semiBoussinesq mode, but they will change in non-Boussinesq mode cases that use the interface filter. --- .../lateral/MOM_interface_filter.F90 | 48 +++++++++++++++---- 1 file changed, 38 insertions(+), 10 deletions(-) diff --git a/src/parameterizations/lateral/MOM_interface_filter.F90 b/src/parameterizations/lateral/MOM_interface_filter.F90 index dd082f1558..07b698e294 100644 --- a/src/parameterizations/lateral/MOM_interface_filter.F90 +++ b/src/parameterizations/lateral/MOM_interface_filter.F90 @@ -148,7 +148,7 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) endif ! Calculate uhD, vhD from h, e, Lsm2_u, Lsm2_v - call filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size=filter_itts-1) + call filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-1) do itt=2,filter_itts @@ -156,14 +156,23 @@ subroutine interface_filter(h, uhtr, vhtr, tv, dt, G, GV, US, CDp, CS) !$OMP parallel do default(shared) do j=js-hs,je+hs do i=is-hs,ie+hs ; de_smooth(i,j,nz+1) = 0.0 ; enddo - do k=nz,1,-1 ; do i=is-hs,ie+hs - de_smooth(i,j,k) = de_smooth(i,j,k+1) + GV%H_to_Z * G%IareaT(i,j) * & - ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) - enddo ; enddo + + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + (GV%H_to_RZ * tv%SpV_avg(i,j,k)) * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + else + do k=nz,1,-1 ; do i=is-hs,ie+hs + de_smooth(i,j,K) = de_smooth(i,j,K+1) + GV%H_to_Z * G%IareaT(i,j) * & + ((uhD(I,j,k) - uhD(I-1,j,k)) + (vhD(i,J,k) - vhD(i,J-1,k))) + enddo ; enddo + endif enddo ! Calculate uhD, vhD from h, de_smooth, Lsm2_u, Lsm2_v - call filter_interface(h, de_smooth, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size=filter_itts-itt) + call filter_interface(h, de_smooth, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size=filter_itts-itt) enddo ! Offer diagnostic fields for averaging. This must occur before updating the layer thicknesses @@ -227,7 +236,7 @@ end subroutine interface_filter !> Calculates parameterized layer transports for use in the continuity equation. !! Fluxes are limited to give positive definite thicknesses. !! Called by interface_filter(). -subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size) +subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, tv, G, GV, US, halo_size) 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 @@ -241,6 +250,7 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size !! [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vhD !< Meridional mass fluxes !! [H L2 ~> m3 or kg] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamics structure integer, optional, intent(in) :: halo_size !< The size of the halo to work on, !! 0 by default. @@ -256,14 +266,16 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size real :: Sfn_est ! A preliminary estimate (before limiting) of the overturning ! streamfunction [H L2 ~> m3 or kg]. real :: Sfn ! The overturning streamfunction [H L2 ~> m3 or kg]. + real :: Rho_avg ! The in situ density averaged to an interface [R ~> kg m-3] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: hn_2 ! Half of h_neglect [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz, hs hs = 0 ; if (present(halo_size)) hs = halo_size is = G%isc-hs ; ie = G%iec+hs ; js = G%jsc-hs ; je = G%jec+hs ; nz = GV%ke - h_neglect = GV%H_subroundoff + h_neglect = GV%H_subroundoff ; hn_2 = 0.5*h_neglect ! Find the maximum and minimum permitted streamfunction. !$OMP parallel do default(shared) @@ -286,7 +298,15 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size do I=is-1,ie Slope = ((e(i,j,K)-e(i+1,j,K))*G%IdxCu(I,j)) * G%OBCmaskCu(I,j) - Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%Z_to_H * Slope) + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i+1,j,k) + h(i+1,j,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i+1,j,k)+hn_2)*tv%SpV_avg(i+1,j,k) + (h(i+1,j,k-1)+hn_2)*tv%SpV_avg(i+1,j,k-1)) ) + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_u(I,j)*G%dy_Cu(I,j)) * (GV%Z_to_H * Slope) + endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. @@ -318,7 +338,15 @@ subroutine filter_interface(h, e, Lsm2_u, Lsm2_v, uhD, vhD, G, GV, US, halo_size do i=is,ie Slope = ((e(i,j,K)-e(i,j+1,K))*G%IdyCv(i,J)) * G%OBCmaskCv(i,J) - Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%Z_to_H * Slope) + if (allocated(tv%SpV_avg)) then + ! This is the fully non-Boussinesq version. + Rho_avg = ( ((h(i,j,k) + h(i,j,k-1)) + (h(i,j+1,k) + h(i,j+1,k-1))) + 4.0*hn_2 ) / & + ( ((h(i,j,k)+hn_2) * tv%SpV_avg(i,j,k) + (h(i,j,k-1)+hn_2) * tv%SpV_avg(i,j,k-1)) + & + ((h(i,j+1,k)+hn_2)*tv%SpV_avg(i,j+1,k) + (h(i,j+1,k-1)+hn_2)*tv%SpV_avg(i,j+1,k-1)) ) + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%RZ_to_H * Slope) * Rho_avg + else + Sfn_est = (Lsm2_v(i,J)*G%dx_Cv(i,J)) * (GV%Z_to_H * Slope) + endif ! Make sure that there is enough mass above to allow the streamfunction ! to satisfy the boundary condition of 0 at the surface. From d223f25396211a9237c2e67b4ce61c06059e9948 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 8 Jun 2023 10:10:36 -0400 Subject: [PATCH 373/629] *Revise calc_isoneutral_slopes when non-Boussinesq Revise calc_isoneutral_slopes to eliminate any dependence on the Boussinesq reference density when in non-Boussinesq mode. This includes the addition of two new arrays to hold the rescaled product of the gravitational acceleration and the specific volume interpolated to the interfaces at velocity points. The answers change in non-Boussinesq mode when one of several parameterizations that use the isoneutral slopes are in use, but are bitwise identical in Boussinesq or semi-Boussinesq mode. --- src/core/MOM_isopycnal_slopes.F90 | 60 ++++++++++++++++++++++++++----- 1 file changed, 52 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 29c547148d..5aa78cb87a 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -4,6 +4,7 @@ module MOM_isopycnal_slopes ! This file is part of MOM6. See LICENSE.md for the license. use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, FATAL use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -81,10 +82,14 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan real, dimension(SZIB_(G)) :: & T_u, & ! Temperature on the interface at the u-point [C ~> degC]. S_u, & ! Salinity on the interface at the u-point [S ~> ppt]. + GxSpV_u, & ! Gravitiational acceleration times the specific volume at an interface + ! at the u-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] pres_u ! Pressure on the interface at the u-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & T_v, & ! Temperature on the interface at the v-point [C ~> degC]. S_v, & ! Salinity on the interface at the v-point [S ~> ppt]. + GxSpV_v, & ! Gravitiational acceleration times the specific volume at an interface + ! at the v-points [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] pres_v ! Pressure on the interface at the v-point [R L2 T-2 ~> Pa]. real, dimension(SZI_(G)) :: & T_h, & ! Temperature on the interface at the h-point [C ~> degC]. @@ -202,6 +207,17 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif endif + if ((use_EOS .and. allocated(tv%SpV_avg) .and. (tv%valid_SpV_halo < 1)) .and. & + (present_N2_u .or. present(dzSxN) .or. present_N2_v .or. present(dzSyN))) then + if (tv%valid_SpV_halo < 0) then + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with invalid values of SpV_avg.") + else + call MOM_error(FATAL, "calc_isoneutral_slopes called in fully non-Boussinesq mode "//& + "with insufficiently large SpV_avg halos of width 0 but 1 is needed.") + endif + endif + ! Find the maximum and minimum permitted streamfunction. if (associated(tv%p_surf)) then !$OMP parallel do default(shared) @@ -227,7 +243,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP local_open_u_BC,dzu,OBC,use_stanley) & !$OMP private(drdiA,drdiB,drdkL,drdkR,pres_u,T_u,S_u, & !$OMP drho_dT_u,drho_dS_u,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_u, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdx,mag_grad2,slope,l_seg) do j=js,je ; do K=nz,2,-1 @@ -245,6 +261,18 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo call calculate_density_derivs(T_u, S_u, pres_u, drho_dT_u, drho_dS_u, & tv%eqn_of_state, EOSdom_u) + if (present_N2_u .or. (present(dzSxN))) then + if (allocated(tv%SpV_avg)) then + do I=is-1,ie + GxSpV_u(I) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i+1,j,k-1))) + enddo + else + do I=is-1,ie + GxSpV_u(I) = G_Rho0 + enddo + endif + endif endif if (use_stanley) then @@ -308,7 +336,9 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) ! This is the gradient of density along geopotentials. - if (present_N2_u) N2_u(I,j,K) = G_Rho0 * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + if (present_N2_u) then + N2_u(I,j,K) = GxSpV_u(I) * drdz * G%mask2dCu(I,j) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + endif if (use_EOS) then drdx = ((wtA * drdiA + wtB * drdiB) / (wtA + wtB) - & @@ -343,8 +373,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif slope_x(I,j,K) = slope if (present(dzSxN)) & - dzSxN(I,j,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + dzSxN(I,j,K) = sqrt( GxSpV_u(I) * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N * abs(slope) * G%mask2dCu(I,j) ! x-direction contribution to S^2 enddo ! I @@ -357,7 +387,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan !$OMP dzv,local_open_v_BC,OBC,use_stanley) & !$OMP private(drdjA,drdjB,drdkL,drdkR,pres_v,T_v,S_v, & !$OMP drho_dT_v,drho_dS_v,hg2A,hg2B,hg2L,hg2R,haA, & - !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h, & + !$OMP drho_dT_dT_h,scrap,pres_h,T_h,S_h,GxSpV_v, & !$OMP drho_dT_dT_hr,pres_hr,T_hr,S_hr, & !$OMP haB,haL,haR,dzaL,dzaR,wtA,wtB,wtL,wtR,drdz, & !$OMP drdy,mag_grad2,slope,l_seg) @@ -375,7 +405,21 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan enddo call calculate_density_derivs(T_v, S_v, pres_v, drho_dT_v, drho_dS_v, & tv%eqn_of_state, EOSdom_v) + + if ((present_N2_v) .or. (present(dzSyN))) then + if (allocated(tv%SpV_avg)) then + do i=is,ie + GxSpV_v(i) = GV%g_Earth * 0.25* ((tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + & + (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j+1,k-1))) + enddo + else + do i=is,ie + GxSpV_v(i) = G_Rho0 + enddo + endif + endif endif + if (use_stanley) then do i=is,ie pres_h(i) = pres(i,j,K) @@ -443,7 +487,7 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! drdz = ((hg2L/haL) * drdkL/dzaL + (hg2R/haR) * drdkR/dzaR) / & ! ((hg2L/haL) + (hg2R/haR)) ! This is the gradient of density along geopotentials. - if (present_N2_v) N2_v(i,J,K) = G_Rho0 * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] + if (present_N2_v) N2_v(i,J,K) = GxSpV_v(i) * drdz * G%mask2dCv(i,J) ! Square of buoyancy freq. [L2 Z-2 T-2 ~> s-2] if (use_EOS) then drdy = ((wtA * drdjA + wtB * drdjB) / (wtA + wtB) - & @@ -480,8 +524,8 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan endif slope_y(i,J,K) = slope if (present(dzSyN)) & - dzSyN(i,J,K) = sqrt( G_Rho0 * max(0., wtL * ( dzaL * drdkL ) & - + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N + dzSyN(i,J,K) = sqrt( GxSpV_v(i) * max(0., wtL * ( dzaL * drdkL ) & + + wtR * ( dzaR * drdkR )) / (wtL + wtR) ) & ! dz * N * abs(slope) * G%mask2dCv(i,J) ! x-direction contribution to S^2 enddo ! i From d16f343e42615d09761dc50aaca268b60a7ca504 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 31 May 2023 05:45:32 -0400 Subject: [PATCH 374/629] Refactor rescaling of CFC_cap flux diagnostics Rescaled CFC flux diagnostics in the CFC cap via a conversion factor in their register diag_field calls, rather than by doing array syntax math in their post_data calls. All answers are bitwise identical. --- src/tracer/MOM_CFC_cap.F90 | 19 ++++++------------- 1 file changed, 6 insertions(+), 13 deletions(-) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index ef8e712b7a..becf1f8995 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -190,7 +190,7 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type !! specifies whether, where, and what !! open boundary conditions are used. - type(CFC_cap_CS), pointer :: CS !< The control structure returned by a + type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. ! local variables @@ -215,7 +215,7 @@ subroutine initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS) ! CFC12 cmor conventions: http://clipc-services.ceda.ac.uk/dreq/u/3ab8e10027d7014f18f9391890369235.html write(m2char, "(I1)") m CS%CFC_data(m)%id_cmor = register_diag_field('ocean_model', 'cfc1'//m2char, diag%axesTL, day, & - 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3') + 'Mole Concentration of CFC1'//m2char//' in Sea Water', 'mol m-3', conversion=GV%Rho0*US%R_to_kg_m3) enddo @@ -308,7 +308,6 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: flux_scale integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -318,14 +317,12 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Compute KPP nonlocal term if necessary if (present(KPP_CSp)) then if (associated(KPP_CSp) .and. present(nonLocalTrans)) then - flux_scale = GV%Z_to_H / GV%rho0 - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc11_flux(:,:), dt, CS%diag, & CS%CFC_data(1)%tr_ptr, CS%CFC_data(1)%conc(:,:,:), & - flux_scale=flux_scale) + flux_scale=GV%RZ_to_H) call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%cfc12_flux(:,:), dt, CS%diag, & CS%CFC_data(2)%tr_ptr, CS%CFC_data(2)%conc(:,:,:), & - flux_scale=flux_scale) + flux_scale=GV%RZ_to_H) endif endif @@ -351,12 +348,8 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C endif ! If needed, write out any desired diagnostics from tracer sources & sinks here. - if (CS%CFC_data(1)%id_cmor > 0) call post_data(CS%CFC_data(1)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(1)%conc, & - CS%diag) - if (CS%CFC_data(2)%id_cmor > 0) call post_data(CS%CFC_data(2)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(2)%conc, & - CS%diag) + if (CS%CFC_data(1)%id_cmor > 0) call post_data(CS%CFC_data(1)%id_cmor, CS%CFC_data(1)%conc, CS%diag) + if (CS%CFC_data(2)%id_cmor > 0) call post_data(CS%CFC_data(2)%id_cmor, CS%CFC_data(2)%conc, CS%diag) end subroutine CFC_cap_column_physics From 546728a23d0fd0c56126ba18e5c3e748a41f6bb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 4 Aug 2023 05:54:12 -0400 Subject: [PATCH 375/629] *+Non-Boussinesq revision of set_viscosity This commit revises set_viscous_BBL and set_viscous_ML to work in fully non-Boussinesq mode, eliminating all dependencies on the Boussinesq reference density when in non-Boussinesq mode. These changes include using the specific volume interpolated to velocity points for the conversion between thickness and height changes when tv%SpV_avg is allocated, including in the calculation of the rescaled ustar in the top and bottom boundary layers and in the Rayleigh drag calculation. In set_viscous_ML, the derivatives of specific volume are used to determine the reduced gravity across interfaces when in non-Boussinesq mode. Both set_viscous_BBL and set_viscous_ML now work extensively in height units rather than thickness units in various places where it is more appropriate to do so when in non-Boussinesq mode, and both use calls to thickness_to_dz to convert between thicknesses and vertical distances. In some places this leads to extra calculations using separate arrays that are rescaled duplicates of each other in Boussinesq mode, which will probably slow the model down a little. There is one rescaling bug due to a hard-coded unrescaled dimensional constant that was fixed. It occurs when setting a tiny floor in a thickness in one inverse calculation. However, this appears to be so small that it does not change any answers in the MOM6-examples test suite, and could only do so if ANGSTROM is set to be many orders of magnitude less than the typical value of 1e-10 m, so it was decided that no runtime bug-flag is needed in this case. A call to find_star is now used to specify the friction velocity used in set_viscous_ML. When in non-Boussinesq mode, this has the effect of using forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 to determine the friction velocity. In set_viscous_BBL the layer specific volumes are used in non-Boussinesq mode to find the average velocities used in the linearization of the nonlinear bottom drag, with similar changes in set_viscous_ML for the drag under ice-shelves. When in non-Boussinesq mode, the units of Kd_shear, Kv_shear and Kv_shear_Bu in the restart files are scaled to their natural MKS units of [Pa s] or [kg m-1 s-1] rather than [m2 s-1] to avoid round-off level changes across restarts, with the units in the files documenting these changes. These altered units do not apply to Boussinesq mode restart files. In set_visc_init, the rescaling factor used to set CS%Hbbl was changed from GV%Z_to_H to (US%Z_to_m*GV%m_to_H) so that it does not depend directly on RHO_0. These changes are extensive but localized to this file, with one new element of the opaque set_visc_CS type and 6 elements with altered units, 37 new or renamed internal variables, and 29 existing internal variables that have revised units. In particular one extensively used thickness curvature variable that had been called just "a" was renamed "crv" to more accurately reflect its purpose and to make it easier to find when rescaling it, with similar changes to two other closely related variables. These changes include the elimination of 29 rescaling factors between thickness and height units, as were two spots that inappropriately (and unnecessarily, as it turns out) used GV%Rho0 even when in non-Boussinesq mode. There are also 4 new debugging checksum output calls. In Boussinesq or semiBoussinesq mode, no public interfaces are changed and all answers are bitwise identical, but in non-Boussinesq mode answers will change and there are changes to the units of 3 variables in restart files. --- .../vertical/MOM_set_viscosity.F90 | 731 ++++++++++++------ 1 file changed, 474 insertions(+), 257 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 9ab300560b..9a99bc6b26 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -6,30 +6,30 @@ module MOM_set_visc use MOM_ALE, only : ALE_CS, ALE_remap_velocities, ALE_remap_interface_vals, ALE_remap_vertex_vals use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cvmix_conv, only : cvmix_conv_is_used +use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_cvmix_shear, only : cvmix_shear_is_used use MOM_debugging, only : uvchksum, hchksum use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, CORNER +use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_specific_vol_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing, mech_forcing +use MOM_forcing_type, only : forcing, mech_forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : slasher, MOM_read_data use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex -use MOM_cvmix_shear, only : cvmix_shear_is_used -use MOM_cvmix_conv, only : cvmix_conv_is_used -use MOM_CVMix_ddiff, only : CVMix_ddiff_is_used +use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E +use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_restart, only : register_restart_field_as_obsolete use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_open_boundary, only : ocean_OBC_type, OBC_NONE, OBC_DIRECTION_E -use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S -use MOM_open_boundary, only : OBC_segment_type implicit none ; private @@ -48,6 +48,8 @@ module MOM_set_visc logical :: initialized = .false. !< True if this control structure has been initialized. real :: Hbbl !< The static bottom boundary layer thickness [H ~> m or kg m-2]. !! Runtime parameter `HBBL`. + real :: dz_bbl !< The static bottom boundary layer thickness in height units [Z ~> m]. + !! Runtime parameter `HBBL`. real :: cdrag !< The quadratic drag coefficient [nondim]. !! Runtime parameter `CDRAG`. real :: c_Smag !< The Laplacian Smagorinsky coefficient for @@ -55,14 +57,14 @@ module MOM_set_visc real :: drag_bg_vel !< An assumed unresolved background velocity for !! calculating the bottom drag [L T-1 ~> m s-1]. !! Runtime parameter `DRAG_BG_VEL`. - real :: BBL_thick_min !< The minimum bottom boundary layer thickness [H ~> m or kg m-2]. + real :: BBL_thick_min !< The minimum bottom boundary layer thickness [Z ~> m]. !! This might be Kv / (cdrag * drag_bg_vel) to give !! Kv as the minimum near-bottom viscosity. real :: Htbl_shelf !< A nominal thickness of the surface boundary layer for use !! in calculating the near-surface velocity [H ~> m or kg m-2]. - real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [H ~> m or kg m-2]. - real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [Z2 T-1 ~> m2 s-1]. - real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [Z2 T-1 ~> m2 s-1]. + real :: Htbl_shelf_min !< The minimum surface boundary layer thickness [Z ~> m]. + real :: KV_BBL_min !< The minimum viscosity in the bottom boundary layer [H Z T-1 ~> m2 s-1 or Pa s] + real :: KV_TBL_min !< The minimum viscosity in the top boundary layer [H Z T-1 ~> m2 s-1 or Pa s] logical :: bottomdraglaw !< If true, the bottom stress is calculated with a !! drag law c_drag*|u|*u. The velocity magnitude !! may be an assumed value or it may be based on the @@ -80,7 +82,7 @@ module MOM_set_visc !! according to what fraction of the bottom they overlie. real :: Chan_drag_max_vol !< The maximum bottom boundary layer volume within which the !! channel drag is applied, normalized by the full cell area, - !! or a negative value to apply no maximum [H ~> m or kg m-2]. + !! or a negative value to apply no maximum [Z ~> m]. logical :: correct_BBL_bounds !< If true, uses the correct bounds on the BBL thickness and !! viscosity so that the bottom layer feels the intended drag. logical :: RiNo_mix !< If true, use Richardson number dependent mixing. @@ -90,8 +92,8 @@ module MOM_set_visc !! thickness of the viscous mixed layer [nondim] real :: omega !< The Earth's rotation rate [T-1 ~> s-1]. real :: ustar_min !< A minimum value of ustar to avoid numerical - !! problems [Z T-1 ~> m s-1]. If the value is small enough, - !! this should not affect the solution. + !! problems [H T-1 ~> m s-1 or kg m-2 s-1]. If the value is + !! small enough, this should not affect the solution. real :: TKE_decay !< The ratio of the natural Ekman depth to the TKE !! decay scale [nondim] real :: omega_frac !< When setting the decay scale for turbulence, use this @@ -145,7 +147,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Local variables real, dimension(SZIB_(G)) :: & - ustar, & ! The bottom friction velocity [Z T-1 ~> m s-1]. + ustar, & ! The bottom friction velocity [H T-1 ~> m s-1 or kg m-2 s-1]. T_EOS, & ! The temperature used to calculate the partial derivatives ! of density with T and S [C ~> degC]. S_EOS, & ! The salinity used to calculate the partial derivatives @@ -156,9 +158,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! layer with salinity [R S-1 ~> kg m-3 ppt-1]. press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. umag_avg, & ! The average magnitude of velocities in the bottom boundary layer [L T-1 ~> m s-1]. - h_bbl_drag ! The thickness over which to apply drag as a body force [H ~> m or kg m-2]. + h_bbl_drag, & ! The thickness over which to apply drag as a body force [H ~> m or kg m-2]. + dz_bbl_drag ! The vertical height over which to apply drag as a body force [Z ~> m]. real :: htot ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot ! Distance from the bottom up to some point [Z ~> m]. real :: htot_vel ! Sum of the layer thicknesses up to some point [H ~> m or kg m-2]. + real :: dztot_vel ! Distance from the bottom up to some point [Z ~> m]. real :: Rhtot ! Running sum of thicknesses times the layer potential ! densities [H R ~> kg m-2 or kg2 m-5]. @@ -176,31 +181,49 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! direction [H ~> m or kg m-2]. h_vel, & ! Arithmetic mean of the layer thicknesses adjacent to a ! velocity point [H ~> m or kg m-2]. + dz_at_vel, & ! Vertical extent of a layer, using an upwind-biased + ! second order accurate estimate based on the previous velocity + ! direction [Z ~> m]. + dz_vel, & ! Arithmetic mean of the difference in across the layers adjacent + ! to a velocity point [Z ~> m]. T_vel, & ! Arithmetic mean of the layer temperatures adjacent to a ! velocity point [C ~> degC]. S_vel, & ! Arithmetic mean of the layer salinities adjacent to a ! velocity point [S ~> ppt]. + SpV_vel, & ! Arithmetic mean of the layer averaged specific volumes adjacent to a + ! velocity point [R-1 ~> kg m-3]. Rml_vel ! Arithmetic mean of the layer coordinate densities adjacent ! to a velocity point [R ~> kg m-3]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: h_vel_pos ! The arithmetic mean thickness at a velocity point ! plus H_neglect to avoid 0 values [H ~> m or kg m-2]. real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. - real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion - ! factor from lateral lengths to vertical depths [Z L-1 ~> nondim]. real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion factor + ! from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_L_to_H ! The drag coeffient times conversion factors from lateral + ! distance to thickness units [H L-1 ~> nondim or kg m-3] + real :: cdrag_RL_to_H ! The drag coeffient times conversion factors from density times lateral + ! distance to thickness units [H L-1 R-1 ~> m3 kg-1 or nondim] + real :: cdrag_conv ! The drag coeffient times a combination of static conversion factors and in + ! situ density or Boussinesq reference density [H L-1 ~> nondim or kg m-3] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining ! the layer [H R ~> kg m-2 or kg2 m-5]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] real :: Dh ! The increment in layer thickness from ! the present layer [H ~> m or kg m-2]. - real :: bbl_thick ! The thickness of the bottom boundary layer [H ~> m or kg m-2]. - real :: bbl_thick_Z ! The thickness of the bottom boundary layer [Z ~> m]. - real :: kv_bbl ! The bottom boundary layer viscosity [Z2 T-1 ~> m2 s-1]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. + real :: bbl_thick ! The thickness of the bottom boundary layer [Z ~> m]. + real :: BBL_thick_max ! A huge upper bound on the boundary layer thickness [Z ~> m]. + real :: kv_bbl ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s] real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1]. real :: U_bg_sq ! The square of an assumed background @@ -210,69 +233,75 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: hwtot ! Sum of the thicknesses used to calculate ! the near-bottom velocity magnitude [H ~> m or kg m-2]. real :: I_hwtot ! The Adcroft reciprocal of hwtot [H-1 ~> m-1 or m2 kg-1]. + real :: dzwtot ! The vertical extent of the region used to calculate + ! the near-bottom velocity magnitude [Z ~> m]. real :: hutot ! Running sum of thicknesses times the velocity ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: Thtot ! Running sum of thickness times temperature [C H ~> degC m or degC kg m-2]. real :: Shtot ! Running sum of thickness times salinity [S H ~> ppt m or ppt kg m-2]. + real :: SpV_htot ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m] real :: hweight ! The thickness of a layer that is within Hbbl ! of the bottom [H ~> m or kg m-2]. + real :: dzweight ! The counterpart of hweight in height units [Z ~> m]. real :: v_at_u, u_at_v ! v at a u point or vice versa [L T-1 ~> m s-1]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real, dimension(SZI_(G),SZJ_(G),max(GV%nk_rho_varies,1)) :: & Rml ! The mixed layer coordinate density [R ~> kg m-3]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually set to 2e7 Pa = 2000 dbar). - real :: D_vel ! The bottom depth at a velocity point [H ~> m or kg m-2]. - real :: Dp, Dm ! The depths at the edges of a velocity cell [H ~> m or kg m-2]. - real :: a ! a is the curvature of the bottom depth across a - ! cell, times the cell width squared [H ~> m or kg m-2]. - real :: a_3, a_12 ! a/3 and a/12 [H ~> m or kg m-2]. - real :: C24_a ! 24/a [H-1 ~> m-1 or m2 kg-1]. + real :: D_vel ! The bottom depth at a velocity point [Z ~> m]. + real :: Dp, Dm ! The depths at the edges of a velocity cell [Z ~> m]. + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. real :: slope ! The absolute value of the bottom depth slope across - ! a cell times the cell width [H ~> m or kg m-2]. - real :: apb_4a, ax2_3apb ! Various nondimensional ratios of a and slope [nondim]. - real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of a and slope [H-1 ~> m-1 or m2 kg-1]. - ! All of the following "volumes" have units of thickness because they are normalized + ! a cell times the cell width [Z ~> m]. + real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. + real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + ! All of the following "volumes" have units of vertical heights because they are normalized ! by the full horizontal area of a velocity cell. real :: Vol_bbl_chan ! The volume of the bottom boundary layer as used in the channel ! drag parameterization, normalized by the full horizontal area - ! of the velocity cell [H ~> m or kg m-2]. - real :: Vol_open ! The cell volume above which it is open [H ~> m or kg m-2]. - real :: Vol_direct ! With less than Vol_direct [H ~> m or kg m-2], there is a direct + ! of the velocity cell [Z ~> m]. + real :: Vol_open ! The cell volume above which it is open [Z ~> m]. + real :: Vol_direct ! With less than Vol_direct [Z ~> m], there is a direct ! solution of a cubic equation for L. real :: Vol_2_reg ! The cell volume above which there are two separate - ! open areas that must be integrated [H ~> m or kg m-2]. + ! open areas that must be integrated [Z ~> m]. real :: vol ! The volume below the interface whose normalized - ! width is being sought [H ~> m or kg m-2]. + ! width is being sought [Z ~> m]. real :: vol_below ! The volume below the interface below the one that - ! is currently under consideration [H ~> m or kg m-2]. + ! is currently under consideration [Z ~> m]. real :: Vol_err ! The error in the volume with the latest estimate of - ! L, or the error for the interface below [H ~> m or kg m-2]. - real :: Vol_quit ! The volume error below which to quit iterating [H ~> m or kg m-2]. - real :: Vol_tol ! A volume error tolerance [H ~> m or kg m-2]. + ! L, or the error for the interface below [Z ~> m]. + real :: Vol_quit ! The volume error below which to quit iterating [Z ~> m]. + real :: Vol_tol ! A volume error tolerance [Z ~> m]. real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface [nondim]. real :: L_direct ! The value of L above volume Vol_direct [nondim]. - real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. - real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [H ~> m or kg m-2] - real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [H ~> m or kg m-2] - real :: Vol_0 ! A deeper volume with known width L0 [H ~> m or kg m-2]. + real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. + real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [Z ~> m] + real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [Z ~> m] + real :: Vol_0 ! A deeper volume with known width L0 [Z ~> m]. real :: L0 ! The value of L above volume Vol_0 [nondim]. - real :: dVol ! vol - Vol_0 [H ~> m or kg m-2]. + real :: dVol ! vol - Vol_0 [Z ~> m]. real :: dV_dL2 ! The partial derivative of volume with L squared - ! evaluated at L=L0 [H ~> m or kg m-2]. + ! evaluated at L=L0 [Z ~> m]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: ustH ! ustar converted to units of H T-1 [H T-1 ~> m s-1 or kg m-2 s-1]. real :: root ! A temporary variable [H T-1 ~> m s-1 or kg m-2 s-1]. real :: Cell_width ! The transverse width of the velocity cell [L ~> m]. - real :: Rayleigh ! A nondimensional value that is multiplied by the layer's - ! velocity magnitude to give the Rayleigh drag velocity, times - ! a lateral to vertical distance conversion factor [Z L-1 ~> nondim]. + real :: Rayleigh ! A factor that is multiplied by the layer's velocity magnitude + ! to give the Rayleigh drag velocity, times a lateral distance to + ! thickness conversion factor [H L-1 ~> nondim or kg m-3]. real :: gam ! The ratio of the change in the open interface width ! to the open interface width atop a cell [nondim]. real :: BBL_frac ! The fraction of a layer's drag that goes into the @@ -287,7 +316,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: tmp ! A temporary variable, sometimes in [Z ~> m] real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] real :: curv_tol ! Numerator of curvature cubed, used to estimate - ! accuracy of a single L(:) Newton iteration [H5 ~> m5 or kg5 m-10] + ! accuracy of a single L(:) Newton iteration [Z5 ~> m5] logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state @@ -299,8 +328,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Isq = G%isc-1 ; Ieq = G%IecB ; Jsq = G%jsc-1 ; Jeq = G%JecB nkmb = GV%nk_rho_varies ; nkml = GV%nkml h_neglect = GV%H_subroundoff - Rho0x400_G = 400.0*(GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H - Vol_quit = 0.9*GV%Angstrom_H + h_neglect + dz_neglect = GV%dZ_subroundoff + + Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) + Vol_quit = (0.9*GV%Angstrom_Z + dz_neglect) C2pi_3 = 8.0*atan(1.0)/3.0 if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& @@ -313,6 +344,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) call hchksum(h,"Start set_viscous_BBL h", G%HI, haloshift=1, scale=GV%H_to_m) if (associated(tv%T)) call hchksum(tv%T, "Start set_viscous_BBL T", G%HI, haloshift=1, scale=US%C_to_degC) if (associated(tv%S)) call hchksum(tv%S, "Start set_viscous_BBL S", G%HI, haloshift=1, scale=US%S_to_ppt) + if (allocated(tv%SpV_avg)) & + call hchksum(tv%SpV_avg, "Start set_viscous_BBL SpV_avg", G%HI, haloshift=1, scale=US%kg_m3_to_R) + if (allocated(tv%SpV_avg)) call hchksum(tv%SpV_avg, "Cornerless SpV_avg", G%HI, & + haloshift=1, omit_corners=.true., scale=US%kg_m3_to_R) + if (associated(tv%T)) call hchksum(tv%T, "Cornerless T", G%HI, haloshift=1, omit_corners=.true., scale=US%C_to_degC) + if (associated(tv%S)) call hchksum(tv%S, "Cornerless S", G%HI, haloshift=1, omit_corners=.true., scale=US%S_to_ppt) endif use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS @@ -320,11 +357,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) - cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H + cdrag_L_to_H = CS%cdrag * US%L_to_m * GV%m_to_H + cdrag_RL_to_H = CS%cdrag * US%L_to_Z * GV%RZ_to_H + BBL_thick_max = G%Rad_Earth_L * US%L_to_Z K2 = max(nkmb+1, 2) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + ! With a linear drag law, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel if ((nkml>0) .and. .not.use_BBL_EOS) then EOSdom(1) = Isq - (G%isd-1) ; EOSdom(2) = G%iec+1 - (G%isd-1) @@ -393,10 +437,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (allocated(visc%Ray_u)) visc%Ray_u(:,:,:) = 0.0 if (allocated(visc%Ray_v)) visc%Ray_v(:,:,:) = 0.0 - !$OMP parallel do default(private) shared(u,v,h,tv,visc,G,GV,US,CS,Rml,nz,nkmb, & - !$OMP nkml,Isq,Ieq,Jsq,Jeq,h_neglect,Rho0x400_G,C2pi_3, & - !$OMP U_bg_sq,cdrag_sqrt_Z,cdrag_sqrt,K2,use_BBL_EOS, & - !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v, pbv) & + !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, & + !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G,C2pi_3, & + !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & + !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & + !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v,pbv) & !$OMP firstprivate(Vol_quit) do j=Jsq,Jeq ; do m=1,2 @@ -420,16 +465,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then ! u-points do k=1,nz ; do I=is,ie if (do_i(I)) then - if (u(I,j,k) *(h(i+1,j,k) - h(i,j,k)) >= 0) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then ! If the flow is from thin to thick then bias towards the thinner thickness h_at_vel(I,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(I,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) else ! If the flow is from thick to thin then use the simple average thickness h_at_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) endif endif h_vel(I,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_vel(I,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) enddo ; enddo if (use_BBL_EOS) then ; do k=1,nz ; do I=is,ie ! Perhaps these should be thickness weighted. @@ -438,6 +487,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) enddo ; enddo ; else ; do k=1,nkmb ; do I=is,ie Rml_vel(I,k) = 0.5 * (Rml(i,j,k) + Rml(i+1,j,k)) enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do I=is,ie + SpV_vel(I,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + enddo ; enddo ; endif else ! v-points do k=1,nz ; do i=is,ie if (do_i(i)) then @@ -445,19 +497,27 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! If the flow is from thin to thick then bias towards the thinner thickness h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) else ! If the flow is from thick to thin then use the simple average thickness h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) endif endif h_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) enddo ; enddo if (use_BBL_EOS) then ; do k=1,nz ; do i=is,ie + ! Perhaps these should be thickness weighted. T_vel(i,k) = 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) S_vel(i,k) = 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) enddo ; enddo ; else ; do k=1,nkmb ; do i=is,ie Rml_vel(i,k) = 0.5 * (Rml(i,j,k) + Rml(i,j+1,k)) enddo ; enddo ; endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz ; do i=is,ie + SpV_vel(i,k) = 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + enddo ; enddo ; endif endif if (associated(OBC)) then ; if (OBC%number_of_segments > 0) then @@ -467,6 +527,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then do k=1,nz h_at_vel(I,k) = h(i,j,k) ; h_vel(I,k) = h(i,j,k) + dz_at_vel(I,k) = dz(i,j,k) ; dz_vel(I,k) = dz(i,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -477,9 +538,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(I,k) = Rml(i,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i,j,k) + enddo ; endif elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then do k=1,nz h_at_vel(I,k) = h(i+1,j,k) ; h_vel(I,k) = h(i+1,j,k) + dz_at_vel(I,k) = dz(i+1,j,k) ; dz_vel(I,k) = dz(i+1,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -490,6 +555,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(I,k) = Rml(i+1,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(I,k) = tv%SpV_avg(i+1,j,k) + enddo ; endif endif endif ; enddo else @@ -497,6 +565,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then do k=1,nz h_at_vel(i,k) = h(i,j,k) ; h_vel(i,k) = h(i,j,k) + dz_at_vel(i,k) = dz(i,j,k) ; dz_vel(i,k) = dz(i,j,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -507,9 +576,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(i,k) = Rml(i,j,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j,k) + enddo ; endif elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then do k=1,nz h_at_vel(i,k) = h(i,j+1,k) ; h_vel(i,k) = h(i,j+1,k) + dz_at_vel(i,k) = dz(i,j+1,k) ; dz_vel(i,k) = dz(i,j+1,k) enddo if (use_BBL_EOS) then do k=1,nz @@ -520,6 +593,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Rml_vel(i,k) = Rml(i,j+1,k) enddo endif + if (allocated(tv%SpV_avg)) then ; do k=1,nz + SpV_vel(i,k) = tv%SpV_avg(i,j+1,k) + enddo ; endif endif endif ; enddo endif @@ -531,16 +607,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Used in ustar(i) do i=is,ie ; if (do_i(i)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot = 0.0 ; Shtot = 0.0 + dztot_vel = 0.0 ; dzwtot = 0.0 + Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 do k=nz,1,-1 if (htot_vel>=CS%Hbbl) exit ! terminate the k loop hweight = MIN(CS%Hbbl - htot_vel, h_at_vel(i,k)) if (hweight < 1.5*GV%Angstrom_H + h_neglect) cycle + dzweight = MIN(CS%dz_bbl - dztot_vel, dz_at_vel(i,k)) - htot_vel = htot_vel + h_at_vel(i,k) + htot_vel = htot_vel + h_at_vel(i,k) hwtot = hwtot + hweight + dztot_vel = dztot_vel + dz_at_vel(i,k) + dzwtot = dzwtot + dzweight if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) @@ -562,20 +642,28 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Thtot = Thtot + hweight * T_vel(i,k) Shtot = Shtot + hweight * S_vel(i,k) endif + if (allocated(tv%SpV_avg) .and. (hweight >= 0.0)) then + SpV_htot = SpV_htot + hweight * SpV_vel(i,k) + endif enddo ! end of k loop - ! Set u* based on u*^2 = Cdrag u_bbl^2 - if (.not.CS%linear_drag .and. (hwtot > 0.0)) then - ustar(i) = cdrag_sqrt_Z*hutot / hwtot - else - ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel - endif - ! Find the Adcroft reciprocal of the total thickness weights I_hwtot = 0.0 ; if (hwtot > 0.0) I_hwtot = 1.0 / hwtot + ! Set u* based on u*^2 = Cdrag u_bbl^2 + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif + umag_avg(i) = hutot * I_hwtot h_bbl_drag(i) = hwtot + dz_bbl_drag(i) = dzwtot if (use_BBL_EOS) then ; if (hwtot > 0.0) then T_EOS(i) = Thtot/hwtot ; S_EOS(i) = Shtot/hwtot @@ -592,7 +680,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif ; enddo else - do i=is,ie ; ustar(i) = cdrag_sqrt_Z*CS%drag_bg_vel ; enddo + do i=is,ie ; ustar(i) = cdrag_sqrt_H*CS%drag_bg_vel ; enddo endif ! Not linear_drag if (use_BBL_EOS) then @@ -621,6 +709,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! The 400.0 in this expression is the square of a Ci introduced in KW99, eq. 2.22. ustarsq = Rho0x400_G * ustar(i)**2 ! Note not in units of u*^2 but [H R ~> kg m-2 or kg2 m-5] htot = 0.0 + dztot = 0.0 ! Calculate the thickness of a stratification limited BBL ignoring rotation: ! h_N = Ci u* / N (limit of KW99 eq. 2.20 for |f|->0) @@ -649,20 +738,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if ((oldfn + Dfn) <= ustarsq) then ! Use whole layer Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else ! Use only part of the layer - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif ! Increment total BBL thickness and cumulative T and S htot = htot + Dh + dztot = dztot + Ddz Thtot = Thtot + T_vel(i,k)*Dh ; Shtot = Shtot + S_vel(i,k)*Dh enddo if ((oldfn < ustarsq) .and. h_at_vel(i,1) > 0.0) then ! Layer 1 might be part of the BBL. if (dR_dT(i) * (Thtot - T_vel(i,1)*htot) + & - dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) & + dR_dS(i) * (Shtot - S_vel(i,1)*htot) < ustarsq) then htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif endif ! Examination of layer 1. else ! Use Rlay and/or the coordinate density as density variables. Rhtot = 0.0 @@ -674,11 +769,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot = htot + Dh + dztot = dztot + Ddz Rhtot = Rhtot + GV%Rlay(k)*Dh enddo if (nkml>0) then @@ -690,16 +789,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cycle elseif ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot = htot + Dh + dztot = dztot + Ddz Rhtot = Rhtot + Rml_vel(i,k)*Dh enddo - if (Rhtot - Rml_vel(i,1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - Rml_vel(i,1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif else - if (Rhtot - GV%Rlay(1)*htot < ustarsq) htot = htot + h_at_vel(i,1) + if (Rhtot - GV%Rlay(1)*htot < ustarsq) then + htot = htot + h_at_vel(i,1) + dztot = dztot + dz_at_vel(i,1) + endif endif endif ! use_BBL_EOS @@ -721,21 +830,20 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%cdrag * U_bg_sq <= 0.0) then ! This avoids NaNs and overflows, and could be used in all cases, ! but is not bitwise identical to the current code. - ustH = ustar(i)*GV%Z_to_H ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) - if (htot*ustH <= (CS%BBL_thick_min+h_neglect) * (0.5*ustH + root)) then + ustH = ustar(i) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) + if (dztot*ustH <= (CS%BBL_thick_min+dz_neglect) * (0.5*ustH + root)) then bbl_thick = CS%BBL_thick_min else ! The following expression reads ! h_bbl = h_N u* / ( 1/2 u* + sqrt( 1/4 u*^2 + ( 2 f h_N )^2 ) ) ! which is h_bbl = h_N u*/(xp u*) as described above. - bbl_thick = (htot * ustH) / (0.5*ustH + root) + bbl_thick = (dztot * ustH) / (0.5*ustH + root) endif else ! The following expression reads ! h_bbl = h_N / ( 1/2 + sqrt( 1/4 + ( 2 f h_N / u* )^2 ) ) ! which is h_bbl = h_N/xp as described above. - bbl_thick = htot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f/ & - ((ustar(i)*ustar(i)) * (GV%Z_to_H**2)) ) ) + bbl_thick = dztot / (0.5 + sqrt(0.25 + htot*htot*C2f*C2f / (ustar(i)*ustar(i)) ) ) if (bbl_thick < CS%BBL_thick_min) bbl_thick = CS%BBL_thick_min endif @@ -748,12 +856,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! need to set that scale here. In fact, viscously reducing the ! shears over an excessively large region reduces the efficacy of ! the Richardson number dependent mixing. - ! In other words, if using RiNo_mix then CS%Hbbl acts as an upper bound on + ! In other words, if using RiNo_mix then CS%dz_bbl acts as an upper bound on ! bbl_thick. - if ((bbl_thick > 0.5*CS%Hbbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%Hbbl + if ((bbl_thick > 0.5*CS%dz_bbl) .and. (CS%RiNo_mix)) bbl_thick = 0.5*CS%dz_bbl ! If drag is a body force, bbl_thick is HBBL - if (CS%body_force_drag) bbl_thick = h_bbl_drag(i) + if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i) if (CS%Channel_drag) then ! The drag within the bottommost Vol_bbl_chan is applied as a part of @@ -779,45 +887,42 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) endif if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif - ! Convert the D's to the units of thickness. - Dp = GV%Z_to_H*Dp ; Dm = GV%Z_to_H*Dm ; D_vel = GV%Z_to_H*D_vel - - a_3 = (Dp + Dm - 2.0*D_vel) ; a = 3.0*a_3 ; a_12 = 0.25*a_3 + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 slope = Dp - Dm ! If the curvature is small enough, there is no reason not to assume ! a uniformly sloping or flat bottom. - if (abs(a) < 1e-2*(slope + CS%BBL_thick_min)) a = 0.0 + if (abs(crv) < 1e-2*(slope + CS%BBL_thick_min)) crv = 0.0 ! Each cell extends from x=-1/2 to 1/2, and has a topography - ! given by D(x) = a*x^2 + b*x + D - a/12. + ! given by D(x) = crv*x^2 + slope*x + D - crv/12. ! Calculate the volume above which the entire cell is open and the ! other volumes at which the equation that is solved for L changes. - if (a > 0.0) then - if (slope >= a) then + if (crv > 0.0) then + if (slope >= crv) then Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open else - tmp = slope/a - Vol_open = 0.25*slope*tmp + C1_12*a - Vol_2_reg = 0.5*tmp**2 * (a - C1_3*slope) + tmp = slope/crv + Vol_open = 0.25*slope*tmp + C1_12*crv + Vol_2_reg = 0.5*tmp**2 * (crv - C1_3*slope) endif - ! Define some combinations of a & b for later use. - C24_a = 24.0/a ; Iapb = 1.0/(a+slope) - apb_4a = (slope+a)/(4.0*a) ; a2x48_apb3 = (48.0*(a*a))*(Iapb**3) - ax2_3apb = 2.0*C1_3*a*Iapb - elseif (a == 0.0) then + ! Define some combinations of crv & slope for later use. + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + apb_4a = (slope+crv)/(4.0*crv) ; a2x48_apb3 = (48.0*(crv*crv))*(Iapb**3) + ax2_3apb = 2.0*C1_3*crv*Iapb + elseif (crv == 0.0) then Vol_open = 0.5*slope if (slope > 0) Iapb = 1.0/slope - else ! a < 0.0 + else ! crv < 0.0 Vol_open = D_vel - Dm - if (slope >= -a) then - Iapb = 1.0e30 ; if (slope+a /= 0.0) Iapb = 1.0/(a+slope) - Vol_direct = 0.0 ; L_direct = 0.0 ; C24_a = 0.0 + if (slope >= -crv) then + Iapb = 1.0e30*US%Z_to_m ; if (slope+crv /= 0.0) Iapb = 1.0/(crv+slope) + Vol_direct = 0.0 ; L_direct = 0.0 ; C24_crv = 0.0 else - C24_a = 24.0/a ; Iapb = 1.0/(a+slope) - L_direct = 1.0 + slope/a ! L_direct < 1 because a < 0 - Vol_direct = -C1_6*a*L_direct**3 + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + L_direct = 1.0 + slope/crv ! L_direct < 1 because crv < 0 + Vol_direct = -C1_6*crv*L_direct**3 endif - Ibma_2 = 2.0 / (slope - a) + Ibma_2 = 2.0 / (slope - crv) endif L(nz+1) = 0.0 ; vol = 0.0 ; Vol_err = 0.0 ; BBL_visc_frac = 0.0 @@ -825,18 +930,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) do K=nz,1,-1 vol_below = vol - vol = vol + h_vel(i,k) + vol = vol + dz_vel(i,k) h_vel_pos = h_vel(i,k) + h_neglect if (vol >= Vol_open) then ; L(K) = 1.0 - elseif (a == 0) then ! The bottom has no curvature. + elseif (crv == 0) then ! The bottom has no curvature. L(K) = sqrt(2.0*vol*Iapb) - elseif (a > 0) then + elseif (crv > 0) then ! There may be a minimum depth, and there are ! analytic expressions for L for all cases. if (vol < Vol_2_reg) then ! In this case, there is a contiguous open region and - ! vol = 0.5*L^2*(slope + a/3*(3-4L)). + ! vol = 0.5*L^2*(slope + crv/3*(3-4L)). if (a2x48_apb3*vol < 1e-8) then ! Could be 1e-7? ! There is a very good approximation here for massless layers. L0 = sqrt(2.0*vol*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) @@ -845,67 +950,67 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) 2.0 * cos(C1_3*acos(a2x48_apb3*vol - 1.0) - C2pi_3)) endif ! To check the answers. - ! Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol else ! There are two separate open regions. - ! vol = slope^2/4a + a/12 - (a/12)*(1-L)^2*(1+2L) - ! At the deepest volume, L = slope/a, at the top L = 1. - !L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_a*(Vol_open - vol)) - C2pi_3) - tmp_val_m1_to_p1 = 1.0 - C24_a*(Vol_open - vol) + ! vol = slope^2/4crv + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + !L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_crv*(Vol_open - vol)) - C2pi_3) + tmp_val_m1_to_p1 = 1.0 - C24_crv*(Vol_open - vol) tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) ! To check the answers. - ! Vol_err = Vol_open - a_12*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol endif else ! a < 0. if (vol <= Vol_direct) then ! Both edges of the cell are bounded by walls. - L(K) = (-0.25*C24_a*vol)**C1_3 + L(K) = (-0.25*C24_crv*vol)**C1_3 else ! x_R is at 1/2 but x_L is in the interior & L is found by solving - ! vol = 0.5*L^2*(slope + a/3*(3-4L)) + ! vol = 0.5*L^2*(slope + crv/3*(3-4L)) - ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + a_3*(3.0-4.0*L(K+1))) - vol_below + ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + crv_3*(3.0-4.0*L(K+1))) - vol_below ! Change to ... - ! if (min(Vol_below + Vol_err, vol) <= Vol_direct) then ? + ! if (min(vol_below + Vol_err, vol) <= Vol_direct) then ? if (vol_below + Vol_err <= Vol_direct) then L0 = L_direct ; Vol_0 = Vol_direct else - L0 = L(K+1) ; Vol_0 = Vol_below + Vol_err - ! Change to Vol_0 = min(Vol_below + Vol_err, vol) ? + L0 = L(K+1) ; Vol_0 = vol_below + Vol_err + ! Change to Vol_0 = min(vol_below + Vol_err, vol) ? endif ! Try a relatively simple solution that usually works well ! for massless layers. - dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = (vol-Vol_0) - ! dV_dL2 = 0.5*(slope+a) - a*L0 ; dVol = max(vol-Vol_0, 0.0) + dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = (vol-Vol_0) + ! dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = max(vol-Vol_0, 0.0) use_L0 = .false. do_one_L_iter = .false. if (CS%answer_date < 20190101) then - curv_tol = GV%Angstrom_H*dV_dL2**2 & - * (0.25 * dV_dL2 * GV%Angstrom_H - a * L0 * dVol) - do_one_L_iter = (a * a * dVol**3) < curv_tol + curv_tol = GV%Angstrom_Z*dV_dL2**2 & + * (0.25 * dV_dL2 * GV%Angstrom_Z - crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol else ! The following code is more robust when GV%Angstrom_H=0, but ! it changes answers. use_L0 = (dVol <= 0.) - Vol_tol = max(0.5 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) - Vol_quit = max(0.9 * GV%Angstrom_H + GV%H_subroundoff, 1e-14 * vol) + Vol_tol = max(0.5 * GV%Angstrom_Z + dz_neglect, 1e-14 * vol) + Vol_quit = max(0.9 * GV%Angstrom_Z + dz_neglect, 1e-14 * vol) curv_tol = Vol_tol * dV_dL2**2 & - * (dV_dL2 * Vol_tol - 2.0 * a * L0 * dVol) - do_one_L_iter = (a * a * dVol**3) < curv_tol + * (dV_dL2 * Vol_tol - 2.0 * crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol endif if (use_L0) then L(K) = L0 - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol elseif (do_one_L_iter) then ! One iteration of Newton's method should give an estimate ! that is accurate to within Vol_tol. L(K) = sqrt(L0*L0 + dVol / dV_dL2) - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol else if (dV_dL2*(1.0-L0*L0) < dVol + & dV_dL2 * (Vol_open - Vol)*Ibma_2) then @@ -913,10 +1018,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) else L_max = sqrt(L0*L0 + dVol / dV_dL2) endif - L_min = sqrt(L0*L0 + dVol / (0.5*(slope+a) - a*L_max)) + L_min = sqrt(L0*L0 + dVol / (0.5*(slope+crv) - crv*L_max)) - Vol_err_min = 0.5*(L_min**2)*(slope + a_3*(3.0-4.0*L_min)) - vol - Vol_err_max = 0.5*(L_max**2)*(slope + a_3*(3.0-4.0*L_max)) - vol + Vol_err_min = 0.5*(L_min**2)*(slope + crv_3*(3.0-4.0*L_min)) - vol + Vol_err_max = 0.5*(L_max**2)*(slope + crv_3*(3.0-4.0*L_max)) - vol ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then if (abs(Vol_err_min) <= Vol_quit) then L(K) = L_min ; Vol_err = Vol_err_min @@ -924,13 +1029,13 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & (Vol_err_max - Vol_err_min)) do itt=1,maxitt - Vol_err = 0.5*(L(K)*L(K))*(slope + a_3*(3.0-4.0*L(K))) - vol + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol if (abs(Vol_err) <= Vol_quit) exit ! Take a Newton's method iteration. This equation has proven ! robust enough not to need bracketing. - L(K) = L(K) - Vol_err / (L(K)* (slope + a - 2.0*a*L(K))) + L(K) = L(K) - Vol_err / (L(K)* (slope + crv - 2.0*crv*L(K))) ! This would be a Newton's method iteration for L^2: - ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+a) - a*L(K))) + ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+crv) - crv*L(K))) enddo endif ! end of iterative solver endif ! end of 1-boundary alternatives. @@ -951,12 +1056,18 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) BBL_frac = 0.0 endif + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif + if (m==1) then ; Cell_width = G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k) else ; Cell_width = G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k) ; endif gam = 1.0 - L(K+1)/L(K) - Rayleigh = US%L_to_Z * CS%cdrag * (L(K)-L(K+1)) * (1.0-BBL_frac) * & + Rayleigh = cdrag_conv * (L(K)-L(K+1)) * (1.0-BBL_frac) * & (12.0*CS%c_Smag*h_vel_pos) / (12.0*CS%c_Smag*h_vel_pos + & - US%L_to_Z*GV%Z_to_H * CS%cdrag * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) + cdrag_conv * gam*(1.0-gam)*(1.0-1.5*gam) * L(K)**2 * Cell_width) else ! This layer feels no drag. Rayleigh = 0.0 endif @@ -964,12 +1075,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then if (Rayleigh > 0.0) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - visc%Ray_u(I,j,k) = GV%Z_to_H*Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) else ; visc%Ray_u(I,j,k) = 0.0 ; endif else if (Rayleigh > 0.0) then u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - visc%Ray_v(i,J,k) = GV%Z_to_H*Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif @@ -978,20 +1089,19 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Set the near-bottom viscosity to a value which will give ! the correct stress when the shear occurs over bbl_thick. ! See next block for explanation. - bbl_thick_Z = bbl_thick * GV%H_to_Z if (CS%correct_BBL_bounds .and. & - cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac <= CS%Kv_BBL_min) then + cdrag_sqrt*ustar(i)*bbl_thick*BBL_visc_frac <= CS%Kv_BBL_min) then ! If the bottom stress implies less viscosity than Kv_BBL_min then ! set kv_bbl to the bound and recompute bbl_thick to be consistent ! but with a ridiculously large upper bound on thickness (for Cd u*=0) kv_bbl = CS%Kv_BBL_min - if (cdrag_sqrt*ustar(i)*BBL_visc_frac*G%Rad_Earth_L*US%L_to_Z > kv_bbl) then - bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i)*BBL_visc_frac ) + if ((cdrag_sqrt*ustar(i))*BBL_visc_frac*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( (cdrag_sqrt*ustar(i)) * BBL_visc_frac ) else - bbl_thick_Z = G%Rad_Earth_L * US%L_to_Z + bbl_thick = BBL_thick_max endif else - kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z*BBL_visc_frac + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick*BBL_visc_frac endif else ! Not Channel_drag. @@ -1003,27 +1113,26 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! - u_bbl is embedded in u* since u*^2 = Cdrag u_bbl^2 ! - The average shear in the BBL is du/dz = 2 * u_bbl / h_bbl ! (which assumes a linear profile, hence the "2") - ! - bbl_thick was bounded to <= 0.5 * CS%Hbbl + ! - bbl_thick was bounded to <= 0.5 * CS%dz_bbl ! - The viscous stress kv_bbl du/dz should balance tau_b ! Cdrag u_bbl^2 = kv_bbl du/dz ! = 2 kv_bbl u_bbl ! so ! kv_bbl = 0.5 h_bbl Cdrag u_bbl ! = 0.5 h_bbl sqrt(Cdrag) u* - bbl_thick_Z = bbl_thick * GV%H_to_Z if (CS%correct_BBL_bounds .and. & - cdrag_sqrt*ustar(i)*bbl_thick_Z <= CS%Kv_BBL_min) then + cdrag_sqrt*ustar(i)*bbl_thick <= CS%Kv_BBL_min) then ! If the bottom stress implies less viscosity than Kv_BBL_min then ! set kv_bbl to the bound and recompute bbl_thick to be consistent ! but with a ridiculously large upper bound on thickness (for Cd u*=0) kv_bbl = CS%Kv_BBL_min - if (cdrag_sqrt*ustar(i)*G%Rad_Earth_L*US%L_to_Z > kv_bbl) then - bbl_thick_Z = kv_bbl / ( cdrag_sqrt*ustar(i) ) + if ((cdrag_sqrt*ustar(i))*BBL_thick_max > kv_bbl) then + bbl_thick = kv_bbl / ( cdrag_sqrt*ustar(i) ) else - bbl_thick_Z = G%Rad_Earth_L * US%L_to_Z + bbl_thick = BBL_thick_max endif else - kv_bbl = cdrag_sqrt*ustar(i)*bbl_thick_Z + kv_bbl = (cdrag_sqrt*ustar(i)) * bbl_thick endif endif @@ -1033,10 +1142,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) I_hwtot = 1.0 / h_bbl_drag(i) do k=nz,1,-1 h_bbl_fr = min(h_bbl_drag(i) - h_sum, h_at_vel(i,k)) * I_hwtot + if (allocated(tv%SpV_avg)) then + cdrag_conv = cdrag_RL_to_H / SpV_vel(i,k) + else + cdrag_conv = cdrag_L_to_H + endif if (m==1) then - visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(I)) * h_bbl_fr + visc%Ray_u(I,j,k) = visc%Ray_u(I,j,k) + (cdrag_conv * umag_avg(I)) * h_bbl_fr else - visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + GV%Z_to_H*(CS%cdrag*US%L_to_Z*umag_avg(i)) * h_bbl_fr + visc%Ray_v(i,J,k) = visc%Ray_v(i,J,k) + (cdrag_conv * umag_avg(i)) * h_bbl_fr endif h_sum = h_sum + h_at_vel(i,k) if (h_sum >= h_bbl_drag(i)) exit ! The top of this layer is above the drag zone. @@ -1047,11 +1161,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) kv_bbl = max(CS%Kv_BBL_min, kv_bbl) if (m==1) then - visc%bbl_thick_u(I,j) = bbl_thick_Z - if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = GV%Z_to_H*kv_bbl + visc%bbl_thick_u(I,j) = bbl_thick + if (allocated(visc%Kv_bbl_u)) visc%Kv_bbl_u(I,j) = kv_bbl else - visc%bbl_thick_v(i,J) = bbl_thick_Z - if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = GV%Z_to_H*kv_bbl + visc%bbl_thick_v(i,J) = bbl_thick + if (allocated(visc%Kv_bbl_v)) visc%Kv_bbl_v(i,J) = kv_bbl endif endif ; enddo ! end of i loop enddo ; enddo ! end of m & j loops @@ -1204,12 +1318,15 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! Local variables real, dimension(SZIB_(G)) :: & - htot, & ! The total depth of the layers being that are within the + htot, & ! The total thickness of the layers that are within the ! surface mixed layer [H ~> m or kg m-2]. + dztot, & ! The distance from the surface to the bottom of the layers that are + ! within the surface mixed layer [Z ~> m] Thtot, & ! The integrated temperature of layers that are within the ! surface mixed layer [H C ~> m degC or kg degC m-2]. Shtot, & ! The integrated salt of layers that are within the ! surface mixed layer [H S ~> m ppt or kg ppt m-2]. + SpV_htot, & ! Running sum of thickness times specific volume [R-1 H ~> m4 kg-1 or m] Rhtot, & ! The integrated density of layers that are within the surface mixed layer ! [H R ~> kg m-2 or kg2 m-5]. Rhtot is only used if no ! equation of state is used. @@ -1222,19 +1339,30 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! (roughly the base of the mixed layer) with temperature [R C-1 ~> kg m-3 degC-1]. dR_dS, & ! Partial derivative of the density at the base of layer nkml ! (roughly the base of the mixed layer) with salinity [R S-1 ~> kg m-3 ppt-1]. - ustar, & ! The surface friction velocity under ice shelves [Z T-1 ~> m s-1]. + dSpV_dT, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. + dSpV_dS, & ! Partial derivative of the specific volume at the base of layer nkml + ! (roughly the base of the mixed layer) with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + ustar, & ! The surface friction velocity under ice shelves [H T-1 ~> m s-1 or kg m-2 s-1]. press, & ! The pressure at which dR_dT and dR_dS are evaluated [R L2 T-2 ~> Pa]. T_EOS, & ! The potential temperature at which dR_dT and dR_dS are evaluated [C ~> degC] S_EOS ! The salinity at which dR_dT and dR_dS are evaluated [S ~> ppt]. + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real, dimension(SZIB_(G),SZJ_(G)) :: & mask_u ! A mask that disables any contributions from u points that ! are land or past open boundary conditions [nondim], 0 or 1. real, dimension(SZI_(G),SZJB_(G)) :: & mask_v ! A mask that disables any contributions from v points that ! are land or past open boundary conditions [nondim], 0 or 1. + real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity in thickness-based units, + ! calculated using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] real :: h_at_vel(SZIB_(G),SZK_(GV))! Layer thickness at velocity points, ! using an upwind-biased second order accurate estimate based ! on the previous velocity direction [H ~> m or kg m-2]. + real :: dz_at_vel(SZIB_(G),SZK_(GV)) ! Vertical extent of a layer at velocity points, + ! using an upwind-biased second order accurate estimate based + ! on the previous velocity direction [Z ~> m]. integer :: k_massive(SZIB_(G)) ! The k-index of the deepest layer yet found ! that has more than h_tiny thickness and will be in the ! viscous mixed layer. @@ -1249,7 +1377,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! magnitudes [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real :: hweight ! The thickness of a layer that is within Hbbl ! of the bottom [H ~> m or kg m-2]. - real :: tbl_thick_Z ! The thickness of the top boundary layer [Z ~> m]. + real :: tbl_thick ! The thickness of the top boundary layer [Z ~> m]. real :: hlay ! The layer thickness at velocity points [H ~> m or kg m-2]. real :: I_2hlay ! 1 / 2*hlay [H-1 ~> m-1 or m2 kg-1]. @@ -1271,31 +1399,38 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) real :: ustarsq ! 400 times the square of ustar, times ! Rho0 divided by G_Earth and the conversion ! from m to thickness units [H R ~> kg m-2 or kg2 m-5]. - real :: cdrag_sqrt_Z ! Square root of the drag coefficient, times a unit conversion - ! factor from lateral lengths to vertical depths [Z L-1 ~> nondim] real :: cdrag_sqrt ! Square root of the drag coefficient [nondim]. + real :: cdrag_sqrt_H ! Square root of the drag coefficient, times a unit conversion + ! factor from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. + real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from + ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, ! divided by G_Earth [H R ~> kg m-2 or kg2 m-5]. real :: Dfn ! The increment in oldfn for entraining ! the layer [H R ~> kg m-2 or kg2 m-5]. - real :: Dh ! The increment in layer thickness from - ! the present layer [H ~> m or kg m-2]. + real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] + real :: Dh ! The increment in layer thickness from the present layer [H ~> m or kg m-2]. + real :: Ddz ! The increment in height change from the present layer [Z ~> m]. real :: U_bg_sq ! The square of an assumed background velocity, for ! calculating the mean magnitude near the top for use in ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. Layers that are less than ! h_tiny can not be the deepest in the viscous mixed layer. real :: absf ! The absolute value of f averaged to velocity points [T-1 ~> s-1]. - real :: U_star ! The friction velocity at velocity points [Z T-1 ~> m s-1]. + real :: U_star ! The friction velocity at velocity points [H T-1 ~> m s-1 or kg m-2 s-1]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: Rho0x400_G ! 400*Rho0/G_Earth, times unit conversion factors - ! [R T2 H Z-2 ~> kg s2 m-4 or kg2 s2 m-7]. + ! [R T2 H-1 ~> kg s2 m-4 or s2 m-1]. ! The 400 is a constant proposed by Killworth and Edwards, 1999. real :: ustar1 ! ustar [H T-1 ~> m s-1 or kg m-2 s-1] real :: h2f2 ! (h*2*f)^2 [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] logical :: use_EOS, do_any, do_any_shelf, do_i(SZIB_(G)) + logical :: nonBous_ML ! If true, use the non-Boussinesq form of some energy and + ! stratification calculations. integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, K2, nkmb, nkml, n type(ocean_OBC_type), pointer :: OBC => NULL() @@ -1309,22 +1444,28 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.(CS%dynamic_viscous_ML .or. associated(forces%frac_shelf_u) .or. & associated(forces%frac_shelf_v)) ) return - Rho0x400_G = 400.0*(GV%Rho0/(US%L_to_Z**2 * GV%g_Earth)) * GV%Z_to_H + Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) - cdrag_sqrt_Z = US%L_to_Z * sqrt(CS%cdrag) + cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H + cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H OBC => CS%OBC use_EOS = associated(tv%eqn_of_state) + nonBous_ML = allocated(tv%SpV_avg) dt_Rho0 = dt / GV%H_to_RZ h_neglect = GV%H_subroundoff h_tiny = 2.0*GV%Angstrom_H + h_neglect + dz_neglect = GV%dZ_subroundoff g_H_Rho0 = (GV%g_Earth*GV%H_to_Z) / (GV%Rho0) if (associated(forces%frac_shelf_u) .neqv. associated(forces%frac_shelf_v)) & call MOM_error(FATAL, "set_viscous_ML: one of forces%frac_shelf_u and "//& "forces%frac_shelf_v is associated, but the other is not.") + ! Extract the friction velocity from the forcing type. + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) + if (associated(forces%frac_shelf_u)) then ! This configuration has ice shelves, and the appropriate variables need to be ! allocated. If the arrays have already been allocated, these calls do nothing. @@ -1342,7 +1483,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) allocate(visc%kv_tbl_shelf_v(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) ! With a linear drag law under shelves, the friction velocity is already known. -! if (CS%linear_drag) ustar(:) = cdrag_sqrt_Z*CS%drag_bg_vel +! if (CS%linear_drag) ustar(:) = cdrag_sqrt_H*CS%drag_bg_vel + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) endif !$OMP parallel do default(shared) @@ -1373,9 +1517,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) endif enddo ; endif - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & - !$OMP h_neglect,h_tiny,g_H_Rho0,js,je,OBC,Isq,Ieq,nz, & - !$OMP U_bg_sq,mask_v,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml) + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP js,je,OBC,Isq,Ieq,nz,nkml,U_star_2d,U_bg_sq,mask_v, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do j=js,je ! u-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1396,8 +1541,8 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i+1,j))) - Idecay_len_TKE(I) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) + Idecay_len_TKE(I) = (absf / U_star) * CS%TKE_decay endif enddo @@ -1416,6 +1561,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, tv%eqn_of_state, & (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/Isq-G%IsdB+1,Ieq-G%IsdB+1/) ) + endif endif do I=Isq,Ieq ; if (do_i(I)) then @@ -1430,8 +1579,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (use_EOS) then T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i+1,j,k)*tv%T(i+1,j,k)) * I_2hlay S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i+1,j,k)*tv%S(i+1,j,k)) * I_2hlay - gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & - dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(I) * (Thtot(I) - T_lay*htot(I)) + & + dSpV_dS(I) * (Shtot(I) - S_lay*htot(I))) + else + gHprime = g_H_Rho0 * (dR_dT(I) * (T_lay*htot(I) - Thtot(I)) + & + dR_dS(I) * (S_lay*htot(I) - Shtot(I))) + endif else gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(I) - Rhtot(I)) endif @@ -1489,19 +1643,24 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (do_any_shelf) then do k=1,nz ; do I=Isq,Ieq ; if (do_i(I)) then - if (u(I,j,k) *(h(i+1,j,k) - h(i,j,k)) >= 0) then + if (u(I,j,k) * (h(i+1,j,k) - h(i,j,k)) >= 0) then h_at_vel(i,k) = 2.0*h(i,j,k)*h(i+1,j,k) / & (h(i,j,k) + h(i+1,j,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i+1,j,k) / & + (dz(i,j,k) + dz(i+1,j,k) + dz_neglect) else h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i+1,j,k)) endif else - h_at_vel(I,k) = 0.0 ; ustar(I) = 0.0 + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(I) = 0.0 endif ; enddo ; enddo do I=Isq,Ieq ; if (do_i(I)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot(I) = 0.0 ; Shtot(I) = 0.0 + Thtot(I) = 0.0 ; Shtot(I) = 0.0 ; SpV_htot(I) = 0.0 if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) @@ -1518,12 +1677,19 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Thtot(I) = Thtot(I) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) Shtot(I) = Shtot(I) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i+1,j,k)) endif + if (allocated(tv%SpV_avg)) then + SpV_htot(I) = SpV_htot(I) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i+1,j,k)) + endif enddo ; endif - if ((.not.CS%linear_drag) .and. (hwtot > 0.0)) then - ustar(I) = cdrag_sqrt_Z * hutot / hwtot - else - ustar(I) = cdrag_sqrt_Z * CS%drag_bg_vel + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(I) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(I) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(I)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(I) = cdrag_sqrt_H_RL * hutot / SpV_htot(I) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(I) = cdrag_sqrt_H * hutot / hwtot endif if (use_EOS) then ; if (hwtot > 0.0) then @@ -1531,6 +1697,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) else T_EOS(I) = 0.0 ; S_EOS(I) = 0.0 endif ; endif + ! if (allocated(tv%SpV_avg)) SpV_av(I) = SpVhtot(I) / hwtot endif ; enddo ! I-loop if (use_EOS) then @@ -1542,7 +1709,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! The 400.0 in this expression is the square of a constant proposed ! by Killworth and Edwards, 1999, in equation (2.20). ustarsq = Rho0x400_G * ustar(i)**2 - htot(i) = 0.0 + htot(i) = 0.0 ; dztot(i) = 0.0 if (use_EOS) then Thtot(i) = 0.0 ; Shtot(i) = 0.0 do k=1,nz-1 @@ -1557,19 +1724,25 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) (h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh enddo if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i+1,j,nz)) S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i+1,j,nz)) if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & - dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! Examination of layer nz. else ! Use Rlay as the density variable. Rhtot = 0.0 @@ -1582,35 +1755,42 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Rhtot(i) = Rhtot(i) + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! use_EOS - !visc%tbl_thick_shelf_u(I,j) = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ! htot(I) / (0.5 + sqrt(0.25 + & + ! visc%tbl_thick_shelf_u(I,j) = max(CS%Htbl_shelf_min, & + ! dztot(I) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*GV%Z_to_H)**2 )) ) - ustar1 = ustar(i)*GV%Z_to_H + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) h2f2 = (htot(i)*(G%CoriolisBu(I,J-1)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 - tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ( htot(I)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%tbl_thick_shelf_u(I,j) = tbl_thick_Z - visc%Kv_tbl_shelf_u(I,j) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(I)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_u(I,j) = tbl_thick + visc%Kv_tbl_shelf_u(I,j) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) endif ; enddo ! I-loop endif ! do_any_shelf enddo ! j-loop at u-points - !$OMP parallel do default(private) shared(u,v,h,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & - !$OMP h_neglect,h_tiny,g_H_Rho0,is,ie,OBC,Jsq,Jeq,nz, & - !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_Z,Rho0x400_G,nkml,mask_u) + !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & + !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & + !$OMP is,ie,OBC,Jsq,Jeq,nz,nkml,U_bg_sq,U_star_2d,mask_u, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do J=Jsq,Jeq ! v-point loop if (CS%dynamic_viscous_ML) then do_any = .false. @@ -1626,14 +1806,14 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) uhtot(i) = 0.25 * dt_Rho0 * ((forces%taux(I,j) + forces%taux(I-1,j+1)) + & (forces%taux(I-1,j) + forces%taux(I,j+1))) - if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else - absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) - if (CS%omega_frac > 0.0) & - absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) - endif + if (CS%omega_frac >= 1.0) then ; absf = 2.0*CS%omega ; else + absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) + if (CS%omega_frac > 0.0) & + absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) + endif - U_star = max(CS%ustar_min, 0.5 * (forces%ustar(i,j) + forces%ustar(i,j+1))) - Idecay_len_TKE(i) = ((absf / U_star) * CS%TKE_decay) * GV%H_to_Z + U_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) + Idecay_len_TKE(i) = (absf / U_star) * CS%TKE_decay endif enddo @@ -1653,6 +1833,10 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) enddo call calculate_density_derivs(T_EOS, S_EOS, press, dR_dT, dR_dS, & tv%eqn_of_state, (/is-G%IsdB+1,ie-G%IsdB+1/) ) + if (nonBous_ML) then + call calculate_specific_vol_derivs(T_EOS, S_EOS, press, dSpV_dT, dSpV_dS, tv%eqn_of_state, & + (/is-G%IsdB+1,ie-G%IsdB+1/) ) + endif endif do i=is,ie ; if (do_i(i)) then @@ -1667,8 +1851,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (use_EOS) then T_lay = (h(i,j,k)*tv%T(i,j,k) + h(i,j+1,k)*tv%T(i,j+1,k)) * I_2hlay S_lay = (h(i,j,k)*tv%S(i,j,k) + h(i,j+1,k)*tv%S(i,j+1,k)) * I_2hlay - gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & - dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + if (nonBous_ML) then + gHprime = (GV%g_Earth * GV%H_to_RZ) * (dSpV_dT(i) * (Thtot(i) - T_lay*htot(i)) + & + dSpV_dS(i) * (Shtot(i) - S_lay*htot(i))) + else + gHprime = g_H_Rho0 * (dR_dT(i) * (T_lay*htot(i) - Thtot(i)) + & + dR_dS(i) * (S_lay*htot(i) - Shtot(i))) + endif else gHprime = g_H_Rho0 * (GV%Rlay(k)*htot(i) - Rhtot(i)) endif @@ -1729,16 +1918,21 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (v(i,J,k) * (h(i,j+1,k) - h(i,j,k)) >= 0) then h_at_vel(i,k) = 2.0*h(i,j,k)*h(i,j+1,k) / & (h(i,j,k) + h(i,j+1,k) + h_neglect) + dz_at_vel(i,k) = 2.0*dz(i,j,k)*dz(i,j+1,k) / & + (dz(i,j,k) + dz(i,j+1,k) + dz_neglect) else h_at_vel(i,k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_at_vel(i,k) = 0.5 * (dz(i,j,k) + dz(i,j+1,k)) endif else - h_at_vel(I,k) = 0.0 ; ustar(i) = 0.0 + h_at_vel(I,k) = 0.0 + dz_at_vel(I,k) = 0.0 + ustar(i) = 0.0 endif ; enddo ; enddo do i=is,ie ; if (do_i(i)) then htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 - Thtot(i) = 0.0 ; Shtot(i) = 0.0 + Thtot(i) = 0.0 ; Shtot(i) = 0.0 ; SpV_htot(i) = 0.0 if (use_EOS .or. .not.CS%linear_drag) then ; do k=1,nz if (htot_vel>=CS%Htbl_shelf) exit ! terminate the k loop hweight = MIN(CS%Htbl_shelf - htot_vel, h_at_vel(i,k)) @@ -1755,13 +1949,20 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Thtot(i) = Thtot(i) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) Shtot(i) = Shtot(i) + hweight * 0.5 * (tv%S(i,j,k) + tv%S(i,j+1,k)) endif + if (allocated(tv%SpV_avg)) then + SpV_htot(i) = SpV_htot(i) + hweight * 0.5 * (tv%SpV_avg(i,j,k) + tv%SpV_avg(i,j+1,k)) + endif enddo ; endif - if (.not.CS%linear_drag) then ; if (hwtot > 0.0) then - ustar(i) = cdrag_sqrt_Z * hutot / hwtot - else - ustar(i) = cdrag_sqrt_Z * CS%drag_bg_vel - endif ; endif + if ((hwtot <= 0.0) .or. (CS%linear_drag .and. .not.allocated(tv%SpV_avg))) then + ustar(i) = cdrag_sqrt_H * CS%drag_bg_vel + elseif (CS%linear_drag .and. allocated(tv%SpV_avg)) then + ustar(i) = cdrag_sqrt_H_RL * CS%drag_bg_vel * (hwtot / SpV_htot(i)) + elseif (allocated(tv%SpV_avg)) then ! (.not.CS%linear_drag) + ustar(i) = cdrag_sqrt_H_RL * hutot / SpV_htot(i) + else ! (.not.CS%linear_drag .and. .not.allocated(tv%SpV_avg)) + ustar(i) = cdrag_sqrt_H * hutot / hwtot + endif if (use_EOS) then ; if (hwtot > 0.0) then T_EOS(i) = Thtot(i)/hwtot ; S_EOS(i) = Shtot(i)/hwtot @@ -1780,6 +1981,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) ! by Killworth and Edwards, 1999, in equation (2.20). ustarsq = Rho0x400_G * ustar(i)**2 htot(i) = 0.0 + dztot(i) = 0.0 if (use_EOS) then Thtot(i) = 0.0 ; Shtot(i) = 0.0 do k=1,nz-1 @@ -1794,19 +1996,25 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) (h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Thtot(i) = Thtot(i) + T_Lay*Dh ; Shtot(i) = Shtot(i) + S_Lay*Dh enddo if ((oldfn < ustarsq) .and. (h_at_vel(i,nz) > 0.0)) then T_Lay = 0.5*(tv%T(i,j,nz) + tv%T(i,j+1,nz)) S_Lay = 0.5*(tv%S(i,j,nz) + tv%S(i,j+1,nz)) if (dR_dT(i)*(T_Lay*htot(i) - Thtot(i)) + & - dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) & + dR_dS(i)*(S_Lay*htot(i) - Shtot(i)) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! Examination of layer nz. else ! Use Rlay as the density variable. Rhtot = 0.0 @@ -1819,27 +2027,33 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) Dfn = (Rlb - Rlay)*(h_at_vel(i,k)+htot(i)) if ((oldfn + Dfn) <= ustarsq) then Dh = h_at_vel(i,k) + Ddz = dz_at_vel(i,k) else - Dh = h_at_vel(i,k) * sqrt((ustarsq-oldfn) / (Dfn)) + frac_used = sqrt((ustarsq-oldfn) / (Dfn)) + Dh = h_at_vel(i,k) * frac_used + Ddz = dz_at_vel(i,k) * frac_used endif htot(i) = htot(i) + Dh + dztot(i) = dztot(i) + Ddz Rhtot = Rhtot + Rlay*Dh enddo - if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) & + if (GV%Rlay(nz)*htot(i) - Rhtot(i) < ustarsq) then htot(i) = htot(i) + h_at_vel(i,nz) + dztot(i) = dztot(i) + dz_at_vel(i,nz) + endif endif ! use_EOS - !visc%tbl_thick_shelf_v(i,J) = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ! htot(i) / (0.5 + sqrt(0.25 + & + ! visc%tbl_thick_shelf_v(i,J) = max(CS%Htbl_shelf_min, & + ! dztot(i) / (0.5 + sqrt(0.25 + & ! (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)))**2 / & - ! (ustar(i)*GV%Z_to_H)**2 )) ) - ustar1 = ustar(i)*GV%Z_to_H + ! (ustar(i))**2 )) ) + ustar1 = ustar(i) h2f2 = (htot(i)*(G%CoriolisBu(I-1,J)+G%CoriolisBu(I,J)) + h_neglect*CS%omega)**2 - tbl_thick_Z = GV%H_to_Z * max(CS%Htbl_shelf_min, & - ( htot(i)*ustar1 ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) - visc%tbl_thick_shelf_v(i,J) = tbl_thick_Z - visc%Kv_tbl_shelf_v(i,J) = GV%Z_to_H*max(CS%Kv_TBL_min, cdrag_sqrt*ustar(i)*tbl_thick_Z) + tbl_thick = max(CS%Htbl_shelf_min, & + ( dztot(i)*ustar(i) ) / ( 0.5*ustar1 + sqrt((0.5*ustar1)**2 + h2f2 ) ) ) + visc%tbl_thick_shelf_v(i,J) = tbl_thick + visc%Kv_tbl_shelf_v(i,J) = max(CS%Kv_TBL_min, cdrag_sqrt*ustar1*tbl_thick) endif ; enddo ! i-loop endif ! do_any_shelf @@ -1873,6 +2087,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) 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=16) :: Kv_units, Kd_units character(len=40) :: mdl = "MOM_set_visc" ! This module's name. isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -1897,25 +2112,31 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) "in the surface boundary layer.", default=.false., do_not_log=.true.) endif + if (GV%Boussinesq) then + Kv_units = "m2 s-1" ; Kd_units = "m2 s-1" + else + Kv_units = "Pa s" ; Kd_units = "kg m-1 s-1" + endif + if (use_kappa_shear .or. useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv) then call safe_alloc_ptr(visc%Kd_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kd_shear, "Kd_shear", .false., restart_CS, & "Shear-driven turbulent diffusivity at interfaces", & - units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') + units=Kd_units, conversion=GV%HZ_T_to_MKS, z_grid='i') endif if (useKPP .or. useEPBL .or. use_CVMix_shear .or. use_CVMix_conv .or. & (use_kappa_shear .and. .not.KS_at_vertex )) then call safe_alloc_ptr(visc%Kv_shear, isd, ied, jsd, jed, nz+1) call register_restart_field(visc%Kv_shear, "Kv_shear", .false., restart_CS, & "Shear-driven turbulent viscosity at interfaces", & - units="m2 s-1", conversion=GV%HZ_T_to_m2_s, z_grid='i') + units=Kv_units, conversion=GV%HZ_T_to_MKS, z_grid='i') endif if (use_kappa_shear .and. KS_at_vertex) then call safe_alloc_ptr(visc%TKE_turb, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call safe_alloc_ptr(visc%Kv_shear_Bu, HI%IsdB, HI%IedB, HI%JsdB, HI%JedB, nz+1) call register_restart_field(visc%Kv_shear_Bu, "Kv_shear_Bu", .false., restart_CS, & "Shear-driven turbulent viscosity at vertex interfaces", & - units="m2 s-1", conversion=GV%HZ_T_to_m2_s, hor_grid="Bu", z_grid='i') + units=Kv_units, conversion=GV%HZ_T_to_MKS, hor_grid="Bu", z_grid='i') elseif (use_kappa_shear) then call safe_alloc_ptr(visc%TKE_turb, isd, ied, jsd, jed, nz+1) endif @@ -1932,14 +2153,13 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) call get_param(param_file, mdl, "HFREEZE", hfreeze, & units="m", default=-1.0, scale=US%m_to_Z, do_not_log=.true.) - if (MLE_use_PBL_MLD) then + if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) - call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & - "Instantaneous active mixing layer depth", "m", conversion=US%Z_to_m) endif - if (hfreeze >= 0.0 .and. .not.MLE_use_PBL_MLD) then - call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) + if (MLE_use_PBL_MLD) then + call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & + "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) endif ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model @@ -2009,8 +2229,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS ! is used in place of the absolute value of the local Coriolis ! parameter in the denominator of some expressions [nondim] real :: Chan_max_thick_dflt ! The default value for CHANNEL_DRAG_MAX_THICK [Z ~> m] - real :: Hbbl ! The static bottom boundary layer thickness [Z ~> m]. - real :: BBL_thick_min ! The minimum bottom boundary layer thickness [Z ~> m]. integer :: i, j, k, is, ie, js, je integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz @@ -2140,14 +2358,14 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_H + GV%H_subroundoff) else call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) endif - call get_param(param_file, mdl, "HBBL", Hbbl, & + call get_param(param_file, mdl, "HBBL", CS%dz_bbl, & "The thickness of a bottom boundary layer with a viscosity increased by "//& "KV_EXTRA_BBL if BOTTOMDRAGLAW is not defined, or the thickness over which "//& "near-bottom velocities are averaged for the drag law if BOTTOMDRAGLAW is "//& @@ -2192,7 +2410,7 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS if (use_regridding .and. (.not. CS%BBL_use_EOS)) & call MOM_error(FATAL,"When using MOM6 in ALE mode it is required to set BBL_USE_EOS to True.") endif - call get_param(param_file, mdl, "BBL_THICK_MIN", BBL_thick_min, & + call get_param(param_file, mdl, "BBL_THICK_MIN", CS%BBL_thick_min, & "The minimum bottom boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& @@ -2201,12 +2419,12 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "The minimum top boundary layer thickness that can be "//& "used with BOTTOMDRAGLAW. This might be "//& "Kv/(cdrag*drag_bg_vel) to give Kv as the minimum "//& - "near-top viscosity.", units="m", default=US%Z_to_m*BBL_thick_min, scale=GV%m_to_H) + "near-top viscosity.", units="m", default=US%Z_to_m*CS%BBL_thick_min, scale=US%m_to_Z) call get_param(param_file, mdl, "HTBL_SHELF", CS%Htbl_shelf, & "The thickness over which near-surface velocities are "//& "averaged for the drag law under an ice shelf. By "//& "default this is the same as HBBL", & - units="m", default=US%Z_to_m*Hbbl, scale=GV%m_to_H) + units="m", default=US%Z_to_m*CS%dz_bbl, scale=GV%m_to_H) call get_param(param_file, mdl, "KV", Kv_background, & "The background kinematic viscosity in the interior. "//& @@ -2220,10 +2438,10 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "KV_BBL_MIN", CS%KV_BBL_min, & "The minimum viscosities in the bottom boundary layer.", & - units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KV_TBL_MIN", CS%KV_TBL_min, & "The minimum viscosities in the top boundary layer.", & - units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=US%Z2_T_to_m2_s*Kv_background, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "CORRECT_BBL_BOUNDS", CS%correct_BBL_bounds, & "If true, uses the correct bounds on the BBL thickness and "//& "viscosity so that the bottom layer feels the intended drag.", & @@ -2246,21 +2464,20 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS endif Chan_max_thick_dflt = -1.0*US%m_to_Z - if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*Hbbl - if (CS%body_force_drag) Chan_max_thick_dflt = Hbbl + if (CS%RiNo_mix) Chan_max_thick_dflt = 0.5*CS%dz_bbl + if (CS%body_force_drag) Chan_max_thick_dflt = CS%dz_bbl call get_param(param_file, mdl, "CHANNEL_DRAG_MAX_BBL_THICK", CS%Chan_drag_max_vol, & "The maximum bottom boundary layer thickness over which the channel drag is "//& "exerted, or a negative value for no fixed limit, instead basing the BBL "//& "thickness on the bottom stress, rotation and stratification. The default is "//& "proportional to HBBL if USE_JACKSON_PARAM or DRAG_AS_BODY_FORCE is true.", & - units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=GV%m_to_H, & + units="m", default=US%Z_to_m*Chan_max_thick_dflt, scale=US%m_to_Z, & do_not_log=.not.CS%Channel_drag) call get_param(param_file, mdl, "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) - CS%Hbbl = Hbbl * GV%Z_to_H ! Rescaled for later use - CS%BBL_thick_min = BBL_thick_min * GV%Z_to_H ! Rescaled for later use + CS%Hbbl = CS%dz_bbl * (US%Z_to_m * GV%m_to_H) ! Rescaled for use in expressions in thickness units. if (CS%RiNo_mix .and. kappa_shear_at_vertex(param_file)) then ! This is necessary for reproducibility across restarts in non-symmetric mode. From 9b86edb3d8f0acb13cfaa610cad17b4a740d7bd2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Aug 2023 11:55:57 -0400 Subject: [PATCH 376/629] *Non-Boussinesq revision of set_diffusivity This commit revises the internal routines called by set_diffusivity to work in fully non-Boussinesq mode, eliminating all dependencies on the Boussinesq reference density when in non-Boussinesq mode. The publicly visible interfaces to this module and the external routines it calls have already been revised, so only this file needs to be updated. The specific changes include: - Refactored add_LOTW_BBL_diffusivity, add_MLrad_diffusivity, and set_BBL_TKE to work in units of layer vertical extent rather than layer thickness to give results in non-Boussinesq mode that avoid dependence on the Boussinesq reference density. - Work with internal variables in vertical distances in the denominator of diffusive flux calculations in find_TKE_to_Kd, while other expressions in this routine are recast in terms of thicknesses to avoid conversions. - Use tv%SpV_avg instead of 1/RHO_0 in find_TKE_to_Kd when in fully non-Boussinesq mode. - Use layer target density differences in place of g_prime in set_density_ratios in mathematically equivalent expressions when non-Boussinesq. - Use thickness_to_dz in 3 places to convert layer thicknesses into vertical distances. - The thickness argument to add_MLrad_diffusivity (in [H ~> m or kg m-2]) has been replaced with a vertical extent argument (in [Z ~> m]). - Use fluxes%tau_mag in place of fluxes%ustar in add_MLrad_diffusivity when in non-Boussinesq or semi-Boussinesq mode. There is a new thermo_var_ptrs type argument to the internal routine add_MLrad_diffusivity to permit this changes. - Use the in situ near-bottom density when adding certain contributions to non-Boussinesq diffusivities. This change includes the addition of a new bottom density (rho_bot) argument to add_int_tide_diffusivity, add_LOTW_BBL_diffusivity and add_drag_diffusivity. - Use GV%dZ_subroundoff in 4 spots in place of GV%H_to_Z*GV%H_subroundoff. - A long-standing comment questioning whether there is double-counting of tidal mixing has been addressed (there is not) and the comment has been revised accordingly. These changes involved changing the units of 21 internal variables and 1 element in the set_diffusivity_CS type. There are 11 new internal variables, while 9 internal variables were eliminated. A total of 44 thickness rescaling factors were eliminated, and there are 2 places where GV%Rho_0 was being used explicitly that were changed into equivalent rescaling factors. All answers are bitwise identical in Boussinesq mode, but some solutions will change in non-Boussinesq mode with this commit. --- .../vertical/MOM_set_diffusivity.F90 | 341 ++++++++++-------- 1 file changed, 200 insertions(+), 141 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 2aac478086..c792f5200e 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -80,8 +80,8 @@ module MOM_set_diffusivity real :: cdrag !< quadratic drag coefficient [nondim] real :: dz_BBL_avg_min !< A minimal distance over which to average to determine the average !! bottom boundary layer density [Z ~> m] - real :: IMax_decay !< inverse of a maximum decay scale for - !! bottom-drag driven turbulence [Z-1 ~> m-1]. + real :: IMax_decay !< Inverse of a maximum decay scale for + !! bottom-drag driven turbulence [H-1 ~> m-1 or m2 kg-1]. real :: Kv !< The interior vertical viscosity [H Z T-1 ~> m2 s-1 or Pa s] real :: Kd !< interior diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_min !< minimum diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -505,8 +505,9 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif ! Add the ML_Rad diffusivity. - if (CS%ML_radiation) & - call add_MLrad_diffusivity(h, fluxes, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + if (CS%ML_radiation) then + call add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int_2d, G, GV, US, CS, TKE_to_Kd, Kd_lay_2d) + endif ! Add the Nikurashin and / or tidal bottom-driven mixing if (CS%use_tidal_mixing) & @@ -517,11 +518,11 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i ! This adds the diffusion sustained by the energy extracted from the flow by the bottom drag. if (CS%bottomdraglaw .and. (CS%BBL_effic > 0.0)) then if (CS%use_LOTW_BBL_diffusivity) then - call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int_2d, G, GV, US, CS, & - dd%Kd_BBL, Kd_lay_2d) + call add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int_2d, & + G, GV, US, CS, dd%Kd_BBL, Kd_lay_2d) else call add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, & - maxTKE, kb, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) + maxTKE, kb, rho_bot, G, GV, US, CS, Kd_lay_2d, Kd_int_2d, dd%Kd_BBL) endif endif @@ -567,7 +568,7 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i if (associated(dd%Kd_work)) then do k=1,nz ; do i=is,ie - dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * GV%H_to_Z*h(i,j,k) ! Watt m-2 s = kg s-3 + dd%Kd_Work(i,j,k) = GV%H_to_RZ * Kd_lay_2d(i,k) * N2_lay(i,k) * dz(i,k) ! Watt m-2 = kg s-3 enddo ; enddo endif @@ -697,27 +698,30 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & ! across an interface times the difference across the ! interface above it [nondim] rho_0, & ! Layer potential densities relative to surface pressure [R ~> kg m-3] + dz, & ! Height change across layers [Z ~> m] maxEnt ! maxEnt is the maximum value of entrainment from below (with ! compensating entrainment from above to keep the layer ! density from changing) that will not deplete all of the - ! layers above or below a layer within a timestep [Z ~> m]. + ! layers above or below a layer within a timestep [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [Z ~> m]. + ! integrated thickness in the BBL [H ~> m or kg m-2]. + mFkb, & ! total thickness in the mixed and buffer layers times ds_dsp1 [H ~> m or kg m-2] p_ref, & ! array of tv%P_Ref pressures [R L2 T-2 ~> Pa] Rcv_kmb, & ! coordinate density in the lowest buffer layer [R ~> kg m-3] p_0 ! An array of 0 pressures [R L2 T-2 ~> Pa] real :: dh_max ! maximum amount of entrainment a layer could undergo before - ! entraining all fluid in the layers above or below [Z ~> m]. + ! entraining all fluid in the layers above or below [H ~> m or kg m-2] real :: dRho_lay ! density change across a layer [R ~> kg m-3] real :: Omega2 ! rotation rate squared [T-2 ~> s-2] - real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density [Z T-2 R-1 ~> m4 s-2 kg-1] - real :: G_IRho0 ! Alternate calculation of G_Rho0 for reproducibility [Z T-2 R-1 ~> m4 s-2 kg-1] - real :: I_Rho0 ! inverse of Boussinesq reference density [R-1 ~> m3 kg-1] + real :: grav ! Gravitational acceleration [Z T-1 ~> m s-2] + real :: G_Rho0 ! Gravitational acceleration divided by Boussinesq reference density + ! [Z R-1 T-2 ~> m4 s-2 kg-1] + real :: G_IRho0 ! Alternate calculation of G_Rho0 with thickness rescaling factors + ! [Z2 T-2 R-1 H-1 ~> m4 s-2 kg-1 or m7 kg-2 s-2] real :: I_dt ! 1/dt [T-1 ~> s-1] - real :: H_neglect ! negligibly small thickness [H ~> m or kg m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] real :: hN2pO2 ! h (N^2 + Omega^2), in [Z T-2 ~> m s-2]. logical :: do_i(SZI_(G)) @@ -727,22 +731,25 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & I_dt = 1.0 / dt Omega2 = CS%omega**2 - H_neglect = GV%H_subroundoff - G_Rho0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + dz_neglect = GV%dZ_subroundoff + grav = (US%L_to_Z**2 * GV%g_Earth) + G_Rho0 = grav / GV%Rho0 if (CS%answer_date < 20190101) then - I_Rho0 = 1.0 / (GV%Rho0) - G_IRho0 = (US%L_to_Z**2 * GV%g_Earth) * I_Rho0 + G_IRho0 = grav * GV%H_to_Z**2 * GV%RZ_to_H else - G_IRho0 = G_Rho0 + G_IRho0 = GV%H_to_Z*G_Rho0 endif + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + ! Simple but coordinate-independent estimate of Kd/TKE if (CS%simple_TKE_to_Kd) then do k=1,nz ; do i=is,ie - hN2pO2 = (GV%H_to_Z * h(i,j,k)) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. - if (hN2pO2>0.) then - TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 Z-1. - else; TKE_to_Kd(i,k) = 0.; endif + hN2pO2 = dz(i,k) * (N2_lay(i,k) + Omega2) ! Units of Z T-2. + if (hN2pO2 > 0.) then + TKE_to_Kd(i,k) = 1.0 / hN2pO2 ! Units of T2 H-1. + else ; TKE_to_Kd(i,k) = 0. ; endif ! The maximum TKE conversion we allow is really a statement ! about the upper diffusivity we allow. Kd_max must be set. maxTKE(i,k) = hN2pO2 * CS%Kd_max ! Units of H Z2 T-3. @@ -793,18 +800,17 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & if (CS%bulkmixedlayer) then kmb = GV%nk_rho_varies do i=is,ie - htot(i) = GV%H_to_Z*h(i,j,kmb) + htot(i) = h(i,j,kmb) mFkb(i) = 0.0 - if (kb(i) < nz) & - mFkb(i) = ds_dsp1(i,kb(i)) * (GV%H_to_Z*(h(i,j,kmb) - GV%Angstrom_H)) + if (kb(i) < nz) mFkb(i) = ds_dsp1(i,kb(i)) * (h(i,j,kmb) - GV%Angstrom_H) enddo do k=1,kmb-1 ; do i=is,ie - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H)) + htot(i) = htot(i) + h(i,j,k) + mFkb(i) = mFkb(i) + ds_dsp1(i,k+1)*(h(i,j,k) - GV%Angstrom_H) enddo ; enddo else do i=is,i - maxEnt(i,1) = 0.0 ; htot(i) = GV%H_to_Z*(h(i,j,1) - GV%Angstrom_H) + maxEnt(i,1) = 0.0 ; htot(i) = h(i,j,1) - GV%Angstrom_H enddo endif do k=kb_min,nz-1 ; do i=is,ie @@ -816,12 +822,12 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & else maxEnt(i,k) = ds_dsp1(i,k)*(maxEnt(i,k-1) + htot(i)) endif - htot(i) = htot(i) + GV%H_to_Z*(h(i,j,k) - GV%Angstrom_H) + htot(i) = htot(i) + (h(i,j,k) - GV%Angstrom_H) endif enddo ; enddo do i=is,ie - htot(i) = GV%H_to_Z*(h(i,j,nz) - GV%Angstrom_H) ; maxEnt(i,nz) = 0.0 + htot(i) = h(i,j,nz) - GV%Angstrom_H ; maxEnt(i,nz) = 0.0 do_i(i) = (G%mask2dT(i,j) > 0.0) enddo do k=nz-1,kb_min,-1 @@ -829,8 +835,8 @@ subroutine find_TKE_to_Kd(h, tv, dRho_int, N2_lay, j, dt, G, GV, US, CS, & do i=is,ie ; if (do_i(i)) then if (k This routine adds diffusion sustained by flow energy extracted by bottom drag. subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, & - kb, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) + kb, rho_bot, G, GV, US, CS, Kd_lay, Kd_int, Kd_BBL) 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 @@ -1171,6 +1183,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, !! maximum-realizable thickness [H Z2 T-3 ~> m3 s-3 or W m-2] integer, dimension(SZI_(G)), intent(in) :: kb !< Index of lightest layer denser than the buffer !! layer, or -1 without a bulk mixed layer + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure real, dimension(SZI_(G),SZK_(GV)), intent(inout) :: Kd_lay !< The diapycnal diffusivity in layers, !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -1185,23 +1199,24 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, Rint ! coordinate density of an interface [R ~> kg m-3] real, dimension(SZI_(G)) :: & htot, & ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. - rho_htot, & ! running integral with depth of density [R Z ~> kg m-2] + ! integrated thickness in the BBL [H ~> m or kg m-2]. + rho_htot, & ! running integral with depth of density [R H ~> kg m-2 or kg2 m-5] gh_sum_top, & ! BBL value of g'h that can be supported by - ! the local ustar, times R0_g [R Z ~> kg m-2] + ! the local ustar, times R0_g [R H ~> kg m-2 or kg2 m-5] Rho_top, & ! density at top of the BBL [R ~> kg m-3] TKE, & ! turbulent kinetic energy available to drive ! bottom-boundary layer mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] - I2decay ! inverse of twice the TKE decay scale [Z-1 ~> m-1]. + I2decay ! inverse of twice the TKE decay scale [H-1 ~> m-1 or m2 kg-1]. real :: TKE_to_layer ! TKE used to drive mixing in a layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_Ray ! TKE from layer Rayleigh drag used to drive mixing in layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_here ! TKE that goes into mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: dRl, dRbot ! temporaries holding density differences [R ~> kg m-3] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar_h ! value of ustar at a thickness point [Z T-1 ~> m s-1]. + real :: ustar_h ! Ustar at a thickness point rescaled into thickness + ! flux units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: absf ! average absolute Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: R0_g ! Rho0 / G_Earth [R T2 Z-1 ~> kg s2 m-4] + real :: R0_g ! Rho0 / G_Earth [R T2 H-1 ~> kg s2 m-4 or s2 m-1] real :: delta_Kd ! increment to Kd from the bottom boundary layer mixing [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical :: Rayleigh_drag ! Set to true if Rayleigh drag velocities ! defined in visc, on the assumption that this @@ -1221,7 +1236,7 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, TKE_Ray = 0.0 ; Rayleigh_drag = .false. if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. - R0_g = GV%Rho0 / (US%L_to_Z**2 * GV%g_Earth) + R0_g = GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth) do K=2,nz ; Rint(K) = 0.5*(GV%Rlay(k-1)+GV%Rlay(k)) ; enddo @@ -1231,9 +1246,14 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! Any turbulence that makes it into the mixed layers is assumed ! to be relatively small and is discarded. do i=is,ie - ustar_h = GV%H_to_Z*visc%ustar_BBL(i,j) - if (associated(fluxes%ustar_tidal)) & - ustar_h = ustar_h + fluxes%ustar_tidal(i,j) + ustar_h = visc%ustar_BBL(i,j) + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar_h = ustar_h + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar_h = ustar_h + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) if ((ustar_h > 0.0) .and. (absf > 0.5*CS%IMax_decay*ustar_h)) then @@ -1243,12 +1263,11 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, ! If ustar_h = 0, this is land so this value doesn't matter. I2decay(i) = 0.5*CS%IMax_decay endif - TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz))) ) * & - visc%TKE_BBL(i,j) + TKE(i) = ((CS%BBL_effic * cdrag_sqrt) * exp(-I2decay(i)*h(i,j,nz)) ) * visc%TKE_BBL(i,j) if (associated(fluxes%TKE_tidal)) & TKE(i) = TKE(i) + fluxes%TKE_tidal(i,j) * GV%RZ_to_H * & - (CS%BBL_effic * exp(-I2decay(i)*(GV%H_to_Z*h(i,j,nz)))) + (CS%BBL_effic * exp(-I2decay(i)*h(i,j,nz))) ! Distribute the work over a BBL of depth 20^2 ustar^2 / g' following ! Killworth & Edwards (1999) and Zilitikevich & Mironov (1996). @@ -1258,16 +1277,16 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, gh_sum_top(i) = R0_g * 400.0 * ustar_h**2 do_i(i) = (G%mask2dT(i,j) > 0.0) - htot(i) = GV%H_to_Z*h(i,j,nz) - rho_htot(i) = GV%Rlay(nz)*(GV%H_to_Z*h(i,j,nz)) + htot(i) = h(i,j,nz) + rho_htot(i) = GV%Rlay(nz)*(h(i,j,nz)) Rho_top(i) = GV%Rlay(1) if (CS%bulkmixedlayer .and. do_i(i)) Rho_top(i) = GV%Rlay(kb(i)-1) enddo do k=nz-1,2,-1 ; domore = .false. do i=is,ie ; if (do_i(i)) then - htot(i) = htot(i) + GV%H_to_Z*h(i,j,k) - rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(GV%H_to_Z*h(i,j,k)) + htot(i) = htot(i) + h(i,j,k) + rho_htot(i) = rho_htot(i) + GV%Rlay(k)*(h(i,j,k)) if (htot(i)*GV%Rlay(k-1) <= (rho_htot(i) - gh_sum_top(i))) then ! The top of the mixing is in the interface atop the current layer. Rho_top(i) = (rho_htot(i) - gh_sum_top(i)) / htot(i) @@ -1286,9 +1305,8 @@ subroutine add_drag_diffusivity(h, u, v, tv, fluxes, visc, j, TKE_to_Kd, maxTKE, i_rem = i_rem + 1 ! Count the i-rows that are still being worked on. ! Apply vertical decay of the turbulent energy. This energy is ! simply lost. - TKE(i) = TKE(i) * exp(-I2decay(i) * (GV%H_to_Z*(h(i,j,k) + h(i,j,k+1)))) + TKE(i) = TKE(i) * exp(-I2decay(i) * (h(i,j,k) + h(i,j,k+1))) -! if (maxEnt(i,k) <= 0.0) cycle if (maxTKE(i,k) <= 0.0) cycle ! This is an analytic integral where diffusivity is a quadratic function of @@ -1377,7 +1395,7 @@ end subroutine add_drag_diffusivity !> Calculates a BBL diffusivity use a Prandtl number 1 diffusivity with a law of the !! wall turbulent viscosity, up to a BBL height where the energy used for mixing has !! consumed the mechanical TKE input. -subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int, & +subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Rho_bot, Kd_int, & G, GV, US, CS, Kd_BBL, Kd_lay) type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -1396,6 +1414,8 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int integer, intent(in) :: j !< j-index of row to work on real, dimension(SZI_(G),SZK_(GV)+1), & intent(in) :: N2_int !< Square of Brunt-Vaisala at interfaces [T-2 ~> s-2] + real, dimension(SZI_(G)), intent(in) :: rho_bot !< In situ density averaged over a near-bottom + !! region [R ~> kg m-3] real, dimension(SZI_(G),SZK_(GV)+1), & intent(inout) :: Kd_int !< Interface net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(set_diffusivity_CS), pointer :: CS !< Diffusivity control structure @@ -1404,26 +1424,29 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int optional, intent(inout) :: Kd_lay !< Layer net diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables + real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] real :: TKE_column ! net TKE input into the column [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_remaining ! remaining TKE available for mixing in this layer and above [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_consumed ! TKE used for mixing in this layer [H Z2 T-3 ~> m3 s-3 or W m-2] real :: TKE_Kd_wall ! TKE associated with unlimited law of the wall mixing [H Z2 T-3 ~> m3 s-3 or W m-2] real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: ustar ! value of ustar at a thickness point [Z T-1 ~> m s-1]. - real :: ustar2 ! square of ustar, for convenience [Z2 T-2 ~> m2 s-2] + real :: ustar ! value of ustar at a thickness point [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: ustar2 ! The square of ustar [H2 T-2 ~> m2 s-2 or kg2 m-4 s-2] real :: absf ! average absolute value of Coriolis parameter around a thickness point [T-1 ~> s-1] - real :: dh, dhm1 ! thickness of layers k and k-1, respectively [Z ~> m]. - real :: z_bot ! distance to interface k from bottom [Z ~> m]. - real :: D_minus_z ! distance to interface k from surface [Z ~> m]. - real :: total_thickness ! total thickness of water column [Z ~> m]. - real :: Idecay ! inverse of decay scale used for "Joule heating" loss of TKE with height [Z-1 ~> m-1]. + real :: dz_int ! Distance between the center of the layers around an interface [Z ~> m] + real :: z_bot ! Distance to interface K from bottom [Z ~> m] + real :: h_bot ! Total thickness between interface K and the bottom [H ~> m or kg m-2] + real :: D_minus_z ! Distance between interface k and the surface [Z ~> m] + real :: total_depth ! Total distance between the seafloor and the sea surface [Z ~> m] + real :: Idecay ! Inverse of decay scale used for "Joule heating" loss of TKE with + ! height [H-1 ~> m-1 or m2 kg-1]. real :: Kd_wall ! Law of the wall diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: Kd_lower ! diffusivity for lower interface [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real :: ustar_D ! u* x D [Z2 T-1 ~> m2 s-1]. + real :: ustar_D ! The extent of the water column times u* [H Z T-1 ~> m2 s-1 or Pa s]. real :: N2_min ! Minimum value of N2 to use in calculation of TKE_Kd_wall [T-2 ~> s-2] logical :: Rayleigh_drag ! Set to true if there are Rayleigh drag velocities defined in visc, on ! the assumption that this extracted energy also drives diapycnal mixing. - integer :: i, k, km1 + integer :: i, k logical :: do_diag_Kd_BBL if (.not.(CS%bottomdraglaw .and. (CS%BBL_effic > 0.0))) return @@ -1437,19 +1460,28 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) Rayleigh_drag = .true. cdrag_sqrt = sqrt(CS%cdrag) + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=G%isc,G%iec ! Developed in single-column mode ! Column-wise parameters. absf = 0.25 * ((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & (abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J-1)))) ! Non-zero on equator! - ! u* at the bottom [Z T-1 ~> m s-1]. - ustar = GV%H_to_Z*visc%ustar_BBL(i,j) + ! u* at the bottom [H T-1 ~> m s-1 or kg m-2 s-1]. + ustar = visc%ustar_BBL(i,j) ustar2 = ustar**2 - ! In add_drag_diffusivity(), fluxes%ustar_tidal is added in. This might be double counting - ! since ustar_BBL should already include all contributions to u*? -AJA - !### Examine the question of whether there is double counting of fluxes%ustar_tidal. - if (associated(fluxes%ustar_tidal)) ustar = ustar + fluxes%ustar_tidal(i,j) + ! In add_drag_diffusivity(), fluxes%ustar_tidal is also added in. There is no + ! double-counting because the logic surrounding the calls to add_drag_diffusivity() + ! and add_LOTW_BBL_diffusivity() only calls one of the two routines. + if (associated(fluxes%ustar_tidal)) then + if (allocated(tv%SpV_avg)) then + ustar = ustar + GV%RZ_to_H*rho_bot(i) * fluxes%ustar_tidal(i,j) + else + ustar = ustar + GV%Z_to_H * fluxes%ustar_tidal(i,j) + endif + endif ! The maximum decay scale should be something of order 200 m. We use the smaller of u*/f and ! (IMax_decay)^-1 as the decay scale. If ustar = 0, this is land so this value doesn't matter. @@ -1467,17 +1499,16 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int TKE_column = CS%BBL_effic * TKE_column ! Only use a fraction of the mechanical dissipation for mixing. TKE_remaining = TKE_column - total_thickness = ( sum(h(i,j,:)) + GV%H_subroundoff )* GV%H_to_Z ! Total column thickness [Z ~> m]. - ustar_D = ustar * total_thickness + total_depth = ( sum(dz(i,:)) + GV%dz_subroundoff ) ! Total column thickness [Z ~> m]. + ustar_D = ustar * total_depth + h_bot = 0. z_bot = 0. Kd_lower = 0. ! Diffusivity on bottom boundary. ! Work upwards from the bottom, accumulating work used until it exceeds the available TKE input ! at the bottom. - do k=GV%ke,2,-1 - dh = GV%H_to_Z * h(i,j,k) ! Thickness of this level [Z ~> m]. - km1 = max(k-1, 1) - dhm1 = GV%H_to_Z * h(i,j,km1) ! Thickness of level above [Z ~> m]. + do K=GV%ke,2,-1 + dz_int = 0.5 * (dz(i,k-1) + dz(i,k)) ! Add in additional energy input from bottom-drag against slopes (sides) if (Rayleigh_drag) TKE_remaining = TKE_remaining + & @@ -1489,23 +1520,24 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int ! Exponentially decay TKE across the thickness of the layer. ! This is energy loss in addition to work done as mixing, apparently to Joule heating. - TKE_remaining = exp(-Idecay*dh) * TKE_remaining + TKE_remaining = exp(-Idecay*h(i,j,k)) * TKE_remaining - z_bot = z_bot + h(i,j,k)*GV%H_to_Z ! Distance between upper interface of layer and the bottom [Z ~> m]. - D_minus_z = max(total_thickness - z_bot, 0.) ! Thickness above layer [Z ~> m]. + z_bot = z_bot + dz(i,k) ! Distance between upper interface of layer and the bottom [Z ~> m]. + h_bot = h_bot + h(i,j,k) ! Thickness between upper interface of layer and the bottom [H ~> m or kg m-2]. + D_minus_z = max(total_depth - z_bot, 0.) ! Thickness above layer [H ~> m or kg m-2]. - ! Diffusivity using law of the wall, limited by rotation, at height z [Z2 T-1 ~> m2 s-1]. + ! Diffusivity using law of the wall, limited by rotation, at height z [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This calculation is at the upper interface of the layer - if ( ustar_D + absf * ( z_bot * D_minus_z ) == 0.) then + if ( ustar_D + absf * ( h_bot * D_minus_z ) == 0.) then Kd_wall = 0. else - Kd_wall = ((GV%Z_to_H*CS%von_karm * ustar2) * (z_bot * D_minus_z)) & - / (ustar_D + absf * (z_bot * D_minus_z)) + Kd_wall = ((CS%von_karm * ustar2) * (z_bot * D_minus_z)) & + / (ustar_D + absf * (h_bot * D_minus_z)) endif ! TKE associated with Kd_wall [H Z2 T-3 ~> m3 s-3 or W m-2]. - ! This calculation if for the volume spanning the interface. - TKE_Kd_wall = Kd_wall * 0.5 * (dh + dhm1) * max(N2_int(i,k), N2_min) + ! This calculation is for the volume spanning the interface. + TKE_Kd_wall = Kd_wall * dz_int * max(N2_int(i,K), N2_min) ! Now bound Kd such that the associated TKE is no greater than available TKE for mixing. if (TKE_Kd_wall > 0.) then @@ -1535,13 +1567,14 @@ subroutine add_LOTW_BBL_diffusivity(h, u, v, tv, fluxes, visc, j, N2_int, Kd_int end subroutine add_LOTW_BBL_diffusivity !> This routine adds effects of mixed layer radiation to the layer diffusivities. -subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) +subroutine add_MLrad_diffusivity(dz, fluxes, tv, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Kd_lay) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure 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] + real, dimension(SZI_(G),SZK_(GV)), intent(in) :: dz !< Height change across layers [Z ~> m] type(forcing), intent(in) :: fluxes !< Surface fluxes structure + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. integer, intent(in) :: j !< The j-index to work on real, dimension(SZI_(G),SZK_(GV)+1), intent(inout) :: Kd_int !< The diapycnal diffusivity at interfaces !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] @@ -1557,24 +1590,26 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, ! This routine adds effects of mixed layer radiation to the layer diffusivities. - real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m]. + real, dimension(SZI_(G)) :: h_ml ! Mixed layer thickness [Z ~> m] real, dimension(SZI_(G)) :: TKE_ml_flux ! Mixed layer TKE flux [H Z2 T-3 ~> m3 s-3 or W m-2] - real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. + real, dimension(SZI_(G)) :: I_decay ! A decay rate [Z-1 ~> m-1]. real, dimension(SZI_(G)) :: Kd_mlr_ml ! Diffusivities associated with mixed layer radiation ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: f_sq ! The square of the local Coriolis parameter or a related variable [T-2 ~> s-2]. - real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2]. + real :: h_ml_sq ! The square of the mixed layer thickness [Z2 ~> m2] + real :: u_star_H ! ustar converted to thickness based units [H T-1 ~> m s-1 or kg m-2 s-1] real :: ustar_sq ! ustar squared [Z2 T-2 ~> m2 s-2] real :: Kd_mlr ! A diffusivity associated with mixed layer turbulence radiation ! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + real :: I_rho ! The inverse of the reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] real :: C1_6 ! 1/6 [nondim] real :: Omega2 ! rotation rate squared [T-2 ~> s-2]. real :: z1 ! layer thickness times I_decay [nondim] - real :: dzL ! thickness converted to heights [Z ~> m]. - real :: I_decay_len2_TKE ! squared inverse decay lengthscale for - ! TKE, as used in the mixed layer code [Z-2 ~> m-2]. - real :: h_neglect ! negligibly small thickness [Z ~> m]. + real :: I_decay_len2_TKE ! Squared inverse decay lengthscale for TKE from the bulk mixed + ! layer code [Z-2 ~> m-2] + real :: dz_neglect ! A negligibly small height change [Z ~> m] logical :: do_any, do_i(SZI_(G)) integer :: i, k, is, ie, nz, kml @@ -1583,12 +1618,13 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, Omega2 = CS%omega**2 C1_6 = 1.0 / 6.0 kml = GV%nkml - h_neglect = GV%H_subroundoff*GV%H_to_Z + dz_neglect = GV%dz_subroundoff + I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. if (.not.CS%ML_radiation) return do i=is,ie ; h_ml(i) = 0.0 ; do_i(i) = (G%mask2dT(i,j) > 0.0) ; enddo - do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + GV%H_to_Z*h(i,j,k) ; enddo ; enddo + do k=1,kml ; do i=is,ie ; h_ml(i) = h_ml(i) + dz(i,k) ; enddo ; enddo do i=is,ie ; if (do_i(i)) then if (CS%ML_omega_frac >= 1.0) then @@ -1600,21 +1636,31 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, f_sq = CS%ML_omega_frac * 4.0 * Omega2 + (1.0 - CS%ML_omega_frac) * f_sq endif - ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 - - TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * (GV%Z_to_H*fluxes%ustar(i,j))) + ! Determine the energy flux out of the mixed layer and its vertical decay scale. + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + ustar_sq = max(fluxes%ustar(i,j), CS%ustar_min)**2 + u_star_H = GV%Z_to_H * fluxes%ustar(i,j) + elseif (allocated(tv%SpV_avg)) then + ustar_sq = max(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1), CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) / tv%SpV_avg(i,j,1)) + else ! This semi-Boussinesq form is mathematically equivalent to the Boussinesq version above. + ! Differs at roundoff: ustar_sq = max(fluxes%tau_mag(i,j) * I_rho, CS%ustar_min**2) + ustar_sq = max((sqrt(fluxes%tau_mag(i,j) * I_rho))**2, CS%ustar_min**2) + u_star_H = GV%RZ_to_H * sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * GV%Rho0) + endif + TKE_ml_flux(i) = (CS%mstar * CS%ML_rad_coeff) * (ustar_sq * u_star_H) I_decay_len2_TKE = CS%TKE_decay**2 * (f_sq / ustar_sq) if (CS%ML_rad_TKE_decay) & TKE_ml_flux(i) = TKE_ml_flux(i) * exp(-h_ml(i) * sqrt(I_decay_len2_TKE)) ! Calculate the inverse decay scale - h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+h_neglect))**2 + h_ml_sq = (CS%ML_rad_efold_coeff * (h_ml(i)+dz_neglect))**2 I_decay(i) = sqrt((I_decay_len2_TKE * h_ml_sq + 1.0) / h_ml_sq) ! Average the dissipation layer kml+1, using ! a more accurate Taylor series approximations for very thin layers. - z1 = (GV%H_to_Z*h(i,j,kml+1)) * I_decay(i) + z1 = dz(i,kml+1) * I_decay(i) if (z1 > 1e-5) then Kd_mlr = TKE_ml_flux(i) * TKE_to_Kd(i,kml+1) * (1.0 - exp(-z1)) else @@ -1639,14 +1685,14 @@ subroutine add_MLrad_diffusivity(h, fluxes, j, Kd_int, G, GV, US, CS, TKE_to_Kd, do k=kml+2,nz-1 do_any = .false. do i=is,ie ; if (do_i(i)) then - dzL = GV%H_to_Z*h(i,j,k) ; z1 = dzL*I_decay(i) + z1 = dz(i,k)*I_decay(i) if (CS%ML_Rad_bug) then ! These expressions are dimensionally inconsistent. -RWH ! This is supposed to be the integrated energy deposited in the layer, ! not the average over the layer as in these expressions. if (z1 > 1e-5) then Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 - US%m_to_Z * ((1.0 - exp(-z1)) / dzL) ! Units of m-1 + US%m_to_Z * ((1.0 - exp(-z1)) / dz(i,k)) ! Units of m-1 else Kd_mlr = (TKE_ml_flux(i) * TKE_to_Kd(i,k)) * & ! Units of H Z T-1 US%m_to_Z * (I_decay(i) * (1.0 - z1 * (0.5 - C1_6*z1))) ! Units of m-1 @@ -1698,23 +1744,23 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! boundary layer turbulence. real, dimension(SZI_(G)) :: & - htot ! total thickness above or below a layer, or the - ! integrated thickness in the BBL [Z ~> m]. + htot ! Running sum of the depth in the BBL [Z ~> m]. real, dimension(SZIB_(G)) :: & uhtot, & ! running integral of u in the BBL [Z L T-1 ~> m2 s-1] - ustar, & ! bottom boundary layer turbulence speed [Z T-1 ~> m s-1]. + ustar, & ! bottom boundary layer piston velocity [H T-1 ~> m s-1 or kg m-2 s-1]. u2_bbl ! square of the mean zonal velocity in the BBL [L2 T-2 ~> m2 s-2] real :: vhtot(SZI_(G)) ! running integral of v in the BBL [Z L T-1 ~> m2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & - vstar, & ! ustar at at v-points [Z T-1 ~> m s-1]. + vstar, & ! ustar at at v-points [H T-1 ~> m s-1 or kg m-2 s-1]. v2_bbl ! square of average meridional velocity in BBL [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz ! The vertical distance between interfaces around a layer [Z ~> m] - real :: cdrag_sqrt ! square root of the drag coefficient [nondim] - real :: I_cdrag_sqrt ! The inverse of the square root of the drag coefficient [nondim] - real :: hvel ! thickness at velocity points [Z ~> m]. + real :: cdrag_sqrt ! Square root of the drag coefficient [nondim] + real :: hvel ! thickness at velocity points [Z ~> m] logical :: domore, do_i(SZI_(G)) integer :: i, j, k, is, ie, js, je, nz @@ -1748,7 +1794,9 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) endif cdrag_sqrt = sqrt(CS%cdrag) - I_cdrag_sqrt = 0.0 ; if (cdrag_sqrt > 0.0) I_cdrag_sqrt = 1.0 / cdrag_sqrt + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) !$OMP parallel default(shared) private(do_i,vhtot,htot,domore,hvel,uhtot,ustar,u2_bbl) !$OMP do @@ -1761,7 +1809,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%Kv_bbl_v)) then do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_v(i,J) > 0.0)) then do_i(i) = .true. - vstar(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) + vstar(i,J) = visc%Kv_bbl_v(i,J) / (cdrag_sqrt*visc%bbl_thick_v(i,J)) endif ; enddo endif !### What about terms from visc%Ray? @@ -1781,12 +1829,12 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! Compute h based on OBC state if (has_obc) then if (OBC%segment(l_seg)%direction == OBC_DIRECTION_N) then - hvel = GV%H_to_Z*h(i,j,k) + hvel = dz(i,j,k) else - hvel = GV%H_to_Z*h(i,j+1,k) + hvel = dz(i,j+1,k) endif else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i,j+1,k)) + hvel = 0.5*(dz(i,j,k) + dz(i,j+1,k)) endif if ((htot(i) + hvel) >= visc%bbl_thick_v(i,J)) then @@ -1802,7 +1850,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (.not.domore) exit enddo do i=is,ie ; if ((G%mask2dCv(i,J) > 0.0) .and. (htot(i) > 0.0)) then - v2_bbl(i,J) = (vhtot(i)*vhtot(i))/(htot(i)*htot(i)) + v2_bbl(i,J) = (vhtot(i)*vhtot(i)) / (htot(i)*htot(i)) else v2_bbl(i,J) = 0.0 endif ; enddo @@ -1815,7 +1863,7 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (allocated(visc%bbl_thick_u)) then do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (cdrag_sqrt*visc%bbl_thick_u(I,j) > 0.0)) then do_i(I) = .true. - ustar(I) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) + ustar(I) = visc%Kv_bbl_u(I,j) / (cdrag_sqrt*visc%bbl_thick_u(I,j)) endif ; enddo endif @@ -1833,12 +1881,12 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) ! Compute h based on OBC state if (has_obc) then if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then - hvel = GV%H_to_Z*h(i,j,k) + hvel = dz(i,j,k) else ! OBC_DIRECTION_W - hvel = GV%H_to_Z*h(i+1,j,k) + hvel = dz(i+1,j,k) endif else - hvel = 0.5*GV%H_to_Z*(h(i,j,k) + h(i+1,j,k)) + hvel = 0.5*(dz(i,j,k) + dz(i+1,j,k)) endif if ((htot(I) + hvel) >= visc%bbl_thick_u(I,j)) then @@ -1854,18 +1902,18 @@ subroutine set_BBL_TKE(u, v, h, tv, fluxes, visc, G, GV, US, CS, OBC) if (.not.domore) exit enddo do I=is-1,ie ; if ((G%mask2dCu(I,j) > 0.0) .and. (htot(i) > 0.0)) then - u2_bbl(I) = (uhtot(I)*uhtot(I))/(htot(I)*htot(I)) + u2_bbl(I) = (uhtot(I)*uhtot(I)) / (htot(I)*htot(I)) else u2_bbl(I) = 0.0 endif ; enddo do i=is,ie - visc%ustar_BBL(i,j) = GV%Z_to_H*sqrt(0.5*G%IareaT(i,j) * & + visc%ustar_BBL(i,j) = sqrt(0.5*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*(ustar(I-1)*ustar(I-1)) + & G%areaCu(I,j)*(ustar(I)*ustar(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*vstar(i,J-1)) + & G%areaCv(i,J)*(vstar(i,J)*vstar(i,J))) ) ) - visc%TKE_BBL(i,j) = GV%Z_to_H*US%L_to_Z**2 * & + visc%TKE_BBL(i,j) = US%L_to_Z**2 * & (((G%areaCu(I-1,j)*(ustar(I-1)*u2_bbl(I-1)) + & G%areaCu(I,j) * (ustar(I)*u2_bbl(I))) + & (G%areaCv(i,J-1)*(vstar(i,J-1)*v2_bbl(i,J-1)) + & @@ -1904,7 +1952,8 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) real :: a(SZK_(GV)), a_0(SZK_(GV)) ! nondimensional temporary variables [nondim] real :: p_ref(SZI_(G)) ! an array of tv%P_Ref pressures [R L2 T-2 ~> Pa] real :: Rcv(SZI_(G),SZK_(GV)) ! coordinate density in the mixed and buffer layers [R ~> kg m-3] - real :: I_Drho ! temporary variable [R-1 ~> m3 kg-1] + real :: I_Drho ! The inverse of the coordinate density difference between + ! layers [R-1 ~> m3 kg-1] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, k, k3, is, ie, nz, kmb @@ -1912,9 +1961,15 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) do k=2,nz-1 if (GV%g_prime(k+1) /= 0.0) then - do i=is,ie - ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) - enddo + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo + endif else do i=is,ie ds_dsp1(i,k) = 1. @@ -1937,7 +1992,11 @@ subroutine set_density_ratios(h, tv, kb, G, GV, US, CS, j, ds_dsp1, rho_0) ! interfaces above and below the buffer layer and the next denser layer. k = kb(i) - I_Drho = g_R0 / GV%g_prime(k+1) + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + I_Drho = g_R0 / GV%g_prime(k+1) + else + I_Drho = 1.0 / (GV%Rlay(k+1) - GV%Rlay(k)) + endif ! The indexing convention for a is appropriate for the interfaces. do k3=1,kmb a(k3+1) = (GV%Rlay(k) - Rcv(i,k3)) * I_Drho @@ -2005,7 +2064,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ !! surface boundary layer. ! Local variables - real :: decay_length ! The maximum decay scale for the BBL diffusion [Z ~> m] + real :: decay_length ! The maximum decay scale for the BBL diffusion [H ~> m or kg m-2] logical :: ML_use_omega 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. @@ -2097,7 +2156,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "length scale.", default=.false.) if (CS%ML_radiation) then ! This give a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%H_subroundoff*GV%H_to_Z) + CS%ustar_min = 2e-4 * CS%omega * (GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "ML_RAD_EFOLD_COEFF", CS%ML_rad_efold_coeff, & "A coefficient that is used to scale the penetration "//& @@ -2161,7 +2220,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ "The maximum decay scale for the BBL diffusion, or 0 to allow the mixing "//& "to penetrate as far as stratification and rotation permit. The default "//& "for now is 200 m. This is only used if BOTTOMDRAGLAW is true.", & - units="m", default=200.0, scale=US%m_to_Z) + units="m", default=200.0, scale=GV%m_to_H) CS%IMax_decay = 0.0 if (decay_length > 0.0) CS%IMax_decay = 1.0/decay_length From 828a1789833e688087e544d408d516bc15ae088e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Aug 2023 03:05:08 -0400 Subject: [PATCH 377/629] *Non-Boussinesq refactoring of entrain_diffusive This commit refactors entrainment_diffusive to avoid any dependencies on the Boussinesq reference density when in non-Boussinesq mode, including using calculate_specific_vol_derivs for one diagnostic when non-Boussinesq. This commit includes making the formerly optional arguments kb_out, Kd_Lay and Kd_int to entrainment_diffusive non-optional, as they have been used in all calls to this routine for many years. Layer target density differences are now used in place of g_prime in entrainment_diffusive in mathematically equivalent expressions for the density difference ratios when non-Boussinesq. The non-Boussinesq upper layer buoyancy flux with entrainment_diffusive was revised to avoid using the Boussinesq reference density when the model is in layered mode but there is no equation of state or bulk mixed layer in use. The units of 3 internal variables were changed and there are 3 new internal variables as a part of these changes, and 4 thickness rescaling factors were eliminated. A default private setting is used to simplify a block of OMP directives. All answers are bitwise identical in Boussinesq mode, but they can change for some non-Boussinesq configurations, and three previously optional arguments have been made mandatory. --- .../vertical/MOM_entrain_diffusive.F90 | 182 ++++++++++-------- 1 file changed, 105 insertions(+), 77 deletions(-) diff --git a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 index c30f5c2c3f..de13322652 100644 --- a/src/parameterizations/vertical/MOM_entrain_diffusive.F90 +++ b/src/parameterizations/vertical/MOM_entrain_diffusive.F90 @@ -5,14 +5,15 @@ module MOM_entrain_diffusive use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_EOS, only : calculate_density, calculate_density_derivs +use MOM_EOS, only : calculate_specific_vol_derivs, EOS_domain use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +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 implicit none ; private @@ -73,14 +74,13 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & intent(out) :: eb !< The amount of fluid entrained from the layer !! below within this time step [H ~> m or kg m-2]. integer, dimension(SZI_(G),SZJ_(G)), & - optional, intent(inout) :: kb_out !< The index of the lightest layer denser than + intent(inout) :: kb_out !< The index of the lightest layer denser than !! the buffer layer. - ! At least one of the two following arguments must be present. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers + intent(in) :: Kd_Lay !< The diapycnal diffusivity of layers !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces + intent(in) :: Kd_int !< The diapycnal diffusivity of interfaces !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. ! This subroutine calculates ea and eb, the rates at which a layer entrains @@ -112,7 +112,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real, allocatable, dimension(:,:,:) :: & Kd_eff, & ! The effective diffusivity that actually applies to each ! layer after the effects of boundary conditions are - ! considered [Z2 T-1 ~> m2 s-1]. + ! considered [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. diff_work ! The work actually done by diffusion across each ! interface [R Z3 T-3 ~> W m-2]. Sum vertically for the total work. @@ -174,16 +174,20 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & grats ! 2*(2 + ds_k+1 / ds_k + ds_k / ds_k+1) = ! 4*ds_Lay*(1/ds_k + 1/ds_k+1). [nondim] - real :: dRHo ! The change in locally referenced potential density between - ! the layers above and below an interface [R ~> kg m-3]. + real :: dRho ! The change in locally referenced potential density between + ! the layers above and below an interface [R ~> kg m-3] + real :: dSpV ! The change in locally referenced specific volume between + ! the layers above and below an interface [R-1 ~> m3 kg-1] real :: g_2dt ! 0.5 * G_Earth / dt, times unit conversion factors - ! [Z3 H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + ! [Z3 H-2 T-3 or R2 Z3 H-2 T-3 ~> m s-3]. real, dimension(SZI_(G)) :: & pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_eos, S_eos, & ! The potential temperature and salinity at which to ! evaluate dRho_dT and dRho_dS [C ~> degC] and [S ~> ppt]. - dRho_dT, dRho_dS ! The partial derivatives of potential density with temperature and - ! salinity, [R C-1 ~> kg m-3 degC-1] and [R S-1 ~> kg m-3 ppt-1]. + dRho_dT, & ! The partial derivative of potential density with temperature [R C-1 ~> kg m-3 degC-1] + dRho_dS, & ! The partial derivative of potential density with salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS ! The partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real :: tolerance ! The tolerance within which E must be converged [H ~> m or kg m-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. @@ -199,7 +203,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & real :: ea_cor ! The corrective adjustment to eakb [H ~> m or kg m-2]. real :: h1 ! The layer thickness after entrainment through the ! interface below is taken into account [H ~> m or kg m-2]. - real :: Idt ! The inverse of the time step [T-1 ~> s-1]. + real :: Idt ! The inverse of the time step [Z H-1 T-1 ~> s-1 or m3 kg-1 s-1]. logical :: do_any logical :: do_entrain_eakb ! True if buffer layer is entrained @@ -217,9 +221,6 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & if (.not. CS%initialized) call MOM_error(FATAL, & "MOM_entrain_diffusive: Module must be initialized before it is used.") - if (.not.(present(Kd_Lay) .or. present(Kd_int))) call MOM_error(FATAL, & - "MOM_entrain_diffusive: Either Kd_Lay or Kd_int must be present in call.") - if ((.not.CS%bulkmixedlayer .and. .not.associated(fluxes%buoy)) .and. & (associated(fluxes%lprec) .or. associated(fluxes%evap) .or. & associated(fluxes%sens) .or. associated(fluxes%sw))) then @@ -254,42 +255,33 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif EOSdom(:) = EOS_domain(G%HI) - !$OMP parallel do default(none) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & - !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & - !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & - !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) & - !$OMP private(dtKd,dtKd_int,do_i,Ent_bl,dtKd_kb,h_bl, & - !$OMP I2p2dsp1_ds,grats,htot,max_eakb,I_dSkbp1, & - !$OMP zeros,maxF_kb,maxF,ea_kbp1,eakb,Sref, & - !$OMP maxF_correct,do_any,do_entrain_eakb, & - !$OMP err_min_eakb0,err_max_eakb0,eakb_maxF, & - !$OMP min_eakb,err_eakb0,F,minF,hm,fk,F_kb_maxent,& - !$OMP F_kb,is1,ie1,kb_min_act,dFdfm_kb,b1,dFdfm, & - !$OMP Fprev,fm,fr,c1,reiterate,eb_kmb,did_i, & - !$OMP h_avail,h_guess,dS_kb,Rcv,F_cor,dS_kb_eff, & - !$OMP Rho_cor,ea_cor,h1,Idt,Kd_here,pressure, & - !$OMP T_eos,S_eos,dRho_dT,dRho_dS,dRho,dS_anom_lim) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,Kd_Lay,G,GV,US,dt,CS,h,tv, & + !$OMP kmb,Angstrom,fluxes,K2,h_neglect,tolerance, & + !$OMP ea,eb,Kd_int,Kd_eff,EOSdom,diff_work,g_2dt, kb_out) & + !$OMP firstprivate(kb,ds_dsp1,dsp1_ds,pres,kb_min) do j=js,je do i=is,ie ; kb(i) = 1 ; enddo - if (present(Kd_Lay)) then + if (allocated(tv%SpV_avg)) then do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) + dtKd(i,k) = GV%RZ_to_H * (dt * Kd_lay(i,j,k)) / tv%SpV_avg(i,j,k) enddo ; enddo - if (present(Kd_int)) then - do K=1,nz+1 ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) - enddo ; enddo - else - do K=2,nz ; do i=is,ie - dtKd_int(i,K) = GV%Z_to_H * (0.5 * dt * (Kd_lay(i,j,k-1) + Kd_lay(i,j,k))) - enddo ; enddo - endif - else ! Kd_int must be present, or there already would have been an error. + do i=is,ie + dtKd_int(i,1) = GV%RZ_to_H * (dt * Kd_int(i,j,1)) / tv%SpV_avg(i,j,1) + dtKd_int(i,nz+1) = GV%RZ_to_H * (dt * Kd_int(i,j,nz+1)) / tv%SpV_avg(i,j,nz) + enddo + ! Use the mass-weighted average specific volume to translate thicknesses to verti distances. + do K=2,nz ; do i=is,ie + dtKd_int(i,K) = GV%RZ_to_H * (dt * Kd_int(i,j,K)) * & + ( (h(i,j,k-1) + h(i,j,k) + 2.0*h_neglect) / & + ((h(i,j,k-1)+h_neglect) * tv%SpV_avg(i,j,k-1) + & + (h(i,j,k)+h_neglect) * tv%SpV_avg(i,j,k)) ) + enddo ; enddo + else do k=1,nz ; do i=is,ie - dtKd(i,k) = GV%Z_to_H * (0.5 * dt * (Kd_int(i,j,K)+Kd_int(i,j,K+1))) + dtKd(i,k) = GV%Z_to_H * (dt * Kd_lay(i,j,k)) enddo ; enddo - dO K=1,nz+1 ; do i=is,ie + do K=1,nz+1 ; do i=is,ie dtKd_int(i,K) = GV%Z_to_H * (dt * Kd_int(i,j,K)) enddo ; enddo endif @@ -298,9 +290,15 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & do i=is,ie ; ds_dsp1(i,nz) = 0.0 ; enddo do i=is,ie ; dsp1_ds(i,nz) = 0.0 ; enddo - do k=2,nz-1 ; do i=is,ie - ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) - enddo ; enddo + if (GV%Boussinesq .or. GV%Semi_Boussinesq) then + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = GV%g_prime(k) / GV%g_prime(k+1) + enddo ; enddo + else ! Use a mathematically equivalent form that avoids any dependency on RHO_0. + do k=2,nz-1 ; do i=is,ie + ds_dsp1(i,k) = (GV%Rlay(k) - GV%Rlay(k-1)) / (GV%Rlay(k+1) - GV%Rlay(k)) + enddo ; enddo + endif if (CS%bulkmixedlayer) then ! This subroutine determines the averaged entrainment across each @@ -393,9 +391,16 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & maxF(i,1) = 0.0 htot(i) = h(i,j,1) - Angstrom enddo - if (associated(fluxes%buoy)) then ; do i=is,ie - maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) - enddo ; endif + if (associated(fluxes%buoy) .and. GV%Boussinesq) then + do i=is,ie + maxF(i,1) = GV%Z_to_H * (dt*fluxes%buoy(i,j)) / GV%g_prime(2) + enddo + elseif (associated(fluxes%buoy)) then + do i=is,ie + maxF(i,1) = (GV%RZ_to_H * 0.5*(GV%Rlay(1) + GV%Rlay(2)) * (dt*fluxes%buoy(i,j))) / & + GV%g_prime(2) + enddo + endif endif ! The following code calculates the maximum flux, maxF, for the interior @@ -819,7 +824,7 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & endif ! associated(tv%eqn_of_state)) if (CS%id_Kd > 0) then - Idt = GV%H_to_Z**2 / dt + Idt = (GV%H_to_m*US%m_to_Z) / dt do k=2,nz-1 ; do i=is,ie if (k 0) then - g_2dt = 0.5 * GV%H_to_Z**2*US%L_to_Z**2 * (GV%g_Earth / dt) + if (GV%Boussinesq .or. .not.associated(tv%eqn_of_state)) then + g_2dt = 0.5 * GV%H_to_Z**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + else + g_2dt = 0.5 * GV%H_to_RZ**2 * US%L_to_Z**2 * (GV%g_Earth / dt) + endif do i=is,ie ; diff_work(i,j,1) = 0.0 ; diff_work(i,j,nz+1) = 0.0 ; enddo if (associated(tv%eqn_of_state)) then if (associated(fluxes%p_surf)) then @@ -854,23 +863,44 @@ subroutine entrainment_diffusive(h, tv, fluxes, dt, G, GV, US, CS, ea, eb, & S_eos(i) = 0.5*(tv%S(i,j,k-1) + tv%S(i,j,k)) endif enddo - call calculate_density_derivs(T_EOS, S_EOS, pressure, dRho_dT, dRho_dS, & - tv%eqn_of_state, EOSdom) - do i=is,ie - if ((k>kmb) .and. (kkmb) .and. (kkmb) .and. (k Date: Fri, 18 Aug 2023 16:20:54 -0600 Subject: [PATCH 378/629] Merge latest mom-ocean main (#254) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * 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). * 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 * Add Bodner MLE testing This patch adds the Bodner MLE testing parameters to the tc2.a test. * +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. * 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. * +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. * 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. * 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. * 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. * (*)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. * +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. * +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. * 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. * (*)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. * +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. * *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. * +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. * 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. * *+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. * +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. * (*)+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. * *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. * *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. * +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. * +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. * *+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. * +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. * 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. * *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. * +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. * *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. * +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. * +*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. * Update _Equation_of_State.dox Updated _Equation_of_State.dox to reflect the new options for the equation of state and freezing point calculations. * +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. * +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. * +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. * 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. * Remove FMS1 calls from MOM_domains_infra * 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. * +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. * +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. * +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. * (*)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. * (*)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. * 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. * 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. * 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). * 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. * 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. * +*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. * +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. * *+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. * +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. * +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. * 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. * remove wave_structure broken code * Autoconf: Better Unicode Python support in makedep 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. * 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.) * 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. * 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. * 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.) * 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. * 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. * 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. * Implementation of ZB sheme * Filters for ZB. Regression changed (FGR changed to amplitude) * Rotate test is passed. Regression changed (order of operatrions) * ZB submitted via PR * ZB: Response to the code review * 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. * +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. * 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) * 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. * +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. * +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. * *+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. * 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. * *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. * 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 * Update MOM_variables.F90 --------- Co-authored-by: Alistair Adcroft Co-authored-by: Abigail Bodner Co-authored-by: Marshall Ward Co-authored-by: Robert Hallberg Co-authored-by: Marshall Ward Co-authored-by: Raphael Dussin Co-authored-by: Niki Zadeh Co-authored-by: Pavel Perezhogin Co-authored-by: Matthew Harrison Co-authored-by: Matthew Thompson --- .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 +- .gitlab-ci.yml | 86 +- .gitlab/pipeline-ci-tool.sh | 14 +- .testing/Makefile | 41 +- .testing/tc2.a/MOM_tc_variant | 6 + .testing/tools/parse_fms_clocks.py | 54 +- ac/configure.ac | 87 +- ac/deps/Makefile | 25 +- ac/makedep | 5 +- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 91 +- .../mct_cap/mom_surface_forcing_mct.F90 | 19 +- config_src/drivers/nuopc_cap/mom_cap.F90 | 4 +- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 19 +- .../solo_driver/MESO_surface_forcing.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 139 +- .../solo_driver/user_surface_forcing.F90 | 9 +- config_src/infra/FMS1/MOM_coms_infra.F90 | 24 +- config_src/infra/FMS1/MOM_domain_infra.F90 | 31 +- config_src/infra/FMS1/MOM_interp_infra.F90 | 96 +- config_src/infra/FMS1/MOM_io_infra.F90 | 41 +- config_src/infra/FMS2/MOM_coms_infra.F90 | 23 +- config_src/infra/FMS2/MOM_domain_infra.F90 | 34 +- config_src/infra/FMS2/MOM_interp_infra.F90 | 157 +- config_src/infra/FMS2/MOM_io_infra.F90 | 1067 ++++++------ src/ALE/MOM_ALE.F90 | 14 +- src/ALE/MOM_hybgen_regrid.F90 | 2 +- src/ALE/MOM_regridding.F90 | 24 +- src/ALE/regrid_interp.F90 | 17 +- src/core/MOM.F90 | 145 +- src/core/MOM_PressureForce_FV.F90 | 2 +- src/core/MOM_barotropic.F90 | 30 +- src/core/MOM_checksum_packages.F90 | 6 +- src/core/MOM_density_integrals.F90 | 34 +- src/core/MOM_dynamics_split_RK2.F90 | 54 +- src/core/MOM_forcing_type.F90 | 70 +- src/core/MOM_interface_heights.F90 | 357 +++- src/core/MOM_open_boundary.F90 | 31 +- src/core/MOM_unit_tests.F90 | 6 + src/core/MOM_variables.F90 | 7 +- src/core/MOM_verticalGrid.F90 | 71 +- src/diagnostics/MOM_diagnostics.F90 | 11 +- src/diagnostics/MOM_obsolete_params.F90 | 1 + src/diagnostics/MOM_wave_speed.F90 | 257 ++- src/diagnostics/MOM_wave_structure.F90 | 793 --------- src/equation_of_state/MOM_EOS.F90 | 1442 ++++++++++++++--- src/equation_of_state/MOM_EOS_Jackett06.F90 | 590 +++++++ src/equation_of_state/MOM_EOS_NEMO.F90 | 432 ----- src/equation_of_state/MOM_EOS_Roquet_SpV.F90 | 813 ++++++++++ src/equation_of_state/MOM_EOS_Roquet_rho.F90 | 633 ++++++++ src/equation_of_state/MOM_EOS_TEOS10.F90 | 26 +- src/equation_of_state/MOM_EOS_UNESCO.F90 | 729 ++++++--- src/equation_of_state/MOM_EOS_Wright.F90 | 345 +++- src/equation_of_state/MOM_EOS_Wright_full.F90 | 1033 ++++++++++++ src/equation_of_state/MOM_EOS_Wright_red.F90 | 1033 ++++++++++++ src/equation_of_state/MOM_EOS_linear.F90 | 54 +- src/equation_of_state/MOM_TFreeze.F90 | 97 +- .../MOM_temperature_convert.F90 | 166 ++ src/equation_of_state/_Equation_of_State.dox | 86 +- src/framework/MOM_file_parser.F90 | 8 +- src/framework/MOM_horizontal_regridding.F90 | 41 +- src/framework/MOM_interpolate.F90 | 27 +- src/framework/MOM_io.F90 | 181 ++- src/framework/MOM_io_file.F90 | 28 +- src/framework/MOM_restart.F90 | 4 +- src/framework/MOM_unit_scaling.F90 | 42 +- src/framework/posix.F90 | 51 +- src/framework/posix.h | 16 +- src/ice_shelf/MOM_ice_shelf.F90 | 51 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 19 - .../MOM_coord_initialization.F90 | 8 +- .../MOM_state_initialization.F90 | 562 +++---- .../MOM_tracer_initialization_from_Z.F90 | 14 +- src/ocean_data_assim/MOM_oda_driver.F90 | 15 +- src/parameterizations/lateral/MOM_MEKE.F90 | 52 +- .../lateral/MOM_Zanna_Bolton.F90 | 978 +++++++++++ .../lateral/MOM_hor_visc.F90 | 30 + .../lateral/MOM_internal_tides.F90 | 215 ++- .../lateral/MOM_mixed_layer_restrat.F90 | 851 ++++++++-- .../vertical/MOM_ALE_sponge.F90 | 32 +- .../vertical/MOM_diabatic_aux.F90 | 7 +- .../vertical/MOM_diabatic_driver.F90 | 130 +- .../vertical/MOM_set_viscosity.F90 | 53 +- .../vertical/MOM_vert_friction.F90 | 20 +- src/tracer/MOM_CFC_cap.F90 | 29 +- src/tracer/MOM_neutral_diffusion.F90 | 2 +- src/tracer/MOM_offline_main.F90 | 44 +- src/tracer/MOM_tracer_Z_init.F90 | 17 +- src/tracer/boundary_impulse_tracer.F90 | 4 - src/user/DOME2d_initialization.F90 | 60 +- src/user/DOME_initialization.F90 | 6 +- src/user/ISOMIP_initialization.F90 | 89 +- src/user/Idealized_Hurricane.F90 | 6 +- src/user/MOM_controlled_forcing.F90 | 49 - 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 | 30 +- src/user/dumbbell_initialization.F90 | 50 +- src/user/dumbbell_surface_forcing.F90 | 2 +- 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 +- 119 files changed, 11386 insertions(+), 4078 deletions(-) delete mode 100644 src/diagnostics/MOM_wave_structure.F90 create mode 100644 src/equation_of_state/MOM_EOS_Jackett06.F90 delete mode 100644 src/equation_of_state/MOM_EOS_NEMO.F90 create mode 100644 src/equation_of_state/MOM_EOS_Roquet_SpV.F90 create mode 100644 src/equation_of_state/MOM_EOS_Roquet_rho.F90 create mode 100644 src/equation_of_state/MOM_EOS_Wright_full.F90 create mode 100644 src/equation_of_state/MOM_EOS_Wright_red.F90 create mode 100644 src/equation_of_state/MOM_temperature_convert.F90 create mode 100644 src/parameterizations/lateral/MOM_Zanna_Bolton.F90 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 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..77409d29ef 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 @@ -154,9 +154,9 @@ 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/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) diff --git a/.testing/Makefile b/.testing/Makefile index 8a79d86e0a..b877ecb5f2 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= @@ -331,32 +332,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 @@ -741,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/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. 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=' diff --git a/ac/configure.ac b/ac/configure.ac index dead0579a6..7ea1870816 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 @@ -220,34 +236,56 @@ 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]) # 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]) # 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 +301,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/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: 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()) 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..251f37290d 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 @@ -548,14 +551,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) @@ -621,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. & @@ -671,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] @@ -755,12 +762,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 @@ -775,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 @@ -877,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 @@ -897,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 @@ -911,10 +922,9 @@ 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 + 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 @@ -925,10 +935,9 @@ 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) + 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. & @@ -1021,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. & @@ -1037,15 +1046,18 @@ 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)) + 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 - 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 @@ -1061,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 @@ -1073,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 @@ -1094,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 @@ -1174,17 +1189,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 +1329,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 +1547,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 +1559,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.", & @@ -1612,7 +1627,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' @@ -1622,7 +1637,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..ec5dab57a7 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) @@ -771,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 @@ -796,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 @@ -817,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 @@ -1292,7 +1299,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 +1309,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_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 2841c7196c..120078b11e 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/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 index b921f7355d..054d42a084 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_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 @@ -142,8 +143,10 @@ module MOM_surface_forcing_nuopc !! 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 ! Diagnostics handles type(forcing_diags), public :: handles @@ -369,7 +372,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 @@ -426,7 +429,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) @@ -832,6 +835,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) @@ -857,6 +861,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 @@ -878,8 +883,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 @@ -1381,7 +1388,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' @@ -1391,7 +1398,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/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/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 522420e004..c99402446f 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 @@ -406,10 +408,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") @@ -427,8 +435,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 @@ -436,13 +442,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 @@ -466,8 +470,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 @@ -476,12 +478,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 @@ -529,9 +529,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) @@ -554,8 +556,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] @@ -575,9 +575,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 @@ -673,8 +673,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. @@ -685,7 +683,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) @@ -724,7 +721,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 @@ -737,11 +734,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 @@ -758,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, & 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) @@ -768,7 +766,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 @@ -784,15 +782,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 @@ -804,6 +806,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 @@ -827,8 +832,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 :: 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 :: 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") @@ -839,12 +843,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)) @@ -854,19 +856,27 @@ 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) + 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) @@ -891,15 +901,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 @@ -1515,8 +1527,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 @@ -1539,8 +1549,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, & @@ -1563,6 +1571,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), "//& @@ -1705,6 +1714,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), "//& @@ -1738,17 +1749,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: "//& @@ -1786,8 +1797,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. & @@ -1855,7 +1882,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.) @@ -1871,7 +1898,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. @@ -1890,10 +1917,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) diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index fc803c27e6..d7d3b89a8a 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. @@ -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 @@ -271,7 +272,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/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_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 470dde0848..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 @@ -1489,7 +1492,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 +1515,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 +1525,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 +1554,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 +1562,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. @@ -1989,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/FMS1/MOM_interp_infra.F90 b/config_src/infra/FMS1/MOM_interp_infra.F90 index 224e26a051..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 @@ -18,6 +20,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 @@ -145,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 @@ -167,46 +201,44 @@ 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 - !! 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 +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, 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) + 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 +248,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 +265,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 +293,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/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_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index d845d7317b..ff1d888c47 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 @@ -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 @@ -1390,7 +1391,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) @@ -1491,7 +1492,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 +1515,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 +1527,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 +1556,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 +1564,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. @@ -1992,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 diff --git a/config_src/infra/FMS2/MOM_interp_infra.F90 b/config_src/infra/FMS2/MOM_interp_infra.F90 index c29459aad1..0b45b752ae 100644 --- a/config_src/infra/FMS2/MOM_interp_infra.F90 +++ b/config_src/infra/FMS2/MOM_interp_infra.F90 @@ -4,20 +4,37 @@ 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 -use time_interp_external_mod, only : get_external_field_axes, get_external_field_missing +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 +use time_interp_external2_mod, only : get_external_field_missing implicit none ; private 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 + +!< 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 @@ -123,15 +140,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) @@ -144,13 +152,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 @@ -166,46 +172,44 @@ 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 - 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) + 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 - 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 +219,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 +236,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 +264,70 @@ 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 + + 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 + + ! 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 - init_extern_field = 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) + 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 - init_extern_field = 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) + 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.) endif - end function init_extern_field end module MOM_interp_infra diff --git a/config_src/infra/FMS2/MOM_io_infra.F90 b/config_src/infra/FMS2/MOM_io_infra.F90 index 54b9dfb78b..a43b4e9344 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 @@ -16,32 +17,31 @@ 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 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,15 +63,10 @@ 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 - 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 @@ -104,11 +99,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 +109,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 +147,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 +177,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 +194,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 +266,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 +294,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) - - ! 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 + ! 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.') - 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) + 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) & + 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 +355,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 +474,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 + 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 - end subroutine get_file_info @@ -575,12 +501,9 @@ 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) + 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) - else - call mpp_get_times(IO_handle%unit, time_values) - endif endif end subroutine get_file_times @@ -590,7 +513,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 +523,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 +586,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 +629,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 +727,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 +753,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 +771,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 +790,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 +821,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 +839,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 +858,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 +890,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) - - ! 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_2d: ", 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 @@ -1060,7 +941,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 +955,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 +969,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,34 +1006,97 @@ 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) + + ! 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 + +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, filename, "read", MOM_domain%mpp_domain) + 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, fieldname, "read_field_3d: ", filename, & - var_to_read, has_time_dim, timelevel, position) + call prepare_to_read_var(fileobj_DD, fieldname, "read_field_2d_region: ", & + filename, var_to_read) ! 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 + 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) - else ! Read the variable using the FMS-1 interface. - call read_data(filename, fieldname, data, MOM_Domain%mpp_domain, & - timelevel=timelevel, position=position) endif if (present(scale)) then ; if (scale /= 1.0) then - call rescale_comp_data(MOM_Domain, data, scale) + 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 +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 @@ -1182,29 +1121,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)) - - ! 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) + ! 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_4d: ", 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 @@ -1226,29 +1160,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 +1197,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 +1251,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 +1314,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) @@ -1682,9 +1594,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. @@ -1807,14 +1719,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 +1740,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 +1761,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 +1779,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 +1797,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 +1817,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 - 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 + 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,18 +1833,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 +1866,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 +1877,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 +1965,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 +2003,37 @@ 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 +!> 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 diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 137f6cee9b..a341fd1835 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1456,24 +1456,30 @@ 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) 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/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..9da4e95b24 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 @@ -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 @@ -530,7 +538,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 +560,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, & @@ -2082,7 +2090,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 @@ -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 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ba7152ea30..89d1ee2004 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 @@ -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 @@ -653,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 @@ -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,19 +1257,19 @@ 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, & - 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 - 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, & @@ -1402,6 +1402,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 @@ -1494,9 +1500,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) @@ -1583,6 +1589,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) @@ -1600,9 +1611,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) @@ -1625,13 +1636,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)" @@ -1678,6 +1695,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 @@ -1850,6 +1869,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 @@ -1980,7 +2005,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. @@ -2200,7 +2224,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 "//& @@ -2236,7 +2260,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, & @@ -2822,6 +2846,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) @@ -2864,7 +2893,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 ) @@ -2904,7 +2933,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) @@ -3108,6 +3137,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) @@ -3119,16 +3153,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 @@ -3138,39 +3163,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 @@ -3197,10 +3194,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) @@ -3228,11 +3221,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 @@ -3384,18 +3372,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") @@ -3994,6 +3970,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_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/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index bb77a99c4c..40f759f4b8 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 @@ -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_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_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/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 74ab4e1f18..9fb1a6b356 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 @@ -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_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index a3b7d604dd..a36fec3bb5 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]. @@ -220,6 +223,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] @@ -357,6 +362,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 @@ -1079,6 +1085,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)) & @@ -1178,11 +1186,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., & @@ -1229,6 +1239,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') @@ -1297,18 +1308,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) @@ -2021,6 +2036,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 @@ -2028,6 +2044,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 @@ -2148,6 +2165,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 @@ -2279,6 +2302,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 @@ -2915,6 +2944,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) @@ -2985,6 +3017,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) @@ -3118,6 +3151,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) @@ -3186,8 +3220,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) @@ -3244,6 +3277,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) @@ -3300,9 +3334,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) @@ -3331,6 +3366,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 @@ -3461,8 +3497,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( & @@ -3521,24 +3559,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 @@ -3579,6 +3620,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/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 7047dd6421..befeb1c2ad 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -3,40 +3,53 @@ 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, 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 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, 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 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 !! 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 +57,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 +68,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 +80,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 +98,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 +134,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 +146,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 +160,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 +175,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 +186,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 +194,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 +239,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 +250,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 @@ -259,4 +260,290 @@ subroutine find_eta_2d(h, tv, G, GV, US, eta, eta_bt, halo_size, eta_to_m, 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. +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 + +!> 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_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/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index d13be05ffd..89383c4936 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -11,6 +11,8 @@ module MOM_unit_tests use MOM_random, only : random_unit_tests use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests +use MOM_EOS, only : EOS_unit_tests +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests implicit none ; private public unit_tests @@ -30,6 +32,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, & @@ -40,6 +44,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/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index bf4b33af11..4ad26ed362 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -91,6 +91,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 @@ -255,8 +258,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 => 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]. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index f20c7bbd26..5e9b5c476c 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 @@ -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 = 0.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") @@ -187,20 +230,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/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index ff65a3b60b..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. @@ -635,7 +630,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), & @@ -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, & diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 1f1a8e0d36..d6a337b08a 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/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/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/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 4ddedf85a8..c68dc7b661 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -6,44 +6,70 @@ 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_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 +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, 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, 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, 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 +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_density_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_compress_nemo +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_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 +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 -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 : EoS_fit_range_TEOS10 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 +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 +use MOM_io, only : stdout use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type implicit none ; private -#include - public EOS_domain public EOS_init 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 +public average_specific_vol public calculate_compress public calculate_density public calculate_density_derivs @@ -67,16 +93,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 @@ -88,7 +112,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, @@ -125,8 +149,13 @@ 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 +! 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] @@ -146,24 +175,36 @@ 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 - -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*(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 +integer, parameter, public :: EOS_WRIGHT_FULL = 4 !< 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_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 +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*(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 +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 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 -character*(10), parameter :: TFREEZE_DEFAULT = TFREEZE_LINEAR_STRING !< The default freezing point expression contains @@ -221,37 +262,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) - call calculate_density_second_derivs_wright(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 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 @@ -278,13 +299,21 @@ 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) + call calculate_density_wright_full(T, S, pressure, rho, start, npts, rho_ref) + 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) - 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) + 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 @@ -295,64 +324,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) - call calculate_density_second_derivs_wright(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 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. @@ -425,21 +396,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 @@ -448,50 +410,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) - call calculate_density_second_derivs_wright(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 default - call MOM_error(FATAL, "calculate_stanley_density_scalar: 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 @@ -517,18 +446,26 @@ 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) + call calculate_spec_vol_wright_full(T, S, pressure, specvol, start, npts, spv_ref) + 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) - 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 specvol(:) = 1.0 / rho(:) 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 @@ -660,6 +597,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 @@ -698,6 +637,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 @@ -713,6 +654,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 @@ -749,6 +692,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 @@ -765,6 +710,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 @@ -804,13 +751,21 @@ 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) + call calculate_density_derivs_wright_full(T, S, pressure, drho_dT, drho_dS, start, npts) + 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) - 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) + 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 @@ -894,24 +849,34 @@ 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(1), Sa(1), pres(1),drho_dT, drho_dS) + 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, Sa, pres, drho_dT, drho_dS) + 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 - 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 @@ -965,13 +930,36 @@ 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) + 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) + 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_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, & 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) + 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_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 @@ -984,13 +972,36 @@ 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) + 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) + 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_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, & 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) + 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_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 @@ -1057,13 +1068,36 @@ 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) + 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) + 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_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, & 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) + 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_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 @@ -1119,23 +1153,26 @@ 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) + call calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) + 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) - 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) 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 @@ -1233,13 +1270,21 @@ 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) + call calculate_compress_wright_full(Ta, Sa, pres, rho, drho_dp, is, npts) + 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) - 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) + 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 @@ -1281,6 +1326,134 @@ 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. +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_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) + 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) + 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 @@ -1351,7 +1524,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!") @@ -1369,6 +1541,16 @@ 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 (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, & + 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 +1640,32 @@ 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 (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 + 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 @@ -1481,30 +1689,44 @@ 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". '//& - "This is only used if USE_EOS is true.", default=EOS_DEFAULT) + "EQN_OF_STATE determines which ocean equation of state should be used. "//& + 'Currently, the valid choices are "LINEAR", "UNESCO", "JACKETT_MCD", '//& + '"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) 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) + EOS%form_of_EOS = EOS_WRIGHT_REDUCED + 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 + EOS%form_of_EOS = EOS_ROQUET_RHO + case (EOS_ROQUET_RHO_STRING) + EOS%form_of_EOS = EOS_ROQUET_RHO + 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.") + trim(tmpstr) // " in input file is invalid.") end select call MOM_mesg('interpret_eos_selection: equation of state set to "' // & trim(tmpstr)//'"', 5) @@ -1513,8 +1735,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 "//& @@ -1524,21 +1745,37 @@ 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. & + (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 "//& - "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_ROQUET_RHO .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 "//& "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 @@ -1563,10 +1800,11 @@ 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_ROQUET_RHO .or. & + EOS%form_of_EOS == EOS_ROQUET_SPV) .and. & + .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 or TFREEZE_TEOSPOLY.") endif ! Unit conversions @@ -1652,27 +1890,24 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) intent(in) :: mask_z !< 3d mask regulating which points to convert [nondim] type(EOS_type), intent(in) :: EOS !< Equation of state structure - 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] + 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_NEMO)) return + 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)) + 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 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] @@ -1700,13 +1935,13 @@ subroutine cons_temp_to_pot_temp(T, S, poTemp, EOS, dom, scale) endif 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)) + 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 - poTemp(is:ie) = gsw_pt_from_ct(Sa(is:ie), Ta(is:ie)) + poTemp(is:ie) = consTemp_to_poTemp(Ta(is:ie), Sa(is:ie)) endif T_scale = EOS%degC_to_C @@ -1718,8 +1953,55 @@ 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) + 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. + + ! 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] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(T) + endif + + + if ((EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then + 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 + consTemp(is:ie) = poTemp_to_consTemp(Tp(is:ie), Sa(is:ie)) + 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 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] @@ -1735,6 +2017,8 @@ subroutine abs_saln_to_prac_saln(S, prSaln, EOS, dom, scale) ! 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] integer :: i, is, ie if (present(dom)) then @@ -1743,22 +2027,61 @@ 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)) + if (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) + 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. + + ! 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] + integer :: i, is, ie + + if (present(dom)) then + is = dom(1) ; ie = dom(2) + else + is = 1 ; ie = size(S) + endif + + if (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 @@ -1770,12 +2093,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 @@ -1801,10 +2124,631 @@ 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_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) + 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.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, 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 + + ! 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_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) + fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & + 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 + + 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, "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) + 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 + + 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 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, 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) + 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_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, "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) + 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, 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 + + ! 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_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) + 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) + 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) + 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) + 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] + 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) 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, & + 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] + 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. + 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] + 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] + 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 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 + ! 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 :: 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] + 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 :: 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 + ! 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] + 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. + + ! 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 + ! 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) + + 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) + + ! 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) & + 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 + 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 + if (verbose) then + write(mesg, '(ES16.8," and ",ES16.8,", ratio - 1 = ",ES16.8)') & + 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 + 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 + + ! 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 + 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 + + 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 + + !> 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 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) + + 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 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 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) + + 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 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 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) + + 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)') & + 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)) + ! 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 !! -!! 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 -!! 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 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_Jackett06.F90 b/src/equation_of_state/MOM_EOS_Jackett06.F90 new file mode 100644 index 0000000000..119edee4f0 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Jackett06.F90 @@ -0,0 +1,590 @@ +!> 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, 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 +!! 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 + +!> 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 +!! +!! 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. +!! +!! 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), +!! 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 diff --git a/src/equation_of_state/MOM_EOS_NEMO.F90 b/src/equation_of_state/MOM_EOS_NEMO.F90 deleted file mode 100644 index dee2bc48bf..0000000000 --- a/src/equation_of_state/MOM_EOS_NEMO.F90 +++ /dev/null @@ -1,432 +0,0 @@ -!> The equation of state using the expressions of Roquet et al. that are used in NEMO -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 - -!> 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 -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 -interface calculate_density_derivs_nemo - module procedure calculate_density_derivs_scalar_nemo, calculate_density_derivs_array_nemo -end interface calculate_density_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] - -! 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 -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 = -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] -!>@} - -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. -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, 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) :: 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_nemo(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) - -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. -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]. - - ! 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] - 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] - - 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 - - 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 - - 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. -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. - - ! 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 - 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] - ! - ! 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 - - ! 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 - 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]. - ! 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] - real, dimension(1) :: drds0 ! A 1-d array with a copy of the derivative of density - ! with salinity [kg m-3 ppt-1] - - T0(1) = T - S0(1) = S - pressure0(1) = pressure - - call calculate_density_derivs_array_nemo(T0, S0, pressure0, drdt0, drds0, 1, 1) - drho_dt = drdt0(1) - drho_ds = drds0(1) -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. -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(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. - - ! Local variables - real :: zs ! Absolute salinity [g kg-1] - real :: zt ! Conservative temperature [degC] - real :: zp ! Pressure converted to decibars [dbar] - 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. - ! - 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)) - enddo -end subroutine calculate_compress_nemo - -end module MOM_EOS_NEMO 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..b6133442db --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -0,0 +1,813 @@ +!> 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, 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], +!! 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 :: 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 :: 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 + +!> 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) :: 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 ; pres0(1) = pressure + + 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 + +!> 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 [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 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! 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 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) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) :: 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 + pres0(1) = pressure + + if (present(rho_ref)) then + 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, pres0, 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 [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 Pa-1] proportional to pressure + real :: dSVdzs2 ! A contribution to the partial derivative of specific volume with + ! 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 Pa-3] proportional to pressure**3 + integer :: j + + do j=start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) :: 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 + ! with absolute salinity [kg m-3 ppt-1] + + T0(1) = T + S0(1) = S + pres0(1) = pressure + + 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 + +!> 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 [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 + ! pressure [m3 kg-1 Pa-1] + real :: dSV_TS_dp ! Derivative of the specific volume anomaly from the reference profile with + ! 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 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! 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 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 + + ! 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) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 ! [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 !< The starting index for calculations + integer, intent(in ) :: npts !< The number of values to calculate + + ! Local variables + 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] + integer :: j + + do j = start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) * ((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) + + ! 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) + + ! 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) + 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 !< 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] + 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 + +!> 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 +!! +!! 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 diff --git a/src/equation_of_state/MOM_EOS_Roquet_rho.F90 b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 new file mode 100644 index 0000000000..6d7a7a143e --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 @@ -0,0 +1,633 @@ +!> 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. + +!use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt + +implicit none ; private + +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_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_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_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 :: 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 :: 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 + +!> 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, pres, rho, rho_ref) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + 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) :: 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 + pres0(1) = pres + + call calculate_density_array_Roquet_rho(T0, S0, pres0, rho0, 1, 1, rho_ref) + rho = rho0(1) + +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, 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) :: 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 [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 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) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) + 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)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + if (present(rho_ref)) rho0S0 = rho0S0 - rho_ref + + 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_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, 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(:) :: 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 + !! 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 [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 Pa-1] + ! proportional to pressure + 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 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 Pa-1] proportional to pressure + real :: dRdzs2 ! A contribution to the partial derivative of density with + ! 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 Pa-3] proportional to pressure**3 + integer :: j + + do j=start,start+npts-1 + ! Conversions to the units used here. + zt = T(j) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 + 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) = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs + enddo + +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, pres, drho_dt, drho_ds) + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + 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 + !! 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) :: 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 + ! with absolute salinity [kg m-3 ppt-1] + + T0(1) = T + S0(1) = S + pres0(1) = pres + + 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 + +!> 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_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(:) :: 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) + !! [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 [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 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) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) + 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)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + rho(j) = rhoTS + rho00p ! In situ density [kg m-3] + + 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 ! 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. +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 [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 + !! 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 !< The starting index for calculations + integer, intent(in ) :: npts !< The number of values to calculate + + ! Local variables + 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] + 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 + ! Conversions to the units used here. + zt = T(j) + zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 + 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 + 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) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) + + ! Find drho_dt_dt + 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)) + + ! Find drho_ds_dp + 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) + + ! Find drho_dt_dp + 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)) + enddo + +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_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 [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] = [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 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_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_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_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] + 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_rho + +!> \namespace mom_eos_Roquet_rho +!! +!! \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 +!! 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. +!! +!! \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_Roquet_rho 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 59ebb92c7a..984b4a7217 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_derivs_UNESCO, calculate_specvol_derivs_UNESCO public calculate_density_scalar_UNESCO, calculate_density_array_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], @@ -30,59 +24,64 @@ 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. +! 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 PSU-3/2] -real, parameter :: R232 = -1.6546e-6 ! A coefficient in the fit for rho0 [kg m-3 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, -! 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 +! 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 :: 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 :: 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 @@ -92,11 +91,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] @@ -118,51 +117,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*(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 + 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 = (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) @@ -177,12 +167,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] @@ -201,51 +190,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*(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. + ! 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 = (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) @@ -256,144 +235,408 @@ 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 :: I_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) - - 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) + 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)) ) + + 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 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. +!> 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. + + ! 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_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) +!! 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 :: 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 :: 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] + real :: I_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? - rho(j) = 1000.0 ; drho_dP(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 ; 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*(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_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 = 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 + p2*ks_2 + ks = ks_0 + p1*(ks_1 + p1*ks_2) dks_dp = ks_1 + 2.0*p1*ks_2 + I_denom = 1.0 / (ks - p1) - rho(j) = rho0*ks / (ks - p1) -! 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) + ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. + 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 * ((rho0 * (ks - p1*dks_dp)) * I_denom**2) 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*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*(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 = 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 = (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: + ! 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 +!! 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( 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 + +!> 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 +!! +!! 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 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 +!! 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, 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 +!! +!! 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 Papers in Marine Sci. No. 36, UNESCO, Paris. end module MOM_EOS_UNESCO diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 77e0d17ff3..d8dee28aa2 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -3,73 +3,57 @@ 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 -#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 +public calculate_density_second_derivs_wright, calc_density_second_derivs_wright_buggy +public EoS_fit_range_Wright, avg_spec_vol_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. +!! 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 end interface calculate_density_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. +!! 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 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 +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 +!> Compute the second derivatives of density with various combinations +!! 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 +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 +!> 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]. -! 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] @@ -89,10 +73,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]. @@ -100,14 +85,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] @@ -122,10 +100,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]. @@ -135,7 +114,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] @@ -166,10 +144,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]. @@ -190,10 +169,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 @@ -224,7 +204,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]. @@ -261,8 +241,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]. @@ -288,7 +270,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] @@ -319,13 +301,13 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh 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 + ! 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 + 2.*b3*T(j))) + 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)) @@ -340,7 +322,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 - 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 - & + 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 @@ -348,8 +330,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 @@ -390,8 +374,116 @@ 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 +!> 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] + 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))) ! 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)) + 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 + ! 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 + 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 calc_dens_second_derivs_buggy_array_wright + +!> 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 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] + 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 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 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]. @@ -425,11 +517,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]. @@ -441,7 +529,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] @@ -460,9 +547,67 @@ 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 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. +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 +!! 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) @@ -718,12 +863,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) @@ -898,7 +1042,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) @@ -939,7 +1083,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) @@ -958,4 +1102,25 @@ 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 new file mode 100644 index 0000000000..107ced3f5b --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -0,0 +1,1033 @@ +!> 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. + +use MOM_hor_index, only : hor_index_type + +implicit none ; private + +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 +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 +!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from +!! 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 + +!> 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 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 + +!> 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 + +!> 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 +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 + +!> 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]. + 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 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]. + 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 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]. + 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 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 + !! 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], 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 + + 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 +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_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 * 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 + +!> 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]. + 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_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. +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 +!! 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) + 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_full + +!> 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 :: 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]. + 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)) + I_pterm = 1.0 / (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)) & + 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))) + I_pterm = 1.0 / (p0 + p_ave) + + 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. + 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))) + I_pterm = 1.0 / (p0 + p_ave) + + 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. + 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 + + +!> \namespace mom_eos_wright_full +!! +!! \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 +!! 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_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. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_full 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..5553112274 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -0,0 +1,1033 @@ +!> 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 + +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 +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 +!! 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], 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 + + 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 +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 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. +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 +!! 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 :: 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]. + 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)) + I_pterm = 1.0 / (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)) & + 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))) + I_pterm = 1.0 / (p0 + p_ave) + + 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. + 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))) + I_pterm = 1.0 / (p0 + p_ave) + + 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. + 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_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 +!! 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_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. +!! https://journals.ametsoc.org/doi/abs/10.1175/1520-0426%281997%29014%3C0735%3AAEOSFU%3E2.0.CO%3B2 + +end module MOM_EOS_Wright_red diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index dd45e6cd81..b1dacf2780 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -7,14 +7,13 @@ 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 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 +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 @@ -119,7 +118,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 +147,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))) @@ -294,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]. @@ -320,6 +319,49 @@ 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. +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. 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 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 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]. */ diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 5d658c44a4..c92753be1e 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -1426,7 +1426,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 @@ -1464,7 +1464,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 @@ -1789,7 +1789,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 @@ -1837,7 +1837,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 diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 83e7718311..34d0b73cb9 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -16,7 +16,8 @@ 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 use MOM_io, only : read_attribute, read_variable @@ -308,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] @@ -447,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() @@ -469,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 @@ -593,17 +603,20 @@ 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 !> 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 @@ -667,7 +680,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, 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 @@ -716,7 +729,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() @@ -727,8 +740,8 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, 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)) @@ -736,7 +749,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(fms_id, 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 @@ -790,7 +803,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 +910,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/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 1026216426..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 @@ -332,15 +333,20 @@ 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, fileset=SINGLE_FILE) + else + 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. @@ -765,13 +771,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 +867,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 @@ -1150,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) @@ -1171,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 @@ -2187,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, & diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index e1613fbbb3..6eaa10f622 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(fileset)) then + if (fileset == 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/framework/MOM_unit_scaling.F90 b/src/framework/MOM_unit_scaling.F90 index bfc2189188..868352102e 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,14 +52,16 @@ 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] - - ! 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. + 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] + + ! 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 @@ -218,8 +220,10 @@ 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%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 @@ -231,11 +235,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/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 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index a78c17803c..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 @@ -1222,12 +1223,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 +1670,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 +1712,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 @@ -1971,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 @@ -1979,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 @@ -2074,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/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_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) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index bd0931c694..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 +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 @@ -150,13 +150,12 @@ 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 ! 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 @@ -226,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 @@ -250,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 : "//& @@ -257,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"//& @@ -289,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)) @@ -374,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: "//& @@ -404,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 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, & "If true, depress the initial surface to avoid huge "//& "tsunamis when a large surface pressure is applied.", & @@ -415,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. @@ -438,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 @@ -462,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. @@ -517,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. @@ -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 @@ -548,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 @@ -667,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 @@ -682,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]. @@ -723,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 "//& @@ -763,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 @@ -798,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 @@ -857,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 @@ -876,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 @@ -915,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 @@ -929,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 @@ -990,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 @@ -1005,81 +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 to pressure units -subroutine convert_thickness(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]. - 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] - 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 - - 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 - call MOM_error(FATAL,"Not yet converting thickness with Boussinesq approx.") - 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 - 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 - p_bot(i,j) = p_top(i,j) + HR_to_pres * (h(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) * (HR_to_pres*h(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) = h(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 @@ -1195,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. @@ -1225,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.", & @@ -1262,7 +1180,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) @@ -1382,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] @@ -1405,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 @@ -1937,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)) :: & @@ -1944,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 @@ -1967,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 @@ -2139,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) @@ -2503,7 +2464,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 @@ -2514,7 +2476,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]. @@ -2721,7 +2684,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 @@ -2773,6 +2736,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 ) @@ -2793,63 +2757,71 @@ 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 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 ) + + ! 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 ) - if (.not. remap_general) then + deallocate( dz_interface ) + else ! This is the old way of initializing to z* coordinates only 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 ) - 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 - - 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 ) + ! 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 + 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, & old_remap=remap_old_alg, answer_date=remap_answer_date ) + deallocate( dz1 ) deallocate( h1 ) deallocate( tmpT1dIn ) deallocate( tmpS1dIn ) @@ -2886,15 +2858,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 @@ -2926,9 +2899,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 dz_to_thickness(dz, tv, h, G, GV, US) + endif ! useALEremapping deallocate(z_in, z_edges_in, temp_z, salt_z, mask_z) @@ -3136,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(:) 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/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 add2d6a984..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 @@ -1101,10 +1102,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 @@ -1157,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. @@ -1439,47 +1436,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_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 new file mode 100644 index 0000000000..500e4a508c --- /dev/null +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -0,0 +1,978 @@ +! > 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_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 + +#include + +public Zanna_Bolton_2020, ZB_2020_init + +!> Control structure for Zanna-Bolton-2020 parameterization. +type, public :: ZB2020_CS ; private + ! Parameters + 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_11 = -1 + integer :: id_S_22 = -1 + integer :: id_S_12 = -1 + !>@} + +end type ZB2020_CS + +contains + +!> 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", 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) + ! 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, "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, "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 + + 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) + + CS%id_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & + '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 points in q (CORNER) points', '1', conversion=1.) + + ! action of filter on momentum flux + 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_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) + +end subroutine ZB_2020_init + +!> Baroclinic Zanna-Bolton-2020 parameterization, see +!! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf +!! 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) +!! Update of the governing equations: +!! (du/dt, dv/dt) = k_BC * div(S) +!! 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]. + 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] + + ! Arrays defined in h (CENTER) points + real, dimension(SZI_(G),SZJ_(G)) :: & + 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, & ! 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, & ! 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, & ! 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, & ! 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 :: 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 :: k_bc ! Constant in from of the parameterization [L2 ~> m2] + ! Related to the amplitude as follows: + ! k_bc = - amplitude * grid_cell_area < 0 + + 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 + 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 + + if (CS%ssd_iter > -1) then + 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 + + sh_xx(:,:) = 0. + sh_xy(:,:) = 0. + vort_xy(:,:) = 0. + 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 + 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 + + call compute_masks(G, GV, h, mask_T, mask_q, k) + 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 + + 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 + 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 + 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) + 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 + 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,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) + 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-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%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) + 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_type == 2) then + vort_sh = 0. + else + vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) + endif + k_bc = - CS%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) + + if (CS%ssd_iter>-1) then + 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) + ! 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 (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_11>0) call post_data(CS%id_S_11, S_11_3d, 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 + +!> 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 + 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 + 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 + + ! Total operator is I - (I-G^n_lowpass)^n_highpass + if (present(q)) then + call pass_var(q, G%Domain, position=CORNER, complete=.true.) + 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 -> ((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 i_lowpass=1,ABS(n_lowpass) + call smooth_Tq(G, mask_T, mask_q, q=q2) + enddo + ! q1 -> (I-G^n_lowpass)*q1 + 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 + 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 + 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(G, min_after, max_after, q=q) + if (max_after > max_before .OR. min_after < min_before) then + 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) + 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 + 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 + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + T(i,j) = T(i,j) - T1(i,j) + enddo ; enddo + else + 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(G, min_after, max_after, T=T) + if (max_after > max_before .OR. min_after < min_before) then + 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 + +!> 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 (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 + 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.) + 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)) & + + (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 + call pass_var(q, G%Domain, position=CORNER, complete=.true.) + endif + + if (present(T)) then + call pass_var(T, G%Domain) + 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)) & + + (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 + call pass_var(T, G%Domain) + endif + +end subroutine smooth_Tq + +!> 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 + 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 (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. + + 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 + +!> 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. + + 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 :: 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] + + + 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 + + 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) + + 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..9037c71c5a 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,9 @@ 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. + 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]. !! The actual viscosity may be the larger of this @@ -329,6 +333,17 @@ 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 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 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] @@ -1607,6 +1622,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ! end of k loop + 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 + 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 +1780,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%use_ZB2020) + CS%initialized = .true. CS%diag => diag diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 6dda4c1b1c..8c56107a4f 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -23,7 +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_structure, only: wave_structure_init, wave_structure, wave_structure_CS +use MOM_wave_speed, only : wave_speeds, wave_speed_CS, wave_speed_init implicit none ; private @@ -40,6 +40,8 @@ module MOM_internal_tides 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 @@ -95,6 +97,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. @@ -124,12 +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. - type(wave_structure_CS) :: wave_struct !< Wave structure control structure !>@{ 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 @@ -148,6 +166,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 @@ -163,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. @@ -176,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] @@ -205,6 +231,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 +252,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 +260,19 @@ subroutine propagate_int_tide(h, tv, cn, TKE_itidal_input, vel_btTide, Nb, dt, & ! initialize local arrays drag_scale(:,:) = 0. 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. @@ -417,15 +461,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 +526,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 +535,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 @@ -545,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) @@ -635,6 +710,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) @@ -2221,12 +2316,14 @@ 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] 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 +2338,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) @@ -2250,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 @@ -2375,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) @@ -2407,6 +2513,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, & @@ -2531,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') @@ -2593,6 +2718,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 +2786,45 @@ 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 + + ! 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 @@ -2670,6 +2837,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/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index fe31eb0de3..206773ecb0 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 @@ -27,6 +28,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 @@ -57,7 +59,31 @@ 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 [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 + !! [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 [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 [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 + !! 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 + !! 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. + 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 @@ -67,7 +93,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 @@ -76,11 +103,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 @@ -92,7 +123,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 @@ -106,22 +137,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) + ! 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 @@ -210,10 +248,10 @@ subroutine mixedlayer_restrat_general(h, uhtr, vhtr, tv, forces, dt, MLD_in, Var vonKar_x_pi2 = CS%vonKar * 9.8696 - 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. @@ -222,7 +260,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 @@ -235,7 +273,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 @@ -264,7 +302,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 @@ -337,7 +375,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 @@ -432,9 +470,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) @@ -445,9 +483,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)) & @@ -519,9 +557,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) @@ -532,9 +570,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)) & @@ -575,7 +613,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) @@ -583,14 +622,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 @@ -600,25 +639,397 @@ 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_OM4 + +!> 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] + + ! 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)) + + ! 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)) + + ! -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 = (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) + 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 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 - !psi1 = max(0., (1. - (2.*z + 1.)**2)) - psi1 = max(0., (1. - (2.*z + 1.)**2) * (1. + (5./21.)*(2.*z + 1.)**2)) + covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. + varS(:) = 0.0 ! Ditto. - 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 + 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 - psi = max(psi1, dd*bottop) ! Combines original psi1 with tail - end function psi + ! 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 -end subroutine mixedlayer_restrat_general + ! 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 + 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 + 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 + 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 + 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) @@ -678,7 +1089,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 @@ -693,12 +1104,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. @@ -921,13 +1331,12 @@ 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] 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 @@ -951,9 +1360,80 @@ 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. "//& + "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 "//& + "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 "//& @@ -962,80 +1442,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', & @@ -1049,10 +1532,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) @@ -1065,29 +1551,21 @@ 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) - - ! 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 + 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 ! 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 @@ -1102,7 +1580,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, & @@ -1113,35 +1591,117 @@ 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 +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 + + ! 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. +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 '(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 + endif + +end function test_answer + !> \namespace mom_mixed_layer_restrat !! !! \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. @@ -1190,6 +1750,12 @@ end subroutine mixedlayer_restrat_register_restarts !! \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 @@ -1201,6 +1767,10 @@ end subroutine mixedlayer_restrat_register_restarts !! 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 @@ -1210,6 +1780,59 @@ end subroutine mixedlayer_restrat_register_restarts !! 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: @@ -1227,11 +1850,9 @@ end subroutine mixedlayer_restrat_register_restarts !! 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_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 ba8ba0b805..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. @@ -827,7 +828,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 +885,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..1bc29ee16f 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 @@ -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. @@ -171,7 +167,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 @@ -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,14 +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, 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 @@ -500,11 +487,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) - 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 + h, tv, G, GV, US, CS%MLD_En_vals, CS%diag) endif if (stoch_CS%do_sppt .and. stoch_CS%id_sppt_wts > 0) & @@ -712,6 +695,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 +841,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 +1297,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 +1386,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 @@ -1828,9 +1827,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 @@ -1900,6 +1905,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) @@ -2950,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 @@ -3044,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 "//& @@ -3168,38 +3160,25 @@ 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", & - "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 +3187,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 "//& @@ -3475,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) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 1e3bf258d8..47d4dffef6 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 @@ -2003,12 +2012,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 +2320,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/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) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 4364dac0fd..41a9cba8f4 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 @@ -20,7 +20,7 @@ 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, increment_date -use time_interp_external_mod, only : init_external_field, time_interp_external +use MOM_interpolate, only : external_field, init_external_field, time_interp_external use MOM_tracer_registry, only : register_tracer use MOM_tracer_types, only : tracer_registry_type use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut @@ -70,10 +70,10 @@ module MOM_CFC_cap type(CFC_tracer_data), dimension(NTR) :: CFC_data !< per-tracer parameters / metadata integer :: CFC_BC_year_offset = 0 !< offset to add to model time to get time value used in CFC_BC_file - integer :: id_cfc11_atm_nh = -1 !< id number for time_interp_external. - integer :: id_cfc11_atm_sh = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm_nh = -1 !< id number for time_interp_external. - integer :: id_cfc12_atm_sh = -1 !< id number for time_interp_external. + type(external_field) :: cfc11_atm_nh_handle !< Handle for time-interpolated CFC11 atm NH + type(external_field) :: cfc11_atm_sh_handle !< Handle for time-interpolated CFC11 atm SH + type(external_field) :: cfc12_atm_nh_handle !< Handle for time-interpolated CFC12 atm NH + type(external_field) :: cfc12_atm_sh_handle !< Handle for time-interpolated CFC12 atm SH end type CFC_cap_CS contains @@ -168,22 +168,23 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) call get_param(param_file, mdl, "CFC11_NH_VARIABLE", CFC_BC_var_name, & "Variable name of NH CFC-11 atm mole fraction in CFC_BC_FILE.", & default="cfc11_nh") - CS%id_cfc11_atm_nh = init_external_field(CFC_BC_file, CFC_BC_var_name) + CS%cfc11_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) call get_param(param_file, mdl, "CFC11_SH_VARIABLE", CFC_BC_var_name, & "Variable name of SH CFC-11 atm mole fraction in CFC_BC_FILE.", & default="cfc11_sh") - CS%id_cfc11_atm_sh = init_external_field(CFC_BC_file, CFC_BC_var_name) + CS%cfc11_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) call get_param(param_file, mdl, "CFC12_NH_VARIABLE", CFC_BC_var_name, & "Variable name of NH CFC-12 atm mole fraction in CFC_BC_FILE.", & default="cfc12_nh") - CS%id_cfc12_atm_nh = init_external_field(CFC_BC_file, CFC_BC_var_name) + CS%cfc12_atm_nh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) call get_param(param_file, mdl, "CFC12_SH_VARIABLE", CFC_BC_var_name, & "Variable name of SH CFC-12 atm mole fraction in CFC_BC_FILE.", & default="cfc12_sh") - CS%id_cfc12_atm_sh = init_external_field(CFC_BC_file, CFC_BC_var_name) + CS%cfc12_atm_sh_handle = init_external_field(CFC_BC_file, CFC_BC_var_name) +! domain=G%Domain%mpp_domain) ! The following vardesc types contain a package of metadata about each tracer, ! including, the name; units; longname; and grid information. @@ -502,15 +503,15 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US Time_external = increment_date(day_start, years=CS%CFC_BC_year_offset) ! CFC11 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol - call time_interp_external(CS%id_cfc11_atm_nh, Time_external, cfc11_atm_nh) + call time_interp_external(CS%cfc11_atm_nh_handle, Time_external, cfc11_atm_nh) cfc11_atm_nh = cfc11_atm_nh * 1.0e-12 - call time_interp_external(CS%id_cfc11_atm_sh, Time_external, cfc11_atm_sh) + call time_interp_external(CS%cfc11_atm_sh_handle, Time_external, cfc11_atm_sh) cfc11_atm_sh = cfc11_atm_sh * 1.0e-12 ! CFC12 atm mole fraction, convert from ppt (pico mol/mol) to mol/mol - call time_interp_external(CS%id_cfc12_atm_nh, Time_external, cfc12_atm_nh) + call time_interp_external(CS%cfc12_atm_nh_handle, Time_external, cfc12_atm_nh) cfc12_atm_nh = cfc12_atm_nh * 1.0e-12 - call time_interp_external(CS%id_cfc12_atm_sh, Time_external, cfc12_atm_sh) + call time_interp_external(CS%cfc12_atm_sh_handle, Time_external, cfc12_atm_sh) cfc12_atm_sh = cfc12_atm_sh * 1.0e-12 !--------------------------------------------------------------------- diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index cdabfa1277..c49c6a9a23 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/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 2200a28c2b..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 @@ -304,7 +305,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 +346,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 +371,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 +413,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 +600,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 +680,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 +744,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 +787,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 +797,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 +826,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 +836,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 @@ -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 @@ -1035,7 +1037,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 +1079,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 @@ -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) @@ -1119,7 +1127,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 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/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/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index 1382fe8e34..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 @@ -98,7 +99,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 +159,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 +181,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 +203,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 +226,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 +288,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 +299,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 @@ -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/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..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 @@ -143,11 +144,10 @@ 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 - !! 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. @@ -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 @@ -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/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/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. 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..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 @@ -105,7 +106,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 +138,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 +148,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 @@ -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 0b65883eca..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 @@ -96,7 +97,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 +127,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 +175,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 +218,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 +233,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 +243,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 +256,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 @@ -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 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) 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 212f2a1f6d3e88c0d8efbdd340af602de42197fd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:51:58 -0400 Subject: [PATCH 379/629] +Add RESTORE_FLUX_RHO and TKE_TIDAL_RHO Added the new runtime parameters RESTORE_FLUX_RHO and TKE_TIDAL_RHO to specify the densities that are used to convert the piston velocities into restoring heat or salt fluxes and to translate tidal velocities into tidal TKE input. Their defaults are set to RHO_0 to reproduce previous answers. Also added tau_mag arguments to 2 calls to allocate_forcing_type() and 4 calls to allocate_mech_forcing() in the FMS_cap and solo_driver code. There are new rho_restore elements in the FMS and solo_driver versions of surface_forcing_CS and in MESO_surface_forcing_CS and user_surface_forcing_CS. By default, all answers are bitwise identical, but there are new entries in some MOM_parameter_doc files. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 32 +++++++++++----- .../solo_driver/MESO_surface_forcing.F90 | 16 +++++--- .../solo_driver/MOM_surface_forcing.F90 | 38 +++++++++++-------- .../solo_driver/user_surface_forcing.F90 | 18 ++++++--- 4 files changed, 70 insertions(+), 34 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 a8398c3cc8..713f04dc18 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -112,8 +112,10 @@ module MOM_surface_forcing_gfdl !! salinity to a specified value. logical :: restore_temp !< If true, the coupled MOM driver adds a term to restore sea !! surface temperature to a specified value. - real :: Flux_const_salt !< Piston velocity for surface salt restoring [Z T-1 ~> m s-1] - real :: Flux_const_temp !< Piston velocity for surface temp restoring [Z T-1 ~> m s-1] + real :: Flux_const_salt !< Piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const_temp !< Piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] logical :: trestore_SPEAR_ECDA !< If true, modify restoring data wrt local SSS real :: SPEAR_dTf_dS !< The derivative of the freezing temperature with !! salinity [C S-1 ~> degC ppt-1]. @@ -268,7 +270,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, isr = is-isd+1 ; ier = ie-isd+1 ; jsr = js-jsd+1 ; jer = je-jsd+1 kg_m2_s_conversion = US%kg_m2s_to_RZ_T - if (CS%restore_temp) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%restore_temp) rhoXcp = CS%rho_restore * fluxes%C_p open_ocn_mask(:,:) = 1.0 fluxes%vPrecGlobalAdj = 0.0 fluxes%vPrecGlobalScl = 0.0 @@ -281,7 +283,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., press=.true., & - fix_accum_bug=CS%fix_ustar_gustless_bug) + fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -363,7 +365,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, do j=js,je ; do i=is,ie delta_sss = data_restore(i,j) - sfc_state%SSS(i,j) delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) - fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const_salt)* & + fluxes%salt_flux(i,j) = 1.e-3*US%S_to_ppt*G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const_salt)* & (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j)) * delta_sss ! R Z T-1 ~> kg Salt m-2 s-1 enddo ; enddo if (CS%adjust_net_srestore_to_zero) then @@ -386,7 +388,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, delta_sss = sfc_state%SSS(i,j) - data_restore(i,j) delta_sss = sign(1.0,delta_sss) * min(abs(delta_sss), CS%max_delta_srestore) fluxes%vprec(i,j) = (CS%basin_mask(i,j)*open_ocn_mask(i,j)*CS%srestore_mask(i,j))* & - (CS%Rho0*CS%Flux_const_salt) * & + (CS%rho_restore*CS%Flux_const_salt) * & delta_sss / (0.5*(sfc_state%SSS(i,j) + data_restore(i,j))) endif enddo ; enddo @@ -717,7 +719,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! mechanical forcing type has been used. if (.not.forces%initialized) then call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true.) + press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -1276,6 +1278,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + real :: rho_TKE_tidal ! The constant bottom density used to translate tidal amplitudes into the + ! tidal bottom TKE input used with INT_TIDE_DISSIPATION [R ~> kg m-3] logical :: new_sim ! False if this simulation was started from a restart file ! or other equivalent files. logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. @@ -1501,6 +1505,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "The derivative of the freezing temperature with salinity.", & units="deg C PSU-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, & do_not_log=.not.CS%trestore_SPEAR_ECDA) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%restore_temp.or.CS%restore_salt)) ! Optionally read tidal amplitude from input file [Z T-1 ~> m s-1] on model grid. ! Otherwise use default tidal amplitude for bottom frictionally-generated @@ -1525,6 +1534,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_to_Z*US%T_to_s) endif + call get_param(param_file, mdl, "TKE_TIDAL_RHO", rho_TKE_tidal, & + "The constant bottom density used to translate tidal amplitudes into the tidal "//& + "bottom TKE input used with INT_TIDE_DISSIPATION.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=.not.(CS%read_TIDEAMP.or.(CS%utide>0.0))) call safe_alloc_ptr(CS%TKE_tidal,isd,ied,jsd,jed) call safe_alloc_ptr(CS%ustar_tidal,isd,ied,jsd,jed) @@ -1537,13 +1551,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) rescale=US%m_to_Z*US%T_to_s) do j=jsd, jed; do i=isd, ied utide = CS%TKE_tidal(i,j) - CS%TKE_tidal(i,j) = G%mask2dT(i,j)*CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = G%mask2dT(i,j)*rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo else do j=jsd,jed; do i=isd,ied utide = CS%utide - CS%TKE_tidal(i,j) = CS%Rho0*CS%cd_tides*(utide*utide*utide) + CS%TKE_tidal(i,j) = rho_TKE_tidal*CS%cd_tides*(utide*utide*utide) CS%ustar_tidal(i,j) = sqrt(CS%cd_tides)*utide enddo ; enddo endif diff --git a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 index a3007326b7..f1f3daa52e 100644 --- a/config_src/drivers/solo_driver/MESO_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MESO_surface_forcing.F90 @@ -9,7 +9,7 @@ module MESO_surface_forcing use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_forcing_type use MOM_grid, only : ocean_grid_type use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_time_manager, only : time_type, operator(+), operator(/) @@ -30,6 +30,8 @@ module MESO_surface_forcing real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [R L Z T-2 ~> Pa] real, dimension(:,:), pointer :: & @@ -166,14 +168,14 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! call MOM_error(FATAL, "MESO_buoyancy_surface_forcing: " // & ! "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in degC) and ! salinity (in ppt or PSU) that are being restored toward. if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const) - fluxes%vprec(i,j) = - (CS%Rho0 * CS%Flux_const) * & + fluxes%vprec(i,j) = - (CS%rho_restore * CS%Flux_const) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -188,7 +190,7 @@ subroutine MESO_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. @@ -272,7 +274,11 @@ subroutine MESO_surface_forcing_init(Time, G, US, param_file, diag, CS) "variable NET_SOL.", fail_if_missing=.true.) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, default=".") CS%inputdir = slasher(CS%inputdir) - + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) endif end subroutine MESO_surface_forcing_init diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 859bfd81c8..8d46a80cae 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -79,9 +79,11 @@ module MOM_surface_forcing real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] real :: G_Earth !< gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< piston velocity for surface restoring [Z T-1 ~> m s-1] - real :: Flux_const_T !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] - real :: Flux_const_S !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: Flux_const = 0.0 !< piston velocity for surface restoring [Z T-1 ~> m s-1] + real :: Flux_const_T = 0.0 !< piston velocity for surface temperature restoring [Z T-1 ~> m s-1] + real :: Flux_const_S = 0.0 !< piston velocity for surface salinity restoring [Z T-1 ~> m s-1] + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: latent_heat_fusion !< latent heat of fusion times [Q ~> J kg-1] real :: latent_heat_vapor !< latent heat of vaporization [Q ~> J kg-1] real :: tau_x0 !< Constant zonal wind stress used in the WIND_CONFIG="const" @@ -250,9 +252,9 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodynamic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) - call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) + call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -837,7 +839,7 @@ subroutine wind_forcing_by_data_override(sfc_state, forces, day, G, US, CS) call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") if (.not.CS%dataOverrideIsInitialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif @@ -953,7 +955,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p ! Read the buoyancy forcing file call get_time(day, seconds, days) @@ -1152,7 +1154,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1164,7 +1166,7 @@ subroutine buoyancy_forcing_from_files(sfc_state, fluxes, day, dt, G, US, CS) do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1220,7 +1222,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - if (CS%use_temperature) rhoXcp = CS%Rho0 * fluxes%C_p + if (CS%use_temperature) rhoXcp = CS%rho_restore * fluxes%C_p if (.not.CS%dataOverrideIsInitialized) then call data_override_init(G%Domain) @@ -1258,7 +1260,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & ((CS%T_Restore(i,j) - sfc_state%SST(i,j)) * rhoXcp * CS%Flux_const_T) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const_S) * & + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const_S) * & (CS%S_Restore(i,j) - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + CS%S_Restore(i,j))) else @@ -1270,7 +1272,7 @@ subroutine buoyancy_forcing_from_data_override(sfc_state, fluxes, day, dt, G, US do j=js,je ; do i=is,ie if (G%mask2dT(i,j) > 0.0) then fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - (CS%G_Earth * CS%Flux_const / CS%Rho0) + (CS%G_Earth * CS%Flux_const / CS%rho_restore) else fluxes%buoy(i,j) = 0.0 endif @@ -1457,8 +1459,8 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) S_restore = CS%S_south + (CS%S_north-CS%S_south)*y if (G%mask2dT(i,j) > 0.0) then fluxes%heat_added(i,j) = G%mask2dT(i,j) * & - ((T_Restore - sfc_state%SST(i,j)) * ((CS%Rho0 * fluxes%C_p) * CS%Flux_const)) - fluxes%vprec(i,j) = - (CS%Rho0*CS%Flux_const) * & + ((T_Restore - sfc_state%SST(i,j)) * ((CS%rho_restore * fluxes%C_p) * CS%Flux_const)) + fluxes%vprec(i,j) = - (CS%rho_restore*CS%Flux_const) * & (S_Restore - sfc_state%SSS(i,j)) / & (0.5*(sfc_state%SSS(i,j) + S_Restore)) else @@ -1472,7 +1474,7 @@ subroutine buoyancy_forcing_linear(sfc_state, fluxes, day, dt, G, US, CS) !do j=js,je ; do i=is,ie ! if (G%mask2dT(i,j) > 0.0) then ! fluxes%buoy(i,j) = (CS%Dens_Restore(i,j) - sfc_state%sfc_density(i,j)) * & - ! (CS%G_Earth * CS%Flux_const / CS%Rho0) + ! (CS%G_Earth * CS%Flux_const / CS%rho_restore) ! else ! fluxes%buoy(i,j) = 0.0 ! endif @@ -1874,6 +1876,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "at the southern end of the domain toward which to "//& "to restore.", units="PSU", default=35.0, scale=US%ppt_to_S) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(((CS%Flux_const==0.0).and.(CS%Flux_const_T==0.0).and.(CS%Flux_const_S==0.0))& + .or.(.not.CS%restorebuoy))) endif call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & diff --git a/config_src/drivers/solo_driver/user_surface_forcing.F90 b/config_src/drivers/solo_driver/user_surface_forcing.F90 index d7d3b89a8a..7d4ea94603 100644 --- a/config_src/drivers/solo_driver/user_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/user_surface_forcing.F90 @@ -35,6 +35,8 @@ module user_surface_forcing real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: gust_const !< A constant unresolved background gustiness !! that contributes to ustar [R L Z T-2 ~> Pa]. @@ -69,7 +71,7 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) ! Set the surface wind stresses, in units of [R L Z T-2 ~> Pa]. A positive taux ! accelerates the ocean to the (pseudo-)east. @@ -91,7 +93,8 @@ subroutine USER_wind_forcing(sfc_state, forces, day, G, US, CS) 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))) - forces%ustar(i,j) = G%mask2dT(i,j) * sqrt(forces%tau_mag(i,j) * (US%L_to_Z/CS%Rho0)) + if (associated(forces%ustar)) & + 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 @@ -200,7 +203,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and ! salinity (in [S ~> ppt]) that are being restored toward. @@ -209,7 +212,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -219,7 +222,7 @@ subroutine USER_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential ! density [R ~> kg m-3] that is being restored toward. @@ -284,6 +287,11 @@ subroutine USER_surface_forcing_init(Time, G, US, param_file, diag, CS) "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & default=0.0, units="m day-1", scale=US%m_to_Z/(86400.0*US%s_to_T)) endif + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0).or.(.not.CS%restorebuoy)) end subroutine USER_surface_forcing_init From cf6ac00bb38d0df8328524c9f30a7338354cf05f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:53:41 -0400 Subject: [PATCH 380/629] Add tau_mag to allocate_forcing_type calls Add tau_mag argument to calls to allocate_forcing_type() in initialize_ice_shelf_fluxes and the mct_cap and noupc_cap versions of convert_IOB_to_fluxes and to calls to allocate_mech_forcing() in initialize_ice_shelf_forces and the mct_cap and noupc_cap versions of convert_IOB_to_forces. All answers are bitwise identical. --- config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 | 4 ++-- config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 | 4 ++-- src/ice_shelf/MOM_ice_shelf.F90 | 7 ++++--- 3 files changed, 8 insertions(+), 7 deletions(-) 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 ec5dab57a7..a5c2db6974 100644 --- a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 @@ -276,7 +276,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & - press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug) + press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -649,7 +649,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) 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 0d2a73aa64..aee95ddd91 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -308,7 +308,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & - cfc=CS%use_CFC, hevap=CS%enthalpy_cpl) + cfc=CS%use_CFC, hevap=CS%enthalpy_cpl, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -716,7 +716,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d0faeb3aae..f5a85da95a 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1869,10 +1869,11 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) ! when SHELF_THERMO = True. These fluxes are necessary if one wants to ! use either ENERGETICS_SFC_PBL (ALE mode) or BULKMIXEDLAYER (layer mode). call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & - press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation = CS%active_shelf_dynamics) + press=.true., water=CS%isthermo, heat=CS%isthermo, shelf_sfc_accumulation=CS%active_shelf_dynamics, & + tau_mag=.true.) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true.) + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) @@ -1903,7 +1904,7 @@ subroutine initialize_ice_shelf_forces(CS, ocn_grid, US, forces_in) type(mech_forcing), pointer :: forces => NULL() call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating forces.") - call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true.) + call allocate_mech_forcing(CS%Grid_in, forces_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) if (CS%rotate_index) then allocate(forces) call allocate_mech_forcing(forces_in, CS%Grid, forces) From 994ce9e914425db7984067f7e17cc133e8a4086e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 30 Jun 2023 17:50:46 -0400 Subject: [PATCH 381/629] +Set tau_mag in idealized_hurricane_wind_forcing Calculate forces%tau_mag in idealized_hurricane_wind_forcing() and SCM_idealized_hurricane_wind_forcing(), and call allocate_mech_forcing with the new tau_mag argument so that this array is sure to be allocated. All answers are bitwise identical in existing test cases, but this step was necessary for this code to work in fully non-Boussinesq configurations. --- src/user/Idealized_Hurricane.F90 | 40 +++++++++++++++++++++----------- 1 file changed, 26 insertions(+), 14 deletions(-) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index ad930911ca..5dd8084fbd 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -22,7 +22,7 @@ module Idealized_hurricane use MOM_error_handler, only : MOM_error, FATAL use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing -use MOM_forcing_type, only : allocate_forcing_type, allocate_mech_forcing +use MOM_forcing_type, only : allocate_mech_forcing use MOM_grid, only : ocean_grid_type use MOM_safe_alloc, only : safe_alloc_ptr use MOM_time_manager, only : time_type, operator(+), operator(/), time_type_to_real @@ -251,7 +251,7 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) if (CS%relative_tau) then REL_TAU_FAC = 1. @@ -325,16 +325,20 @@ subroutine idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, CS) enddo !> Get Ustar - 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(US%L_to_Z * (CS%gustiness/CS%Rho0 + & - sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & - 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo - enddo + 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(US%L_to_Z * (CS%gustiness/CS%Rho0 + & + sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & + 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) + enddo ; enddo ; endif + + !> Get tau_mag [R L Z T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + 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))) + enddo ; enddo ; endif - return end subroutine idealized_hurricane_wind_forcing !> Calculate the wind speed at a location as a function of time. @@ -522,7 +526,7 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C ! Allocate the forcing arrays, if necessary. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., tau_mag=.true.) pie = 4.0*atan(1.0) ; Deg2Rad = pie/180. !/ BR ! Implementing Holland (1980) parameteric wind profile @@ -667,13 +671,21 @@ subroutine SCM_idealized_hurricane_wind_forcing(sfc_state, forces, day, G, US, C endif forces%tauy(I,j) = CS%rho_a * US%L_to_Z * G%mask2dCv(I,j) * Cd*dU10*dV enddo ; enddo + ! Set the surface friction velocity [Z T-1 ~> m s-1]. ustar is always positive. - do j=js,je ; do i=is,ie + 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(US%L_to_Z * (CS%gustiness/CS%Rho0 + & sqrt(0.5*(forces%taux(I-1,j)**2 + forces%taux(I,j)**2) + & 0.5*(forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2))/CS%Rho0)) - enddo ; enddo + enddo ; enddo ; endif + + !> Set magnitude of the wind stress [R L Z T-2 ~> Pa] + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = G%mask2dT(i,j) * (CS%gustiness + & + 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))) + enddo ; enddo ; endif end subroutine SCM_idealized_hurricane_wind_forcing From d1077375d5109384f300b8e35789ab130cf061d2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 5 Jul 2023 17:35:18 -0400 Subject: [PATCH 382/629] +Use RESTORE_FLUX_RHO in dumbbell & SCM_CVMix_tests Use RESTORE_FLUX_RHO in SCM_CVMix_tests and dumbbell_surface_forcing to specify the density that are used to convert the piston velocities into restoring heat or salt fluxes. As with other analogous changes, the default is set to RHO_0 to reproduce previous answers. Also set forces%tau_mag in SCM_CVMix_tests_wind_forcing if it is associated. There is a new rho_restore element in the control structures for the SCM_CVMix_tests two module, while the units of an element in the dumbbell_surface_forcing module are changed. By default, all existing answers are bitwise identical, but there are new entries in some MOM_parameter_doc files. --- src/user/SCM_CVMix_tests.F90 | 18 ++++++++++++++---- src/user/dumbbell_surface_forcing.F90 | 19 +++++++++++++------ 2 files changed, 27 insertions(+), 10 deletions(-) diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 7b1b4b3946..104a2b0312 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -42,6 +42,8 @@ module SCM_CVMix_tests real :: surf_evap !< (Constant) Evaporation rate [Z T-1 ~> m s-1] real :: Max_sw !< maximum of diurnal sw radiation [C Z T-1 ~> degC m s-1] real :: Rho0 !< reference density [R ~> kg m-3] + real :: rho_restore !< The density that is used to convert piston velocities + !! into salt or heat fluxes [R ~> kg m-3] end type ! This include declares and sets the variable "version". @@ -184,6 +186,9 @@ subroutine SCM_CVMix_tests_surface_forcing_init(Time, G, param_file, CS) "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat fluxes.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) end subroutine SCM_CVMix_tests_surface_forcing_init @@ -214,7 +219,11 @@ subroutine SCM_CVMix_tests_wind_forcing(sfc_state, forces, day, G, US, CS) mag_tau = sqrt(CS%tau_x*CS%tau_x + CS%tau_y*CS%tau_y) if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie - forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / (CS%Rho0) ) + forces%ustar(i,j) = sqrt( US%L_to_Z * mag_tau / 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 enddo ; enddo ; endif end subroutine SCM_CVMix_tests_wind_forcing @@ -246,7 +255,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying ! by Rho0*Cp do J=Jsq,Jeq ; do i=is,ie - fluxes%sens(i,J) = CS%surf_HF * CS%Rho0 * fluxes%C_p + fluxes%sens(i,J) = CS%surf_HF * CS%rho_restore * fluxes%C_p enddo ; enddo endif @@ -255,7 +264,7 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! Note CVMix test inputs give evaporation in [Z T-1 ~> m s-1] ! This therefore must be converted to mass flux in [R Z T-1 ~> kg m-2 s-1] ! by multiplying by density and some unit conversion factors. - fluxes%evap(i,J) = CS%surf_evap * CS%Rho0 + fluxes%evap(i,J) = CS%surf_evap * CS%rho_restore enddo ; enddo endif @@ -264,7 +273,8 @@ subroutine SCM_CVMix_tests_buoyancy_forcing(sfc_state, fluxes, day, G, US, CS) ! Note CVMix test inputs give max sw rad in [Z C T-1 ~> m degC s-1] ! therefore must convert to [Q R Z T-1 ~> W m-2] by multiplying by Rho0*Cp ! Note diurnal cycle peaks at Noon. - fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * CS%RHO0 * fluxes%C_p + fluxes%sw(i,J) = CS%Max_sw * max(0.0, cos(2*PI*(time_type_to_real(DAY)/86400.0 - 0.5))) * & + CS%rho_restore * fluxes%C_p enddo ; enddo endif diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index ca383ba1f1..6f6e4da439 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -25,9 +25,8 @@ module dumbbell_surface_forcing type, public :: dumbbell_surface_forcing_CS ; private logical :: use_temperature !< If true, temperature and salinity are used as state variables. logical :: restorebuoy !< If true, use restoring surface buoyancy forcing. - real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] - real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: Flux_const !< The restoring rate at the surface [R Z T-1 ~> kg m-2 s-1]. ! real :: gust_const !< A constant unresolved background gustiness ! !! that contributes to ustar [R L Z T-2 ~> Pa]. real :: slp_amplitude !< The amplitude of pressure loading [R L2 T-2 ~> Pa] applied @@ -114,7 +113,7 @@ subroutine dumbbell_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) if (CS%use_temperature .and. CS%restorebuoy) then do j=js,je ; do i=is,ie if (CS%forcing_mask(i,j)>0.) then - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * CS%Flux_const) * & ((CS%S_restore(i,j) - sfc_state%SSS(i,j)) / (0.5 * (CS%S_restore(i,j) + sfc_state%SSS(i,j)))) endif @@ -181,6 +180,9 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) real :: S_surf ! Initial surface salinity [S ~> ppt] real :: S_range ! Range of the initial vertical distribution of salinity [S ~> ppt] real :: x ! Latitude normalized by the domain size [nondim] + real :: Rho0 ! The density used in the Boussinesq approximation [R ~> kg m-3] + real :: rho_restore ! The density that is used to convert piston velocities into salt + ! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] integer :: i, j logical :: dbrotate ! If true, rotate the domain. # include "version_variable.h" @@ -202,7 +204,7 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "G_EARTH", CS%G_Earth, & "The gravitational acceleration of the Earth.", & units="m s-2", default=9.80, scale=US%m_to_L**2*US%Z_to_m*US%T_to_s**2) - call get_param(param_file, mdl, "RHO_0", CS%Rho0, & + call get_param(param_file, mdl, "RHO_0", Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& @@ -233,8 +235,13 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) "The constant that relates the restoring surface fluxes to the relative "//& "surface anomalies (akin to a piston velocity). Note the non-MKS units.", & default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) - ! Convert CS%Flux_const from m day-1 to m s-1. - CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) + ! Convert FLUXCONST from m day-1 to m s-1 and Flux_const to [R Z T-1 ~> kg m-2 s-1] + CS%Flux_const = rho_restore * (CS%Flux_const / 86400.0) allocate(CS%forcing_mask(G%isd:G%ied, G%jsd:G%jed), source=0.0) From 5afb1222abf1f0bbffc12e80548f32f2646ae8f3 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Tue, 25 Jul 2023 12:07:53 -0400 Subject: [PATCH 383/629] Resolve warning about S_REF units The units of S_REF were first registered in "PSU" and then later by benchmark in "ppt" which led to a WARNING. Although there is no uniformity to the units of S_REF throughout the user code (currently PSU, ppt, and 1e-3) are all used, benchmark is the only one that leads to a warning in the current suite and changing all to be consistent would 1) unnecessarily update the doc files, and 2) not be correct for all models. Bottom line, I'm punting on the best way to handle units of salinity. This commit resolves the only WARNING we currently get in the MOM6-examples suite. --- src/user/benchmark_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index 333f53895e..ad75d83efa 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -142,7 +142,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e units="degC", default=29.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, & "The uniform salinities used to initialize the benchmark test case.", & - units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! This subroutine has no run-time parameters. From 4c224e704f9bae6bdc6741f677f4b5b902ec5b8a Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Mon, 21 Aug 2023 14:52:34 -0400 Subject: [PATCH 384/629] Bugfix in MLE for reproducible restarts with USE_BODNER23 = True - Update for missing halo update of field wpup_filtered in MOM_mixed_layer_restrat.F90 during initialization. - The missing halo update caused the model to diverge when running from restart files. - With the halo update the model now reproduces from restart files. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 1 + 1 file changed, 1 insertion(+) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 5b7ec60dee..9cf79b07ce 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1584,6 +1584,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) + if (allocated(CS%wpup_filtered)) call pass_var(CS%wpup_filtered, G%domain) end function mixedlayer_restrat_init From 7e51f1d6d82e1ba6fbc90df3bde8bbe4607a2f15 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 26 Jul 2023 16:27:45 -0400 Subject: [PATCH 385/629] +*Non-Boussinesq form of mixedlayer_restrat Revised the code in MOM_mixed_layer_restrat.F90 to work internally with thickness-based units for the restratification timescale calculation and other internal calculations, which eliminates the dependence in this module on the value of the Boussinesq reference density in non-Boussinesq mode. Several other minor issues (which might not change any answers in production runs) were also fixed. The changes with this commit include: - When in non-Boussinesq mode, the mixed layer buoyancy gradients are determined from the average specific volume referenced to the surface pressure, rather than from the average potential density. - Use find_ustar to set the friction velocities in the appropriate units in the various mixed_layer_restrat routines. - 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. - Within the function mu, the expression for dd was revised 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 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. - The addition of code to both mixedlayer_restrat_Bodner and mixedlayer_restrat_OM4 to determine the mixed layer thickness from its vertical extent when in non-Boussinesq mode. This commit includes changes to the units of the Kv_restrat, ustar_min and wpup_filtered elements in the mixedlayer_restrat_CS type and the units of four arguments to the private function growth_time. CS%wpup_filtered also appears in the restart files generated with some mixed layer restratification settings, and it is rescaled to units of vertical distance or mass per unit area in the restart files depending on whether the model is Boussinesq. There are 17 new or renamed internal variables, while the units of 21 internal variables were changed. 19 rescaling factors were cancelled out or replaced. There are also comments where variable units were corrected or added. The rescaling of several chksum calls for thicknesses was modified to GV%H_to_mks to avoid any dependence on RHO_0 when non-Boussinesq. No public interfaces are changed. All answers are bitwise identical in Boussinesq mode (at least when TAIL_DH=0.), but solutions will change in non-Boussinesq mode when mixed layer restratification is enabled, including changes to the units of a variable in the restart files. --- .../lateral/MOM_mixed_layer_restrat.F90 | 532 ++++++++++++------ 1 file changed, 345 insertions(+), 187 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 9cf79b07ce..444ef8f064 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -19,7 +19,7 @@ module MOM_mixed_layer_restrat use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units -use MOM_EOS, only : calculate_density, EOS_domain +use MOM_EOS, only : calculate_density, calculate_spec_vol, EOS_domain implicit none ; private @@ -86,15 +86,17 @@ module MOM_mixed_layer_restrat 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 - real :: ustar_min !< A minimum value of ustar to avoid numerical problems [Z T-1 ~> m s-1] + logical :: use_Stanley_ML !< If true, use the Stanley parameterization of SGS T variance + real :: ustar_min !< A minimum value of ustar in thickness units to avoid numerical + !! problems [H T-1 ~> m s-1 or kg m-2 s-1] real :: Kv_restrat !< A viscosity that sets a floor on the momentum mixing rate - !! during restratification [Z2 T-1 ~> m2 s-1] + !! during restratification, rescaled into thickness-based + !! units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] 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] - wpup_filtered !< Time-filtered vertical momentum flux [Z2 T-2 ~> m2 s-2] + wpup_filtered !< Time-filtered vertical momentum flux [H L T-2 ~> m2 s-2 or kg m-1 s-2] !>@{ !! Diagnostic identifier @@ -173,7 +175,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] real, dimension(:,:), pointer :: MLD_in !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] (not H) + !! PBL scheme [Z ~> m] type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure @@ -184,27 +186,37 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - U_star_2d, & ! The wind friction velocity, calculated using + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using ! the Boussinesq reference density or the time-evolving surface density - ! in non-Boussinesq mode [Z T-1 ~> m s-1] + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] MLD_fast, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_fast, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av_fast, & ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] + Rml_av_fast, & ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] MLD_slow, & ! Mixed layer depth actually used in MLE restratification parameterization [H ~> m or kg m-2] htot_slow, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av_slow ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] + Rml_av_slow ! Negative g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] real :: rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rml_int_fast(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: rml_int_slow(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int_fast(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: SpV_int_slow(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: H_mld(SZI_(G)) ! The thickness of water within the topmost MLD_in of height [H ~> m or kg m-2] + real :: MLD_rem(SZI_(G)) ! The vertical extent of the MLD_in that has not yet been accounted for [Z ~> m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: h_vel ! htot interpolated onto velocity points [Z ~> m] (not H). + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] - real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff so can be neglected [H ~> m or kg m-2] - real :: dz_neglect ! A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] 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 :: a(SZK_(GV)) ! A non-dimensional value relating the overall flux @@ -256,9 +268,12 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, if (.not. allocated(VarMix%Rd_dx_h) .and. CS%front_length > 0.) & call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "The resolution argument, Rd/dx, was not associated.") + if (CS%use_Stanley_ML .and. .not.GV%Boussinesq) call MOM_error(FATAL, & + "MOM_mixedlayer_restrat: The Stanley parameterization is not"//& + "available without the Boussinesq approximation.") ! Extract the friction velocity from the forcing type. - call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) if (CS%MLE_density_diff > 0.) then ! We need to calculate a mixed layer depth, MLD. !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA @@ -304,9 +319,30 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, enddo enddo ! j-loop elseif (CS%MLE_use_PBL_MLD) then - do j = js-1, je+1 ; do i = is-1, ie+1 - MLD_fast(i,j) = (CS%MLE_MLD_stretch * GV%Z_to_H) * MLD_in(i,j) - enddo ; enddo + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j = js-1, je+1 ; do i = is-1, ie+1 + MLD_fast(i,j) = CS%MLE_MLD_stretch * GV%Z_to_H * MLD_in(i,j) + enddo ; enddo + else ! The fully non-Boussinesq conversion between height in MLD_in and thickness. + do j=js-1,je+1 + do i=is-1,ie+1 ; MLD_rem(i) = MLD_in(i,j) ; H_mld(i) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + H_mld(i) = H_mld(i) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + do i=is-1,ie+1 ; MLD_fast(i,j) = CS%MLE_MLD_stretch * H_mld(i) ; enddo + enddo + endif else call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "No MLD to use for MLE parameterization.") @@ -315,7 +351,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! Apply time filter (to remove diurnal cycle) if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(MLD_in, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=US%Z_to_m) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) @@ -332,8 +368,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! Apply slower time filter (to remove seasonal cycle) on already filtered MLD_fast if (CS%MLE_MLD_decay_time2>0.) then if (CS%debug) then - call hchksum(CS%MLD_filtered_slow,'mixed_layer_restrat: MLD_filtered_slow',G%HI,haloshift=1,scale=GV%H_to_m) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD fast',G%HI,haloshift=1,scale=GV%H_to_m) + call hchksum(CS%MLD_filtered_slow, 'mixed_layer_restrat: MLD_filtered_slow', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD fast', G%HI, haloshift=1, scale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time2 / ( dt + CS%MLE_MLD_decay_time2 ) bFac = dt / ( dt + CS%MLE_MLD_decay_time2 ) @@ -353,9 +389,8 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, uDml(:) = 0.0 ; vDml(:) = 0.0 uDml_slow(:) = 0.0 ; vDml_slow(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_Z if (CS%front_length>0.) then res_upscale = .true. I_LFront = 1. / CS%front_length @@ -366,58 +401,106 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) !$OMP parallel default(shared) private(rho_ml,h_vel,u_star,absf,mom_mixrate,timescale, & - !$OMP line_is_empty, keep_going,res_scaling_fac, & + !$OMP SpV_ml,SpV_int_fast,SpV_int_slow,Rml_int_fast,Rml_int_slow, & + !$OMP line_is_empty,keep_going,res_scaling_fac, & !$OMP a,IhTot,b,Ihtot_slow,zpb,hAtVel,zpa,dh) & !$OMP firstprivate(uDml,vDml,uDml_slow,vDml_slow) - !$OMP do - do j=js-1,je+1 - do i=is-1,ie+1 - htot_fast(i,j) = 0.0 ; Rml_av_fast(i,j) = 0.0 - htot_slow(i,j) = 0.0 ; Rml_av_slow(i,j) = 0.0 - enddo - keep_going = .true. - do k=1,nz + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 do i=is-1,ie+1 - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + htot_fast(i,j) = 0.0 ; Rml_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; Rml_int_slow(i) = 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. + keep_going = .true. + do k=1,nz do i=is-1,ie+1 - if (htot_fast(i,j) < MLD_fast(i,j)) then - dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) - Rml_av_fast(i,j) = Rml_av_fast(i,j) + dh*rho_ml(i) - htot_fast(i,j) = htot_fast(i,j) + dh - line_is_empty = .false. - endif - if (htot_slow(i,j) < MLD_slow(i,j)) then - dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) - Rml_av_slow(i,j) = Rml_av_slow(i,j) + dh*rho_ml(i) - htot_slow(i,j) = htot_slow(i,j) + dh - line_is_empty = .false. - endif + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) enddo - if (line_is_empty) keep_going=.false. - endif + 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_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + Rml_int_fast(i) = Rml_int_fast(i) + dh*rho_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + Rml_int_slow(i) = Rml_int_slow(i) + dh*rho_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo + + do i=is-1,ie+1 + Rml_av_fast(i,j) = -(g_Rho0*Rml_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = -(g_Rho0*Rml_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot_fast(i,j) = 0.0 ; SpV_int_fast(i) = 0.0 + htot_slow(i,j) = 0.0 ; SpV_int_slow(i) = 0.0 + enddo + keep_going = .true. + do k=1,nz + do i=is-1,ie+1 + 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 ! This is not implemented yet in the EoS code. + ! call calculate_spec_vol(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_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + ! endif + line_is_empty = .true. + do i=is-1,ie+1 + if (htot_fast(i,j) < MLD_fast(i,j)) then + dh = min( h(i,j,k), MLD_fast(i,j)-htot_fast(i,j) ) + SpV_int_fast(i) = SpV_int_fast(i) + dh*SpV_ml(i) + htot_fast(i,j) = htot_fast(i,j) + dh + line_is_empty = .false. + endif + if (htot_slow(i,j) < MLD_slow(i,j)) then + dh = min( h(i,j,k), MLD_slow(i,j)-htot_slow(i,j) ) + SpV_int_slow(i) = SpV_int_slow(i) + dh*SpV_ml(i) + htot_slow(i,j) = htot_slow(i,j) + dh + line_is_empty = .false. + endif + enddo + if (line_is_empty) keep_going=.false. + endif + enddo - do i=is-1,ie+1 - Rml_av_fast(i,j) = -(g_Rho0*Rml_av_fast(i,j)) / (htot_fast(i,j) + h_neglect) - Rml_av_slow(i,j) = -(g_Rho0*Rml_av_slow(i,j)) / (htot_slow(i,j) + h_neglect) + ! Convert the vertically integrated specific volume into a positive variable with units of density. + do i=is-1,ie+1 + Rml_av_fast(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_fast(i)) / (htot_fast(i,j) + h_neglect) + Rml_av_slow(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int_slow(i)) / (htot_slow(i,j) + h_neglect) + enddo enddo - enddo + endif if (CS%debug) then - call hchksum(h,'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) - call hchksum(MLD_fast,'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_m) - call hchksum(Rml_av_fast,'mixed_layer_restrat: rml', G%HI, haloshift=1, & - scale=US%m_to_Z*US%L_T_to_m_s**2) + call hchksum(h, 'mixed_layer_restrat: h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(U_star_2d, 'mixed_layer_restrat: u*', G%HI, haloshift=1, scale=GV%H_to_m*US%s_to_T) + call hchksum(MLD_fast, 'mixed_layer_restrat: MLD', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(Rml_av_fast, 'mixed_layer_restrat: rml', G%HI, haloshift=1, & + scale=GV%m_to_H*US%L_T_to_m_s**2) endif ! TO DO: @@ -437,34 +520,34 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i+1,j)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef if (res_upscale) timescale = timescale * res_scaling_fac uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_fast(i+1,j)-Rml_av_fast(i,j)) * (h_vel**2) ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i+1,j)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef2 if (res_upscale) timescale = timescale * res_scaling_fac uDml_slow(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_slow(i+1,j)-Rml_av_slow(i,j)) * (h_vel**2) if (uDml(I) + uDml_slow(I) == 0.) then do k=1,nz ; uhml(I,j,k) = 0.0 ; enddo @@ -524,34 +607,34 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 - h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_fast(i,j) + htot_fast(i,j+1)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef if (res_upscale) timescale = timescale * res_scaling_fac vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_fast(i,j+1)-Rml_av_fast(i,j)) * (h_vel**2) ! As above but using the slow filtered MLD - h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) * GV%H_to_Z + h_vel = 0.5*((htot_slow(i,j) + htot_slow(i,j+1)) + h_neglect) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef2) mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef2 if (res_upscale) timescale = timescale * res_scaling_fac vDml_slow(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av_slow(i,j+1)-Rml_av_slow(i,j)) * (h_vel**2) if (vDml(i) + vDml_slow(i) == 0.) then do k=1,nz ; vhml(i,J,k) = 0.0 ; enddo @@ -710,31 +793,40 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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] + little_h, & ! "Little h" representing active mixing layer depth [H ~> m or kg m-2] + big_H, & ! "Big H" representing the mixed layer depth [H ~> m or kg m-2] 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] + buoy_av, & ! g_Rho0 times the average mixed layer density or G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + wpup ! Turbulent vertical momentum [L H T-2 ~> m2 s-2 or kg m-1 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 :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq ! reference density or the time-evolving surface density in non-Boussinesq ! mode [Z T-1 ~> m 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 :: BLD_in_H(SZI_(G)) ! The thickness of the active boundary layer with the topmost BLD of + ! height [H ~> m or kg m-2] + real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] + real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] + real :: Rml_int(SZI_(G)) ! Potential density integrated through the mixed layer [R H ~> kg m-2 or kg2 m-5] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] + real :: H_mld(SZI_(G)) ! The thickness of water within the topmost BLD of height [H ~> m or kg m-2] + real :: MLD_rem(SZI_(G)) ! The vertical extent of the BLD that has not yet been accounted for [Z ~> m] 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 :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] 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 :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] 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 :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [H ~> m or kg m-2] + real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [H ~> m or kg m-2] + real :: grd_b ! The vertically average gradient of buoyancy [L H-1 T-2 ~> s-2 or m-3 kg-1 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] @@ -754,7 +846,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * 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. @@ -775,24 +867,49 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) if (CS%debug) then - call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_mks) 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(U_star_2d, '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) + G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(CS%MLD_filtered_slow,'mle_Bodner: MLD_filtered_slow 1', & - G%HI, haloshift=1, scale=US%Z_to_m) + G%HI, haloshift=1, scale=GV%H_to_mks) 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 + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j = js-1, je+1 ; do i = is-1, ie+1 + little_h(i,j) = rmean2ts(GV%Z_to_H*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 + else ! The fully non-Boussinesq conversion between height in BLD and thickness. + do j=js-1,je+1 + do i=is-1,ie+1 ; MLD_rem(i) = BLD(i,j) ; H_mld(i) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + H_mld(i) = H_mld(i) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + do i=is-1,ie+1 + little_h(i,j) = rmean2ts(H_mld(i), 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 + endif ! 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 @@ -804,11 +921,11 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! 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 + * ( ( US%Z_to_m * US%s_to_T )**3 ) ! [m3 T3 Z-3 s-3 ~> 1] u_star3 = ( US%Z_to_m * US%s_to_T * U_star_2d(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 + * ( US%m_to_L * GV%m_to_H * US%T_to_s**2 ) ! [L H s2 m-2 T-2 ~> 1 or kg m-3] ! 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) @@ -816,13 +933,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(CS%MLD_filtered,'mle_Bodner: MLD_filtered 2', & - G%HI, haloshift=1, scale=US%Z_to_m) + G%HI, haloshift=1, scale=GV%H_to_mks) 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) + G%HI, haloshift=1, scale=GV%H_to_mks) + call hchksum(wpup,'mle_Bodner: wpup', G%HI, haloshift=1, scale=US%L_to_m*GV%H_to_mks*US%s_to_T**2) endif ! Calculate the average density in the "mixed layer". @@ -834,11 +951,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d !$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 sigint, muzb, muza, hAtVel, Rml_int, SpV_int) + !$OMP do do j=js-1,je+1 + rho_ml(:) = 0.0 ; SpV_ml(:) = 0.0 do i=is-1,ie+1 - htot(i,j) = 0.0 ; buoy_av(i,j) = 0.0 + htot(i,j) = 0.0 ; Rml_int(i) = 0.0 ; SpV_int(i) = 0.0 enddo keep_going = .true. do k=1,nz @@ -846,17 +965,22 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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) + if (GV%Boussinesq .or. GV%semi_Boussinesq) 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 else - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, rho_ml(:), tv%eqn_of_state, EOSdom) + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_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 + if (htot(i,j) < big_H(i,j)) then + dh = min( h(i,j,k), big_H(i,j) - htot(i,j) ) + Rml_int(i) = Rml_int(i) + dh*rho_ml(i) ! Rml_int has units of [R H ~> kg m-2] + SpV_int(i) = SpV_int(i) + dh*SpV_ml(i) ! SpV_int has units of [H R-1 ~> m4 kg-1 or m] htot(i,j) = htot(i,j) + dh line_is_empty = .false. endif @@ -865,18 +989,24 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is-1,ie+1 + ! Buoy_av has units (L2 H-1 T-2 R-1) * (R H) * H-1 = L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2 + buoy_av(i,j) = -( g_Rho0 * Rml_int(i) ) / (htot(i,j) + h_neglect) + enddo + else + do i=is-1,ie+1 + ! Buoy_av has units (R L2 H-1 T-2) * (R-1 H) * H-1 = L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2 + buoy_av(i,j) = (GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo + endif enddo if (CS%debug) then - call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_m) + call hchksum(htot,'mle_Bodner: htot', G%HI, haloshift=1, scale=GV%H_to_mks) 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) + scale=US%L_to_m**2*GV%H_to_mks*US%s_to_T) + call hchksum(buoy_av,'mle_Bodner: buoy_av', G%HI, haloshift=1, scale=GV%m_to_H*US%L_T_to_m_s**2) endif ! U - Component @@ -885,12 +1015,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 + h_sml = 0.5*( little_h(i,j) + little_h(i+1,j) ) ! H ~> m or kg m-3 + h_big = 0.5*( big_H(i,j) + big_H(i+1,j) ) ! H ~> m or kg m-3 + grd_b = ( buoy_av(i+1,j) - buoy_av(i,j) ) * G%IdxCu(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i+1,j) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 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 + * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -926,12 +1056,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 + h_sml = 0.5*( little_h(i,j) + little_h(i,j+1) ) ! H ~> m or kg m-3 + h_big = 0.5*( big_H(i,j) + big_H(i,j+1) ) ! H ~> m or kg m-3 + grd_b = ( buoy_av(i,j+1) - buoy_av(i,j) ) * G%IdyCv(I,j) ! L H-1 T-2 ~> s-2 or m3 kg-1 s-2 + r_wpup = 2. / ( wpup(i,j) + wpup(i,j+1) ) ! T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1 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 + * ( ( h_big**2 ) * grd_b ) ) * r_wpup else ! There is no flux on land and no gradient at open boundary points. psi_mag = 0.0 endif @@ -1065,25 +1195,30 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_avail ! The volume available for diffusion out of each face of each ! sublayer of the mixed layer, divided by dt [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJ_(G)) :: & - U_star_2d, & ! The wind friction velocity, calculated using + U_star_2d, & ! The wind friction velocity in thickness-based units, calculated using ! the Boussinesq reference density or the time-evolving surface density - ! in non-Boussinesq mode [Z T-1 ~> m s-1] + ! in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] htot, & ! The sum of the thicknesses of layers in the mixed layer [H ~> m or kg m-2] - Rml_av ! g_Rho0 times the average mixed layer density [L2 Z-1 T-2 ~> m s-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1] - real :: Rho0(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + Rml_av ! g_Rho0 times the average mixed layer density or negative G_Earth + ! times the average specific volume [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2] + real :: g_Rho0 ! G_Earth/Rho0 times a thickness conversion factor + ! [L2 H-1 T-2 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2] + real :: Rho_ml(SZI_(G)) ! Potential density relative to the surface [R ~> kg m-3] + real :: rho_int(SZI_(G)) ! The integral of density over the mixed layer depth [R H ~> kg m-2 or kg2 m-3] + real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] + real :: SpV_int(SZI_(G)) ! Specific volume integrated through the surface layer [H R-1 ~> m4 kg-1 or m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] - real :: h_vel ! htot interpolated onto velocity points [Z ~> m]. (The units are not H.) + real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] - real :: u_star ! surface friction velocity, interpolated to velocity points [Z T-1 ~> m s-1]. + real :: u_star ! surface friction velocity, interpolated to velocity points and recast into + ! thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1]. real :: vonKar_x_pi2 ! A scaling constant that is approximately the von Karman constant times ! pi squared [nondim] real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] real :: timescale ! mixing growth timescale [T ~> s] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. real :: h_neglect ! tiny thickness usually lost in roundoff and can be neglected [H ~> m or kg m-2] - real :: dz_neglect ! tiny thickness that usually lost in roundoff and can be neglected [Z ~> m] real :: I4dt ! 1/(4 dt) [T-1 ~> s-1] real :: I2htot ! Twice the total mixed layer thickness at velocity points [H ~> m or kg m-2] real :: z_topx2 ! depth of the top of a layer at velocity points [H ~> m or kg m-2] @@ -1113,11 +1248,10 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) h_min = 0.5*GV%Angstrom_H ! This should be GV%Angstrom_H, but that value would change answers. uDml(:) = 0.0 ; vDml(:) = 0.0 I4dt = 0.25 / dt - g_Rho0 = GV%g_Earth / GV%Rho0 + g_Rho0 = GV%H_to_Z * GV%g_Earth / GV%Rho0 vonKar_x_pi2 = CS%vonKar * 9.8696 use_EOS = associated(tv%eqn_of_state) h_neglect = GV%H_subroundoff - dz_neglect = GV%H_subroundoff*GV%H_to_Z if (.not.use_EOS) call MOM_error(FATAL, "mixedlayer_restrat_BML: "// & "An equation of state must be used with this module.") @@ -1126,33 +1260,56 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) "The Stanley parameterization is not available with the BML.") ! Extract the friction velocity from the forcing type. - call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1) + call find_ustar(forces, tv, U_star_2d, G, GV, US, halo=1, H_T_units=.true.) ! Fix this later for nkml >= 3. p0(:) = 0.0 EOSdom(:) = EOS_domain(G%HI, halo=1) - !$OMP parallel default(shared) private(Rho0,h_vel,u_star,absf,mom_mixrate,timescale, & - !$OMP I2htot,z_topx2,hx2,a) & + !$OMP parallel default(shared) private(Rho_ml,rho_int,h_vel,u_star,absf,mom_mixrate,timescale, & + !$OMP SpV_ml,SpV_int,I2htot,z_topx2,hx2,a) & !$OMP firstprivate(uDml,vDml) - !$OMP do - do j=js-1,je+1 - do i=is-1,ie+1 - htot(i,j) = 0.0 ; Rml_av(i,j) = 0.0 - enddo - do k=1,nkml - call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho0(:), tv%eqn_of_state, EOSdom) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; rho_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_density(tv%T(:,j,k), tv%S(:,j,k), p0, Rho_ml(:), tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + rho_int(i) = rho_int(i) + h(i,j,k)*Rho_ml(i) + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo + do i=is-1,ie+1 - Rml_av(i,j) = Rml_av(i,j) + h(i,j,k)*Rho0(i) - htot(i,j) = htot(i,j) + h(i,j,k) - h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + Rml_av(i,j) = (g_Rho0*rho_int(i)) / (htot(i,j) + h_neglect) enddo enddo + else ! This is only used in non-Boussinesq mode. + !$OMP do + do j=js-1,je+1 + do i=is-1,ie+1 + htot(i,j) = 0.0 ; SpV_int(i) = 0.0 + enddo + do k=1,nkml + call calculate_spec_vol(tv%T(:,j,k), tv%S(:,j,k), p0, SpV_ml, tv%eqn_of_state, EOSdom) + do i=is-1,ie+1 + SpV_int(i) = SpV_int(i) + h(i,j,k)*SpV_ml(i) ! [H R-1 ~> m4 kg-1 or m] + htot(i,j) = htot(i,j) + h(i,j,k) + h_avail(i,j,k) = max(I4dt*G%areaT(i,j)*(h(i,j,k)-GV%Angstrom_H),0.0) + enddo + enddo - do i=is-1,ie+1 - Rml_av(i,j) = (g_Rho0*Rml_av(i,j)) / (htot(i,j) + h_neglect) + ! Convert the vertically integrated specific volume into a negative variable with units of density. + do i=is-1,ie+1 + Rml_av(i,j) = (-GV%H_to_RZ*GV%g_Earth * SpV_int(i)) / (htot(i,j) + h_neglect) + enddo enddo - enddo + endif ! TO DO: ! 1. Mixing extends below the mixing layer to the mixed layer. Find it! @@ -1161,26 +1318,26 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! U - Component !$OMP do do j=js,je ; do I=is-1,ie - h_vel = 0.5*(htot(i,j) + htot(i+1,j)) * GV%H_to_Z + h_vel = 0.5*(htot(i,j) + htot(i+1,j)) u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i+1,j))) absf = 0.5*(abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I,J))) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) uDml(I) = timescale * G%OBCmaskCu(I,j)*G%dyCu(I,j)*G%IdxCu(I,j) * & - (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av(i+1,j)-Rml_av(i,j)) * (h_vel**2) if (uDml(I) == 0) then do k=1,nkml ; uhml(I,j,k) = 0.0 ; enddo @@ -1212,26 +1369,26 @@ subroutine mixedlayer_restrat_BML(h, uhtr, vhtr, tv, forces, dt, G, GV, US, CS) ! V- component !$OMP do do J=js-1,je ; do i=is,ie - h_vel = 0.5*(htot(i,j) + htot(i,j+1)) * GV%H_to_Z + h_vel = 0.5*(htot(i,j) + htot(i,j+1)) u_star = max(CS%ustar_min, 0.5*(U_star_2d(i,j) + U_star_2d(i,j+1))) absf = 0.5*(abs(G%CoriolisBu(I-1,J)) + abs(G%CoriolisBu(I,J))) ! NOTE: growth_time changes answers on some systems, see below. - ! timescale = growth_time(u_star, h_vel, absf, dz_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) + ! timescale = growth_time(u_star, h_vel, absf, h_neglect, CS%vonKar, CS%Kv_restrat, CS%ml_restrat_coef) ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) ! momentum mixing rate: pi^2*visc/h_ml^2 mom_mixrate = vonKar_x_pi2*u_star**2 / & - (absf*h_vel**2 + 4.0*(h_vel+dz_neglect)*u_star) + (absf*h_vel**2 + 4.0*(h_vel+h_neglect)*u_star) timescale = 0.0625 * (absf + 2.0*mom_mixrate) / (absf**2 + mom_mixrate**2) timescale = timescale * CS%ml_restrat_coef ! timescale = timescale*(2?)*(L_def/L_MLI) * min(EKE/MKE,1.0 + (G%dyCv(i,j)/L_def)**2) vDml(i) = timescale * G%OBCmaskCv(i,J)*G%dxCv(i,J)*G%IdyCv(i,J) * & - (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2 * GV%Z_to_H) + (Rml_av(i,j+1)-Rml_av(i,j)) * (h_vel**2) if (vDml(i) == 0) then do k=1,nkml ; vhml(i,J,k) = 0.0 ; enddo else @@ -1301,19 +1458,21 @@ end subroutine mixedlayer_restrat_BML !> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) - real, intent(in) :: u_star !< Surface friction velocity [Z T-1 ~> m s-1] + real, intent(in) :: u_star !< Surface friction velocity in thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1] real, intent(in) :: hBL !< Boundary layer thickness including at least a neglible - !! value to keep it positive definite [Z ~> m] + !! value to keep it positive definite [H ~> m or kg m-2] real, intent(in) :: absf !< Absolute value of the Coriolis parameter [T-1 ~> s-1] - real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be neglected [Z ~> m] - real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification [Z2 T-1 ~> m2 s-1] + real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be + !! neglected [H ~> m or kg m-2] + real, intent(in) :: Kv_rest !< The background laminar vertical viscosity used for restratification, + !! rescaled into thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] real, intent(in) :: vonKar !< The von Karman constant, used to scale the turbulent limits !! on the restratification timescales [nondim] real, intent(in) :: restrat_coef !< An overall scaling factor for the restratification timescale [nondim] ! Local variables real :: mom_mixrate ! rate at which momentum is homogenized within mixed layer [T-1 ~> s-1] - real :: Kv_eff ! An effective overall viscosity [Z2 T-1 ~> m2 s-1] + real :: Kv_eff ! An effective overall viscosity in thickness-based units [H2 T-1 ~> m2 s-1 or kg2 m-4 s-1] real :: pi2 ! A scaling constant that is approximately pi^2 [nondim] ! peak ML visc: u_star * von_Karman * (h_ml*u_star)/(absf*h_ml + 4.0*u_star) + Kv_water @@ -1354,7 +1513,6 @@ 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 @@ -1429,7 +1587,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "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) + units="m2 s-2", default=1.0e-24) ! This parameter stays in MKS units. 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 "//& @@ -1464,7 +1622,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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 + 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.) @@ -1520,23 +1678,21 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "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) + units="m2 s-1", default=0.0, scale=GV%m2_s_to_HZ_T*(US%Z_to_m*GV%m_to_H)) 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) + ustar_min_dflt = 2.0e-4 * omega * (GV%Angstrom_Z + GV%dZ_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) + units="m s-1", default=US%Z_to_m*US%s_to_T*ustar_min_dflt, scale=GV%m_to_H*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', & @@ -1550,13 +1706,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=BLD_units) + 'm', conversion=GV%H_to_m) 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) + 'm', conversion=GV%H_to_m) CS%id_Rml = register_diag_field('ocean_model', 'ML_buoy_restrat', diag%axesT1, Time, & 'Mixed Layer Buoyancy as used in the mixed-layer restratification parameterization', & - 'm s-2', conversion=US%m_to_Z*(US%L_T_to_m_s**2)) + 'm s-2', conversion=GV%m_to_H*(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) @@ -1572,7 +1728,7 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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) + 'm2 s-2', conversion=US%L_to_m*GV%H_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)) @@ -1599,6 +1755,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 + character(len=64) :: mom_flux_units logical :: mixedlayer_restrat_init, use_Bodner ! Check to see if this module will be used @@ -1624,14 +1781,15 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest allocate(CS%MLD_filtered_slow(HI%isd:HI%ied,HI%jsd:HI%jed), source=0.) 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 ARE WRONG -AJA + units=get_thickness_units(GV), conversion=GV%H_to_MKS) endif if (use_Bodner) then ! CS%MLD_filtered_slow is used to keep a running mean of the PBL's seasonal or winter MLD. + mom_flux_units = "m2 s-2" ; if (.not.GV%Boussinesq) mom_flux_units = "kg m-1 s-2" 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 ) + units=mom_flux_units, conversion=US%L_to_m*GV%H_to_mks*US%s_to_T**2 ) endif end subroutine mixedlayer_restrat_register_restarts From d60c2e064e601d565cb4fa260ed885057b73fa8f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 5 Aug 2023 05:46:14 -0400 Subject: [PATCH 386/629] *Non-Boussinesq revision of kappa_shear Remove dependency on the Boussinesq reference density in MOM_kappa_shear when in fully non-Boussinesq mode. This is done by using calls to calculate_density and calculate_specific_vol_derivs to calculate the thermal expansion and haline contraction coefficients, and by using thickness_to_dz to convert layer thicknesses to vertical distances. A large part of the changes to the kappa_shear code involved refactoring it to differentiate between thicknesses and geometric heights by working internally with dynamic viscosities and diffusivities in non-Boussinesq mode, and to keep thicknesses in thickness units rather than converting them to distances in height units. The internal variable dz was renamed to h_lay in Calculate_kappa_shear and Calc_kappa_shear_vertex for greater clarity. The scaling factor for dz_massless is now set to (US%Z_to_m*GV%m_to_H) in Calculate_kappa_shear to reduce the dependency on the Boussinesq reference density; this does not impact answers if RHO_0 = RHO_KV_CONVERT. The internal changes related to this are extensive. This commit includes changing the units of 63 internal variables, and the addition or renaming of 17 internal variables. There are 2 new arguments to find_kappa_tke (one is necessary to differentiate thicknesses from vertical distances and while the other is used to preserve Boussinesq-mode answers), and 1 new argument to kappa_shear_column plus the renaming of another. The units of 13 internal subroutine arguments and 3 elements of the Kappa_shear_CS type change. A total of 6 thickness unit conversion factors were eliminated with these changes. The answers will change in non-Boussinesq mode when the Jackson et al. shear mixing parameterization is in use, but they are bitwise identical in all Boussinesq test cases. There are no changes to external interfaces. --- .../vertical/MOM_kappa_shear.F90 | 569 ++++++++++-------- 1 file changed, 330 insertions(+), 239 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 191b88de0a..81ab0661cc 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -3,18 +3,20 @@ module MOM_kappa_shear ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr -use MOM_diag_mediator, only : diag_ctrl, time_type -use MOM_debugging, only : hchksum, Bchksum -use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density_derivs +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_ptr +use MOM_diag_mediator, only : diag_ctrl, time_type +use MOM_debugging, only : hchksum, Bchksum +use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type +use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density, calculate_specific_vol_derivs implicit none ; private @@ -53,12 +55,12 @@ module MOM_kappa_shear !! the buoyancy and shear scales in the diffusivity !! equation, 0 to eliminate the shear scale [nondim]. real :: TKE_bg !< The background level of TKE [Z2 T-2 ~> m2 s-2]. - real :: kappa_0 !< The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: kappa_0 !< The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_seed !< A moderately large seed value of diapycnal diffusivity that !! is used as a starting turbulent diffusivity in the iterations !! to findind an energetically constrained solution for the - !! shear-driven diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + !! shear-driven diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc !< Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] real :: kappa_tol_err !< The fractional error in kappa that is tolerated [nondim]. real :: Prandtl_turb !< Prandtl number used to convert Kd_shear into viscosity [nondim]. integer :: nkml !< The number of layers in the mixed layer, as @@ -101,7 +103,7 @@ module MOM_kappa_shear type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to !! regulate the timing of diagnostic output. !>@{ Diagnostic IDs - integer :: id_Kd_shear = -1, id_TKE = -1, id_ILd2 = -1, id_dz_Int = -1 + integer :: id_Kd_shear = -1, id_TKE = -1 !>@} end type Kappa_shear_CS @@ -144,30 +146,33 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - kappa_2d, & ! 2-D version of kappa_io [Z2 T-1 ~> m2 s-1]. + kappa_2d, & ! 2-D version of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. real, dimension(SZK_(GV)) :: & - Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - dz, & ! The layer thickness [Z ~> m]. - u0xdz, & ! The initial zonal velocity times dz [Z L T-1 ~> m2 s-1]. - v0xdz, & ! The initial meridional velocity times dz [Z L T-1 ~> m2 s-1]. - T0xdz, & ! The initial temperature times dz [C Z ~> degC m]. - S0xdz ! The initial salinity times dz [S Z ~> ppt m]. + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times thickness [C H ~> degC m or degC kg m-2] or if + ! temperature is not a state variable, the density times thickness [R H ~> kg m-2 or kg2 m-3] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2]. real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 T-1 ~> m2 s-1]. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. - kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. - real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. + real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. - real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. - real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. + real :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -183,13 +188,17 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & use_temperature = associated(tv%T) k0dt = dt*CS%kappa_0 - dz_massless = 0.1*sqrt(k0dt) + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) !$OMP parallel do default(private) shared(js,je,is,ie,nz,h,u_in,v_in,use_temperature,tv,G,GV,US, & !$OMP CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io) do j=js,je + + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_2d, j, G, GV) + do k=1,nz ; do i=is,ie - h_2d(i,k) = h(i,j,k)*GV%H_to_Z + h_2d(i,k) = h(i,j,k) u_2d(i,k) = u_in(i,j,k) ; v_2d(i,k) = v_in(i,j,k) enddo ; enddo if (use_temperature) then ; do k=1,nz ; do i=is,ie @@ -203,26 +212,28 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & !--------------------------------------- do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then ! call cpu_clock_begin(id_clock_setup) + ! Store a transposed version of the initial arrays. ! Any elimination of massless layers would occur here. if (CS%eliminate_massless) then nzc = 1 do k=1,nz ! Zero out the thicknesses of all layers, even if they are unused. - dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 ! Add a new layer if this one has mass. -! if ((dz(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 - if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & +! if ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & (h_2d(i,k) > dz_massless)) nzc = nzc+1 ! Only merge clusters of massless layers. -! if ((dz(nzc) > dz_massless) .or. & -! ((dz(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(i,k) > dz_massless))) nzc = nzc+1 kc(k) = nzc - dz(nzc) = dz(nzc) + h_2d(i,k) + h_lay(nzc) = h_lay(nzc) + h_2d(i,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(i,k) u0xdz(nzc) = u0xdz(nzc) + u_2d(i,k)*h_2d(i,k) v0xdz(nzc) = v0xdz(nzc) + v_2d(i,k)*h_2d(i,k) if (use_temperature) then @@ -236,7 +247,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kc(nz+1) = nzc+1 ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo ! Now determine kf, the fractional weight of interface kc when ! interpolating between interfaces kc and kc+1. @@ -251,21 +262,23 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & kf(nz+1) = 0.0 else do k=1,nz - dz(k) = h_2d(i,k) - u0xdz(k) = u_2d(i,k)*dz(k) ; v0xdz(k) = v_2d(i,k)*dz(k) + h_lay(k) = h_2d(i,k) + dz_lay(k) = dz_2d(i,k) + u0xdz(k) = u_2d(i,k)*h_lay(k) ; v0xdz(k) = v_2d(i,k)*h_lay(k) enddo if (use_temperature) then do k=1,nz - T0xdz(k) = T_2d(i,k)*dz(k) ; S0xdz(k) = S_2d(i,k)*dz(k) + T0xdz(k) = T_2d(i,k)*h_lay(k) ; S0xdz(k) = S_2d(i,k)*h_lay(k) enddo else do k=1,nz - T0xdz(k) = rho_2d(i,k)*dz(k) ; S0xdz(k) = rho_2d(i,k)*dz(k) + T0xdz(k) = rho_2d(i,k)*h_lay(k) ; S0xdz(k) = rho_2d(i,k)*h_lay(k) enddo endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif + f2 = 0.25 * ((G%CoriolisBu(I,j)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I,J-1)**2 + G%CoriolisBu(I-1,J)**2)) surface_pres = 0.0 ; if (associated(p_surf)) surface_pres = p_surf(i,j) @@ -277,7 +290,7 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) ! call cpu_clock_begin(id_clock_setup) @@ -312,9 +325,9 @@ subroutine Calculate_kappa_shear(u_in, v_in, h, tv, p_surf, kappa_io, tke_io, & endif ; enddo ! i-loop do K=1,nz+1 ; do i=is,ie - kappa_io(i,j,K) = G%mask2dT(i,j) * GV%Z_to_H*kappa_2d(i,K) + kappa_io(i,j,K) = G%mask2dT(i,j) * kappa_2d(i,K) tke_io(i,j,K) = G%mask2dT(i,j) * tke_2d(i,K) - kv_io(i,j,K) = ( G%mask2dT(i,j) * GV%Z_to_H*kappa_2d(i,K) ) * CS%Prandtl_turb + kv_io(i,j,K) = ( G%mask2dT(i,j) * kappa_2d(i,K) ) * CS%Prandtl_turb enddo ; enddo enddo ! end of j-loop @@ -368,32 +381,36 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ !! call to kappa_shear_init. ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + dz_3d ! Vertical distance between interface heights [Z ~> m]. real, dimension(SZIB_(G),SZK_(GV)) :: & - h_2d, & ! A 2-D version of h, but converted to [Z ~> m]. + h_2d, & ! A 2-D version of h [H ~> m or kg m-2]. + dz_2d, & ! Vertical distance between interface heights [Z ~> m]. u_2d, v_2d, & ! 2-D versions of u_in and v_in, converted to [L T-1 ~> m s-1]. T_2d, S_2d, rho_2d ! 2-D versions of T [C ~> degC], S [S ~> ppt], and rho [R ~> kg m-3]. real, dimension(SZIB_(G),SZK_(GV)+1,2) :: & - kappa_2d ! Quasi 2-D versions of kappa_io [Z2 T-1 ~> m2 s-1]. + kappa_2d ! Quasi 2-D versions of kappa_io [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZIB_(G),SZK_(GV)+1) :: & tke_2d ! 2-D version tke_io [Z2 T-2 ~> m2 s-2]. real, dimension(SZK_(GV)) :: & - Idz, & ! The inverse of the distance between TKE points [Z-1 ~> m-1]. - dz, & ! The layer thickness [Z ~> m]. - u0xdz, & ! The initial zonal velocity times dz [L Z T-1 ~> m2 s-1]. - v0xdz, & ! The initial meridional velocity times dz [L Z T-1 ~> m2 s-1]. - T0xdz, & ! The initial temperature times dz [C Z ~> degC m]. - S0xdz ! The initial salinity times dz [S Z ~> ppt m]. + Idz, & ! The inverse of the thickness of the merged layers [H-1 ~> m2 kg-1]. + h_lay, & ! The layer thickness [H ~> m or kg m-2] + dz_lay, & ! The geometric layer thickness in height units [Z ~> m] + u0xdz, & ! The initial zonal velocity times dz [L H T-1 ~> m2 s-1 or kg m-1 s-1]. + v0xdz, & ! The initial meridional velocity times dz [H L T-1 ~> m2 s-1 or kg m-1 s-1] + T0xdz, & ! The initial temperature times dz [C H ~> degC m or degC kg m-2] + S0xdz ! The initial salinity times dz [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)+1) :: & - kappa, & ! The shear-driven diapycnal diffusivity at an interface [Z2 T-1 ~> m2 s-1]. + kappa, & ! The shear-driven diapycnal diffusivity at an interface [H Z T-1 ~> m2 s-1 or Pa s] tke, & ! The Turbulent Kinetic Energy per unit mass at an interface [Z2 T-2 ~> m2 s-2]. - kappa_avg, & ! The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + kappa_avg, & ! The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_avg ! The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. real :: f2 ! The squared Coriolis parameter of each column [T-2 ~> s-2]. real :: surface_pres ! The top surface pressure [R L2 T-2 ~> Pa]. - real :: dz_in_lay ! The running sum of the thickness in a layer [Z ~> m]. - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. - real :: dz_massless ! A layer thickness that is considered massless [Z ~> m]. + real :: dz_in_lay ! The running sum of the thickness in a layer [H ~> m or kg m-2] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1] + real :: dz_massless ! A layer thickness that is considered massless [H ~> m or kg m-2] real :: I_hwt ! The inverse of the masked thickness weights [H-1 ~> m-1 or m2 kg-1]. real :: I_Prandtl ! The inverse of the turbulent Prandtl number [nondim]. logical :: use_temperature ! If true, temperature and salinity have been @@ -412,9 +429,12 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ use_temperature = associated(tv%T) k0dt = dt*CS%kappa_0 - dz_massless = 0.1*sqrt(k0dt) + dz_massless = 0.1*sqrt((US%Z_to_m*GV%m_to_H)*k0dt) I_Prandtl = 0.0 ; if (CS%Prandtl_turb > 0.0) I_Prandtl = 1.0 / CS%Prandtl_turb + ! Convert layer thicknesses into geometric thickness in height units. + call thickness_to_dz(h, tv, dz_3d, G, GV, US, halo_size=1) + !$OMP parallel do default(private) shared(jsB,jeB,isB,ieB,nz,h,u_in,v_in,use_temperature,tv,G,GV, & !$OMP US,CS,kappa_io,dz_massless,k0dt,p_surf,dt,tke_io,kv_io,I_Prandtl) do J=JsB,JeB @@ -443,13 +463,17 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ ((G%mask2dT(i+1,j) * h(i+1,j,k)) * S_in(i+1,j,k) + & (G%mask2dT(i,j+1) * h(i,j+1,k)) * S_in(i,j+1,k)) ) * I_hwt endif - h_2d(I,k) = GV%H_to_Z * ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & - (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & - ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & - (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) -! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k)))*GV%H_to_Z + h_2d(I,k) = ((G%mask2dT(i,j) * h(i,j,k) + G%mask2dT(i+1,j+1) * h(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * h(i+1,j,k) + G%mask2dT(i,j+1) * h(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) + dz_2d(I,k) = ((G%mask2dT(i,j) * dz_3d(i,j,k) + G%mask2dT(i+1,j+1) * dz_3d(i+1,j+1,k)) + & + (G%mask2dT(i+1,j) * dz_3d(i+1,j,k) + G%mask2dT(i,j+1) * dz_3d(i,j+1,k)) ) / & + ((G%mask2dT(i,j) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i+1,j) + G%mask2dT(i,j+1)) + 1.0e-36 ) +! h_2d(I,k) = 0.25*((h(i,j,k) + h(i+1,j+1,k)) + (h(i+1,j,k) + h(i,j+1,k))) ! h_2d(I,k) = ((h(i,j,k)**2 + h(i+1,j+1,k)**2) + & -! (h(i+1,j,k)**2 + h(i,j+1,k)**2))*GV%H_to_Z * I_hwt +! (h(i+1,j,k)**2 + h(i,j+1,k)**2)) * I_hwt enddo ; enddo if (.not.use_temperature) then ; do k=1,nz ; do I=IsB,IeB rho_2d(I,k) = GV%Rlay(k) @@ -467,20 +491,21 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ nzc = 1 do k=1,nz ! Zero out the thicknesses of all layers, even if they are unused. - dz(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 + h_lay(k) = 0.0 ; dz_lay(k) = 0.0 ; u0xdz(k) = 0.0 ; v0xdz(k) = 0.0 T0xdz(k) = 0.0 ; S0xdz(k) = 0.0 ! Add a new layer if this one has mass. -! if ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 - if ((k>CS%nkml) .and. (dz(nzc) > 0.0) .and. & +! if ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless)) nzc = nzc+1 + if ((k>CS%nkml) .and. (h_lay(nzc) > 0.0) .and. & (h_2d(I,k) > dz_massless)) nzc = nzc+1 ! Only merge clusters of massless layers. -! if ((dz(nzc) > dz_massless) .or. & -! ((dz(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 +! if ((h_lay(nzc) > dz_massless) .or. & +! ((h_lay(nzc) > 0.0) .and. (h_2d(I,k) > dz_massless))) nzc = nzc+1 kc(k) = nzc - dz(nzc) = dz(nzc) + h_2d(I,k) + h_lay(nzc) = h_lay(nzc) + h_2d(I,k) + dz_lay(nzc) = dz_lay(nzc) + dz_2d(I,k) u0xdz(nzc) = u0xdz(nzc) + u_2d(I,k)*h_2d(I,k) v0xdz(nzc) = v0xdz(nzc) + v_2d(I,k)*h_2d(I,k) if (use_temperature) then @@ -494,7 +519,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kc(nz+1) = nzc+1 ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / h_lay(k) ; enddo ! Now determine kf, the fractional weight of interface kc when ! interpolating between interfaces kc and kc+1. @@ -509,21 +534,23 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ kf(nz+1) = 0.0 else do k=1,nz - dz(k) = h_2d(I,k) - u0xdz(k) = u_2d(I,k)*dz(k) ; v0xdz(k) = v_2d(I,k)*dz(k) + h_lay(k) = h_2d(I,k) + dz_lay(k) = dz_2d(I,k) + u0xdz(k) = u_2d(I,k)*h_lay(k) ; v0xdz(k) = v_2d(I,k)*h_lay(k) enddo if (use_temperature) then do k=1,nz - T0xdz(k) = T_2d(I,k)*dz(k) ; S0xdz(k) = S_2d(I,k)*dz(k) + T0xdz(k) = T_2d(I,k)*h_lay(k) ; S0xdz(k) = S_2d(I,k)*h_lay(k) enddo else do k=1,nz - T0xdz(k) = rho_2d(I,k)*dz(k) ; S0xdz(k) = rho_2d(I,k)*dz(k) + T0xdz(k) = rho_2d(I,k)*h_lay(k) ; S0xdz(k) = rho_2d(I,k)*h_lay(k) enddo endif nzc = nz do k=1,nzc+1 ; kc(k) = k ; kf(k) = 0.0 ; enddo endif + f2 = G%CoriolisBu(I,J)**2 surface_pres = 0.0 if (associated(p_surf)) then @@ -545,7 +572,7 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nzc+1 ; kappa(K) = CS%kappa_seed ; enddo call kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, & - dz, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & + h_lay, dz_lay, u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, & tke_avg, tv, CS, GV, US) ! call cpu_clock_begin(Id_clock_setup) ! Extrapolate from the vertically reduced grid back to the original layers. @@ -578,11 +605,11 @@ subroutine Calc_kappa_shear_vertex(u_in, v_in, h, T_in, S_in, tv, p_surf, kappa_ do K=1,nz+1 ; do I=IsB,IeB tke_io(I,J,K) = G%mask2dBu(I,J) * tke_2d(I,K) - kv_io(I,J,K) = ( G%mask2dBu(I,J) * GV%Z_to_H*kappa_2d(I,K,J2) ) * CS%Prandtl_turb + kv_io(I,J,K) = ( G%mask2dBu(I,J) * kappa_2d(I,K,J2) ) * CS%Prandtl_turb enddo ; enddo if (J>=G%jsc) then ; do K=1,nz+1 ; do i=G%isc,G%iec ! Set the diffusivities in tracer columns from the values at vertices. - kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * GV%Z_to_H * & + kappa_io(i,j,K) = G%mask2dT(i,j) * 0.25 * & ((kappa_2d(I-1,K,J2m1) + kappa_2d(I,K,J2)) + & (kappa_2d(I-1,K,J2) + kappa_2d(I,K,J2m1))) enddo ; enddo ; endif @@ -601,11 +628,11 @@ end subroutine Calc_kappa_shear_vertex !> This subroutine calculates shear-driven diffusivity and TKE in a single column -subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & +subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, hlay, dz_lay, & u0xdz, v0xdz, T0xdz, S0xdz, kappa_avg, tke_avg, tv, CS, GV, US) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)+1), & - intent(inout) :: kappa !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + intent(inout) :: kappa !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZK_(GV)+1), & intent(out) :: tke !< The Turbulent Kinetic Energy per unit mass at !! an interface [Z2 T-2 ~> m2 s-2]. @@ -613,17 +640,20 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & real, intent(in) :: f2 !< The square of the Coriolis parameter [T-2 ~> s-2]. real, intent(in) :: surface_pres !< The surface pressure [R L2 T-2 ~> Pa]. real, dimension(SZK_(GV)), & - intent(in) :: dz !< The layer thickness [Z ~> m]. + intent(in) :: hlay !< The layer thickness [H ~> m or kg m-2] + real, dimension(SZK_(GV)), & + intent(in) :: dz_lay !< The geometric layer thickness in height units [Z ~> m] real, dimension(SZK_(GV)), & - intent(in) :: u0xdz !< The initial zonal velocity times dz [Z L T-1 ~> m2 s-1]. + intent(in) :: u0xdz !< The initial zonal velocity times hlay [H L T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)), & - intent(in) :: v0xdz !< The initial meridional velocity times dz [Z L T-1 ~> m2 s-1]. + intent(in) :: v0xdz !< The initial meridional velocity times the + !! layer thickness [H L T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)), & - intent(in) :: T0xdz !< The initial temperature times dz [C Z ~> degC m]. + intent(in) :: T0xdz !< The initial temperature times hlay [C H ~> degC m or degC kg m-2] real, dimension(SZK_(GV)), & - intent(in) :: S0xdz !< The initial salinity times dz [S Z ~> ppt m]. + intent(in) :: S0xdz !< The initial salinity times hlay [S H ~> ppt m or ppt kg m-2] real, dimension(SZK_(GV)+1), & - intent(out) :: kappa_avg !< The time-weighted average of kappa [Z2 T-1 ~> m2 s-1]. + intent(out) :: kappa_avg !< The time-weighted average of kappa [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(SZK_(GV)+1), & intent(out) :: tke_avg !< The time-weighted average of TKE [Z2 T-2 ~> m2 s-2]. real, intent(in) :: dt !< Time increment [T ~> s]. @@ -646,47 +676,56 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & real, dimension(nzc+1) :: & N2, & ! The squared buoyancy frequency at an interface [T-2 ~> s-2]. - dz_Int, & ! The extent of a finite-volume space surrounding an interface, - ! as used in calculating kappa and TKE [Z ~> m]. + h_Int, & ! The extent of a finite-volume space surrounding an interface, + ! as used in calculating kappa and TKE [H ~> m or kg m-2] + dz_Int, & ! The vertical distance with the space surrounding an interface, + ! as used in calculating kappa and TKE [Z ~> m] + dz_h_Int, & ! The ratio of the vertical distances to the thickness around an + ! interface [Z H-1 ~> nondim or m3 kg-1]. In non-Boussinesq mode + ! this is the specific volume, otherwise it is a scaling factor. I_dz_int, & ! The inverse of the distance between velocity & density points ! above and below an interface [Z-1 ~> m-1]. This is used to - ! calculate N2, shear, and fluxes, and it might differ from - ! 1/dz_Int, as they have different uses. + ! calculate N2, shear and fluxes. S2, & ! The squared shear at an interface [T-2 ~> s-2]. a1, & ! a1 is the coupling between adjacent interfaces in the TKE, - ! velocity, and density equations [Z ~> m] + ! velocity, and density equations [H ~> m or kg m-2] c1, & ! c1 is used in the tridiagonal (and similar) solvers [nondim]. - k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. - kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1]. - kappa_out, & ! The kappa that results from the kappa equation [Z2 T-1 ~> m2 s-1]. - kappa_mid, & ! The average of the initial and predictor estimates of kappa [Z2 T-1 ~> m2 s-1]. + k_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_src, & ! The shear-dependent source term in the kappa equation [T-1 ~> s-1] + kappa_out, & ! The kappa that results from the kappa equation [H Z T-1 ~> m2 s-1 or Pa s] + kappa_mid, & ! The average of the initial and predictor estimates of kappa [H Z T-1 ~> m2 s-1 or Pa s] tke_pred, & ! The value of TKE from a predictor step [Z2 T-2 ~> m2 s-2]. - kappa_pred, & ! The value of kappa from a predictor step [Z2 T-1 ~> m2 s-1]. + kappa_pred, & ! The value of kappa from a predictor step [H Z T-1 ~> m2 s-1 or Pa s] pressure, & ! The pressure at an interface [R L2 T-2 ~> Pa]. T_int, & ! The temperature interpolated to an interface [C ~> degC]. Sal_int, & ! The salinity interpolated to an interface [S ~> ppt]. dbuoy_dT, & ! The partial derivative of buoyancy with changes in temperature [Z T-2 C-1 ~> m s-2 degC-1] dbuoy_dS, & ! The partial derivative of buoyancy with changes in salinity [Z T-2 S-1 ~> m s-2 ppt-1] + dSpV_dT, & ! The partial derivative of specific volume with changes in temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! The partial derivative of specific volume with changes in salinity [R-1 S-1 ~> m3 kg-1 ppt-1] + rho_int, & ! The in situ density interpolated to an interface [R ~> kg m-3] I_L2_bdry, & ! The inverse of the square of twice the harmonic mean - ! distance to the top and bottom boundaries [Z-2 ~> m-2]. - K_Q, & ! Diffusivity divided by TKE [T ~> s]. - K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [T ~> s]. - local_src_avg, & ! The time-integral of the local source [nondim]. + ! distance to the top and bottom boundaries [H-1 Z-1 ~> m-2 or m kg-1]. + K_Q, & ! Diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + K_Q_tmp, & ! A temporary copy of diffusivity divided by TKE [H T Z-1 ~> s or kg s m-3] + local_src_avg, & ! The time-integral of the local source [nondim] tol_min, & ! Minimum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_max, & ! Maximum tolerated ksrc for the corrector step [T-1 ~> s-1]. tol_chg, & ! The tolerated kappa change integrated over a timestep [nondim]. dist_from_top, & ! The distance from the top surface [Z ~> m]. + h_from_top, & ! The total thickness above an interface [H ~> m or kg m-2] local_src ! The sum of all sources of kappa, including kappa_src and - ! sources from the elliptic term [T-1 ~> s-1]. + ! sources from the elliptic term [T-1 ~> s-1] real :: dist_from_bot ! The distance from the bottom surface [Z ~> m]. - real :: b1 ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. - real :: bd1 ! A term in the denominator of b1 [Z ~> m]. + real :: h_from_bot ! The total thickness below and interface [H ~> m or kg m-2] + real :: b1 ! The inverse of the pivot in the tridiagonal equations [H-1 ~> m-1 or m2 kg-1]. + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2]. real :: d1 ! 1 - c1 in the tridiagonal equations [nondim] - real :: gR0 ! A conversion factor from Z to pressure, given by Rho_0 times g - ! [R L2 T-2 Z-1 ~> kg m-2 s-2]. + real :: gR0 ! A conversion factor from H to pressure, Rho_0 times g in Boussinesq + ! mode, or just g when non-Boussinesq [R L2 T-2 H-1 ~> kg m-2 s-2 or m s-2]. real :: g_R0 ! g_R0 is a rescaled version of g/Rho [Z R-1 T-2 ~> m4 kg-1 s-2]. - real :: Norm ! A factor that normalizes two weights to 1 [Z-2 ~> m-2]. + real :: Norm ! A factor that normalizes two weights to 1 [H-2 ~> m-2 or m4 kg-2]. real :: tol_dksrc ! Tolerance for the change in the kappa source within an iteration ! relative to the local source [nondim]. This must be greater than 1. real :: tol2 ! The tolerance for the change in the kappa source within an iteration @@ -702,8 +741,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! gives acceptably small changes in k_src [T ~> s]. real :: Idtt ! Idtt = 1 / dt_test [T-1 ~> s-1]. real :: dt_inc ! An increment to dt_test that is being tested [T ~> s]. - - real :: k0dt ! The background diffusivity times the timestep [Z2 ~> m2]. + real :: wt_a ! The fraction of a layer thickness identified with the interface + ! above a layer [nondim] + real :: wt_b ! The fraction of a layer thickness identified with the interface + ! below a layer [nondim] + real :: k0dt ! The background diffusivity times the timestep [H Z ~> m2 or kg m-1]. logical :: valid_dt ! If true, all levels so far exhibit acceptably small changes in k_src. logical :: use_temperature ! If true, temperature and salinity have been ! allocated and are being used as state variables. @@ -718,8 +760,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! N2_debug, & ! A version of N2 for debugging [T-2 ~> s-2] Ri_crit = CS%Rino_crit - gR0 = GV%Rho0 * GV%g_Earth - g_R0 = (US%L_to_Z**2 * GV%g_Earth) / (GV%Rho0) + gR0 = GV%H_to_RZ * GV%g_Earth + g_R0 = (US%L_to_Z**2 * GV%g_Earth) / GV%Rho0 k0dt = dt*CS%kappa_0 tol_dksrc = CS%kappa_src_max_chg @@ -735,27 +777,37 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! Set up Idz as the inverse of layer thicknesses. - do k=1,nzc ; Idz(k) = 1.0 / dz(k) ; enddo + do k=1,nzc ; Idz(k) = 1.0 / dz_lay(k) ; enddo ! Set up I_dz_int as the inverse of the distance between ! adjacent layer centers. - I_dz_int(1) = 2.0 / dz(1) - dist_from_top(1) = 0.0 + I_dz_int(1) = 2.0 / dz_lay(1) + dist_from_top(1) = 0.0 ; h_from_top(1) = 0.0 do K=2,nzc - I_dz_int(K) = 2.0 / (dz(k-1) + dz(k)) - dist_from_top(K) = dist_from_top(K-1) + dz(k-1) + I_dz_int(K) = 2.0 / (dz_lay(k-1) + dz_lay(k)) + dist_from_top(K) = dist_from_top(K-1) + dz_lay(k-1) + h_from_top(K) = h_from_top(K-1) + hlay(k-1) + enddo + I_dz_int(nzc+1) = 2.0 / dz_lay(nzc) + + ! Find the inverse of the squared distances from the boundaries. + dist_from_bot = 0.0 ; h_from_bot = 0.0 + do K=nzc,2,-1 + dist_from_bot = dist_from_bot + dz_lay(k) + h_from_bot = h_from_bot + hlay(k) + I_L2_bdry(K) = ((dist_from_top(K) + dist_from_bot) * (h_from_top(K) + h_from_bot)) / & + ((dist_from_top(K) * dist_from_bot) * (h_from_top(K) * h_from_bot)) enddo - I_dz_int(nzc+1) = 2.0 / dz(nzc) ! Determine the velocities and thicknesses after eliminating massless ! layers and applying a time-step of background diffusion. if (nzc > 1) then a1(2) = k0dt*I_dz_int(2) - b1 = 1.0 / (dz(1) + a1(2)) + b1 = 1.0 / (hlay(1) + a1(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) - c1(2) = a1(2) * b1 ; d1 = dz(1) * b1 ! = 1 - c1 + c1(2) = a1(2) * b1 ; d1 = hlay(1) * b1 ! = 1 - c1 do k=2,nzc-1 - bd1 = dz(k) + d1*a1(k) + bd1 = hlay(k) + d1*a1(k) a1(k+1) = k0dt*I_dz_int(k+1) b1 = 1.0 / (bd1 + a1(k+1)) u(k) = b1 * (u0xdz(k) + a1(k)*u(k-1)) @@ -767,11 +819,11 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! rho or T and S have insulating boundary conditions, u & v use no-slip ! bottom boundary conditions (if kappa0 > 0). ! For no-slip bottom boundary conditions - b1 = 1.0 / ((dz(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) + b1 = 1.0 / ((hlay(nzc) + d1*a1(nzc)) + k0dt*I_dz_int(nzc+1)) u(nzc) = b1 * (u0xdz(nzc) + a1(nzc)*u(nzc-1)) v(nzc) = b1 * (v0xdz(nzc) + a1(nzc)*v(nzc-1)) ! For insulating boundary conditions - b1 = 1.0 / (dz(nzc) + d1*a1(nzc)) + b1 = 1.0 / (hlay(nzc) + d1*a1(nzc)) T(nzc) = b1 * (T0xdz(nzc) + a1(nzc)*T(nzc-1)) Sal(nzc) = b1 * (S0xdz(nzc) + a1(nzc)*Sal(nzc-1)) do k=nzc-1,1,-1 @@ -780,9 +832,9 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & enddo else ! This is correct, but probably unnecessary. - b1 = 1.0 / (dz(1) + k0dt*I_dz_int(2)) + b1 = 1.0 / (hlay(1) + k0dt*I_dz_int(2)) u(1) = b1 * u0xdz(1) ; v(1) = b1 * v0xdz(1) - b1 = 1.0 / dz(1) + b1 = 1.0 / hlay(1) T(1) = b1 * T0xdz(1) ; Sal(1) = b1 * S0xdz(1) endif @@ -792,33 +844,66 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! layers have thin cells, and the total thickness adds up properly. ! The top- and bottom- interfaces have zero thickness, consistent with ! adding additional zero thickness layers. - dz_Int(1) = 0.0 ; dz_Int(2) = dz(1) + h_Int(1) = 0.0 ; h_Int(2) = hlay(1) + dz_Int(1) = 0.0 ; dz_Int(2) = dz_lay(1) do K=2,nzc-1 - Norm = 1.0 / (dz(k)*(dz(k-1)+dz(k+1)) + 2.0*dz(k-1)*dz(k+1)) - dz_Int(K) = dz_Int(K) + dz(k) * ( ((dz(k)+dz(k+1)) * dz(k-1)) * Norm) - dz_Int(K+1) = dz(k) * ( ((dz(k-1)+dz(k)) * dz(k+1)) * Norm) + Norm = 1.0 / (hlay(k)*(hlay(k-1)+hlay(k+1)) + 2.0*hlay(k-1)*hlay(k+1)) + wt_a = ((hlay(k)+hlay(k+1)) * hlay(k-1)) * Norm + wt_b = ((hlay(k-1)+hlay(k)) * hlay(k+1)) * Norm + h_Int(K) = h_Int(K) + hlay(k) * wt_a + h_Int(K+1) = hlay(k) * wt_b + dz_Int(K) = dz_Int(K) + dz_lay(k) * wt_a + dz_Int(K+1) = dz_lay(k) * wt_b enddo - dz_Int(nzc) = dz_Int(nzc) + dz(nzc) ; dz_Int(nzc+1) = 0.0 + h_Int(nzc) = h_Int(nzc) + hlay(nzc) ; h_Int(nzc+1) = 0.0 + dz_Int(nzc) = dz_Int(nzc) + dz_lay(nzc) ; dz_Int(nzc+1) = 0.0 - dist_from_bot = 0.0 - do K=nzc,2,-1 - dist_from_bot = dist_from_bot + dz(k) - I_L2_bdry(K) = (dist_from_top(K) + dist_from_bot)**2 / & - (dist_from_top(K) * dist_from_bot)**2 - enddo + if (GV%Boussinesq) then + do K=1,nzc+1 ; dz_h_Int(K) = GV%H_to_Z ; enddo + else + ! Find an effective average specific volume around an interface. + dz_h_Int(1:nzc+1) = 0.0 + if (hlay(1) > 0.0) dz_h_Int(1) = dz_lay(1) / hlay(1) + do K=2,nzc+1 + if (h_Int(K) > 0.0) then + dz_h_Int(K) = dz_Int(K) / h_Int(K) + else + dz_h_Int(K) = dz_h_Int(K-1) + endif + enddo + endif ! Calculate thermodynamic coefficients and an initial estimate of N2. if (use_temperature) then pressure(1) = surface_pres do K=2,nzc - pressure(K) = pressure(K-1) + gR0*dz(k-1) + pressure(K) = pressure(K-1) + gR0*hlay(k-1) T_int(K) = 0.5*(T(k-1) + T(k)) Sal_int(K) = 0.5*(Sal(k-1) + Sal(k)) enddo - call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & - tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) - else + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + call calculate_density_derivs(T_int, Sal_int, pressure, dbuoy_dT, dbuoy_dS, & + tv%eqn_of_state, (/2,nzc/), scale=-g_R0 ) + else + ! These should perhaps be combined into a single call to calculate the thermal expansion + ! and haline contraction coefficients? + call calculate_specific_vol_derivs(T_int, Sal_int, pressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,nzc/) ) + call calculate_density(T_int, Sal_int, pressure, rho_int, tv%eqn_of_state, (/2,nzc/) ) + do K=2,nzc + dbuoy_dT(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dT(K)) + dbuoy_dS(K) = (US%L_to_Z**2 * GV%g_Earth) * (rho_int(K) * dSpV_dS(K)) + enddo + endif + elseif (GV%Boussinesq .or. GV%semi_Boussinesq) then do K=1,nzc+1 ; dbuoy_dT(K) = -g_R0 ; dbuoy_dS(K) = 0.0 ; enddo + else + do K=1,nzc+1 ; dbuoy_dS(K) = 0.0 ; enddo + dbuoy_dT(1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(1) + do K=2,nzc + dbuoy_dT(K) = -(US%L_to_Z**2 * GV%g_Earth) / (0.5*(GV%Rlay(k-1) + GV%Rlay(k))) + enddo + dbuoy_dT(nzc+1) = -(US%L_to_Z**2 * GV%g_Earth) / GV%Rlay(nzc) endif ! N2_debug(1) = 0.0 ; N2_debug(nzc+1) = 0.0 @@ -829,7 +914,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! enddo ! This call just calculates N2 and S2. - call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, dz, I_dz_int, dbuoy_dT, dbuoy_dS, & + call calculate_projected_state(kappa, u, v, T, Sal, 0.0, nzc, hlay, I_dz_int, dbuoy_dT, dbuoy_dS, & CS%vel_underflow, u, v, T, Sal, N2, S2, GV, US) ! ---------------------------------------------------- ! Iterate @@ -840,8 +925,8 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & kappa_avg(K) = 0.0 ; tke_avg(K) = 0.0 local_src_avg(K) = 0.0 ! Use the grid spacings to scale errors in the source. - if ( dz_Int(K) > 0.0 ) & - local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / dz_Int(K) + if ( h_Int(K) > 0.0 ) & + local_src_avg(K) = 0.1 * k0dt * I_dz_int(K) / h_Int(K) enddo ! call cpu_clock_end(id_clock_setup) @@ -854,7 +939,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! ---------------------------------------------------- ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q, tke, kappa_out, kappa_src, local_src) ! call cpu_clock_end(id_clock_KQ) @@ -892,7 +977,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! timestep is found long before the minimum is reached, so the ! value of max_KS_it may be unimportant, especially if it is large ! enough. - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*dt_test, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) valid_dt = .true. @@ -925,7 +1010,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & if ((dt_test < dt_rem) .and. valid_dt) then dt_inc = 0.5*dt_test do itt_dt=1,dt_refinements - call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, dz, & + call calculate_projected_state(kappa_out, u, v, T, Sal, 0.5*(dt_test+dt_inc), nzc, hlay, & I_dz_int, dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, T_test, S_test, & N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) valid_dt = .true. @@ -974,14 +1059,14 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & ! call cpu_clock_end(id_clock_avg) else ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_out, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) do K=1,nzc+1 ; K_Q_tmp(K) = K_Q(K) ; enddo - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q_tmp, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) @@ -993,13 +1078,13 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & enddo ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u_test, v_test, & T_test, S_test, N2, S2, GV, US, ks_int=ks_kappa, ke_int=ke_kappa) ! call cpu_clock_end(id_clock_project) ! call cpu_clock_begin(id_clock_KQ) - call find_kappa_tke(N2, S2, kappa_out, Idz, dz_Int, I_L2_bdry, f2, & + call find_kappa_tke(N2, S2, kappa_out, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nzc, CS, GV, US, K_Q, tke_pred, kappa_pred) ! call cpu_clock_end(id_clock_KQ) @@ -1017,7 +1102,7 @@ subroutine kappa_shear_column(kappa, tke, dt, nzc, f2, surface_pres, dz, & if (dt_rem > 0.0) then ! Update the values of u, v, T, Sal, N2, and S2 for the next iteration. ! call cpu_clock_begin(id_clock_project) - call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, dz, I_dz_int, & + call calculate_projected_state(kappa_mid, u, v, T, Sal, dt_now, nzc, hlay, I_dz_int, & dbuoy_dT, dbuoy_dS, CS%vel_underflow, u, v, T, Sal, N2, S2, & GV, US) ! call cpu_clock_end(id_clock_project) @@ -1037,15 +1122,15 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int integer, intent(in) :: nz !< The number of layers (after eliminating massless !! layers?). real, dimension(nz+1), intent(in) :: kappa !< The diapycnal diffusivity at interfaces, - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or Pa s]. real, dimension(nz), intent(in) :: u0 !< The initial zonal velocity [L T-1 ~> m s-1]. real, dimension(nz), intent(in) :: v0 !< The initial meridional velocity [L T-1 ~> m s-1]. real, dimension(nz), intent(in) :: T0 !< The initial temperature [C ~> degC]. real, dimension(nz), intent(in) :: S0 !< The initial salinity [S ~> ppt]. real, intent(in) :: dt !< The time step [T ~> s]. - real, dimension(nz), intent(in) :: dz !< The grid spacing of layers [Z ~> m]. - real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the layer's thicknesses - !! [Z-1 ~> m-1]. + real, dimension(nz), intent(in) :: dz !< The layer thicknesses [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: I_dz_int !< The inverse of the distance between succesive + !! layer centers [Z-1 ~> m-1]. real, dimension(nz+1), intent(in) :: dbuoy_dT !< The partial derivative of buoyancy with !! temperature [Z T-2 C-1 ~> m s-2 degC-1]. real, dimension(nz+1), intent(in) :: dbuoy_dS !< The partial derivative of buoyancy with @@ -1066,9 +1151,9 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int ! Local variables real, dimension(nz+1) :: c1 ! A tridiagonal variable [nondim] - real :: a_a, a_b ! Tridiagonal coupling coefficients [Z ~> m] - real :: b1, b1nz_0 ! Tridiagonal variables [Z-1 ~> m-1] - real :: bd1 ! A term in the denominator of b1 [Z ~> m] + real :: a_a, a_b ! Tridiagonal coupling coefficients [H ~> m or kg m-2] + real :: b1, b1nz_0 ! Tridiagonal variables [H-1 ~> m-1 or m2 kg-1] + real :: bd1 ! A term in the denominator of b1 [H ~> m or kg m-2] real :: d1 ! A tridiagonal variable [nondim] integer :: k, ks, ke @@ -1162,17 +1247,21 @@ subroutine calculate_projected_state(kappa, u0, v0, T0, S0, dt, nz, dz, I_dz_int end subroutine calculate_projected_state !> This subroutine calculates new, consistent estimates of TKE and kappa. -subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & +subroutine find_kappa_tke(N2, S2, kappa_in, Idz, h_Int, dz_Int, dz_h_Int, I_L2_bdry, f2, & nz, CS, GV, US, K_Q, tke, kappa, kappa_src, local_src) integer, intent(in) :: nz !< The number of layers to work on. real, dimension(nz+1), intent(in) :: N2 !< The buoyancy frequency squared at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(in) :: S2 !< The squared shear at interfaces [T-2 ~> s-2]. real, dimension(nz+1), intent(in) :: kappa_in !< The initial guess at the diffusivity - !! [Z2 T-1 ~> m2 s-1]. - real, dimension(nz+1), intent(in) :: dz_Int !< The thicknesses associated with interfaces - !! [Z ~> m]. + !! [H Z T-1 ~> m2 s-1 or Pa s] + real, dimension(nz+1), intent(in) :: h_Int !< The thicknesses associated with interfaces + !! [H ~> m or kg m-2] + real, dimension(nz+1), intent(in) :: dz_Int !< The vertical distances around interfaces [Z ~> m] + real, dimension(nz+1), intent(in) :: dz_h_Int !< The ratio of the vertical distances to the + !! thickness around an interface [Z H-1 ~> nondim or m3 kg-1]. + !! In non-Boussinesq mode this is the specific volume. real, dimension(nz+1), intent(in) :: I_L2_bdry !< The inverse of the squared distance to - !! boundaries [Z-2 ~> m-2]. + !! boundaries [H-1 Z-1 ~> m-2 or m kg-1]. real, dimension(nz), intent(in) :: Idz !< The inverse grid spacing of layers [Z-1 ~> m-1]. real, intent(in) :: f2 !< The squared Coriolis parameter [T-2 ~> s-2]. type(Kappa_shear_CS), pointer :: CS !< A pointer to this module's control structure. @@ -1180,42 +1269,41 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(nz+1), intent(inout) :: K_Q !< The shear-driven diapycnal diffusivity divided by !! the turbulent kinetic energy per unit mass at - !! interfaces [T ~> s]. + !! interfaces [H T Z-1 ~> s or kg s m-3]. real, dimension(nz+1), intent(out) :: tke !< The turbulent kinetic energy per unit mass at !! interfaces [Z2 T-2 ~> m2 s-2]. - real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces - !! [Z2 T-1 ~> m2 s-1]. + real, dimension(nz+1), intent(out) :: kappa !< The diapycnal diffusivity at interfaces + !! [H Z T-1 ~> m2 s-1 or Pa s] real, dimension(nz+1), optional, & - intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1]. + intent(out) :: kappa_src !< The source term for kappa [T-1 ~> s-1] real, dimension(nz+1), optional, & - intent(out) :: local_src !< The sum of all local sources for kappa, - !! [T-1 ~> s-1]. + intent(out) :: local_src !< The sum of all local sources for kappa + !! [T-1 ~> s-1] ! This subroutine calculates new, consistent estimates of TKE and kappa. ! Local variables real, dimension(nz) :: & - aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [Z T-1 ~> m s-1]. + aQ, & ! aQ is the coupling between adjacent interfaces in the TKE equations [H T-1 ~> m s-1 or kg m-2 s-1] dQdz ! Half the partial derivative of TKE with depth [Z T-2 ~> m s-2]. real, dimension(nz+1) :: & - dK, & ! The change in kappa [Z2 T-1 ~> m2 s-1]. + dK, & ! The change in kappa [H Z T-1 ~> m2 s-1 or Pa s]. dQ, & ! The change in TKE [Z2 T-2 ~> m2 s-2]. cQ, cK, & ! cQ and cK are the upward influences in the tridiagonal and ! hexadiagonal solvers for the TKE and kappa equations [nondim]. - I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [Z-2 ~> m-2]. + I_Ld2, & ! 1/Ld^2, where Ld is the effective decay length scale for kappa [H-1 Z-1 ~> m-2 or m kg-1] TKE_decay, & ! The local TKE decay rate [T-1 ~> s-1]. k_src, & ! The source term in the kappa equation [T-1 ~> s-1]. - dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [T ~> s]. - dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [T-1 ~> s-1]. + dQmdK, & ! With Newton's method the change in dQ(k-1) due to dK(k) [Z T H-1 ~> s or m3 s kg-1] + dKdQ, & ! With Newton's method the change in dK(k) due to dQ(k) [H Z-1 T-1 ~> s-1 or kg m-3 s-1] e1 ! The fractional change in a layer TKE due to a change in the ! TKE of the layer above when all the kappas below are 0 [nondim]. ! e1 is nondimensional, and 0 < e1 < 1. - real :: tke_src ! The net source of TKE due to mixing against the shear - ! and stratification [Z2 T-3 ~> m2 s-3]. (For convenience, - ! a term involving the non-dissipation of q0 is also - ! included here.) - real :: bQ ! The inverse of the pivot in the tridiagonal equations [T Z-1 ~> s m-1]. + real :: tke_src ! The net source of TKE due to mixing against the shear and stratification + ! [Z2 T-3 ~> m2 s-3] or [H Z T-3 ~> m2 s-3 or kg m-1 s-3]. + ! (For convenience, a term involving the non-dissipation of q0 is also included here.) + real :: bQ ! The inverse of the pivot in the tridiagonal equations [T H-1 ~> s m-1 or m2 s kg-1] real :: bK ! The inverse of the pivot in the tridiagonal equations [Z-1 ~> m-1]. - real :: bQd1 ! A term in the denominator of bQ [Z T-1 ~> m s-1]. + real :: bQd1 ! A term in the denominator of bQ [H T-1 ~> m s-1 or kg m-2 s-1] real :: bKd1 ! A term in the denominator of bK [Z ~> m]. real :: cQcomp, cKcomp ! 1 - cQ or 1 - cK in the tridiagonal equations [nondim]. real :: c_s2 ! The coefficient for the decay of TKE due to @@ -1228,26 +1316,28 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & real :: Ilambda2 ! 1.0 / CS%lambda**2 [nondim] real :: TKE_min ! The minimum value of shear-driven TKE that can be ! solved for [Z2 T-2 ~> m2 s-2]. - real :: kappa0 ! The background diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. - real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [Z2 T-1 ~> m2 s-1]. + real :: kappa0 ! The background diapycnal diffusivity [H Z T-1 ~> m2 s-1 or Pa s] + real :: kappa_trunc ! Diffusivities smaller than this are rounded to 0 [H Z T-1 ~> m2 s-1 or Pa s] - real :: eden1, eden2 ! Variables used in calculating e1 [Z-1 ~> m-1] - real :: I_eden ! The inverse of the denominator in e1 [Z ~> m] + real :: eden1, eden2 ! Variables used in calculating e1 [H Z-2 ~> m-1 or kg m-4] + real :: I_eden ! The inverse of the denominator in e1 [Z2 H-1 ~> m or m4 kg-1] real :: ome ! Variables used in calculating e1 [nondim] - real :: diffusive_src ! The diffusive source in the kappa equation [Z T-1 ~> m s-1]. + real :: diffusive_src ! The diffusive source in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] real :: chg_by_k0 ! The value of k_src that leads to an increase of - ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1]. + ! kappa_0 if only the diffusive term is a sink [T-1 ~> s-1] + real :: h_dz_here ! The ratio of the thicknesses to the vertical distances around an interface + ! [H Z-1 ~> nondim or kg m-3]. In non-Boussinesq mode this is the density. - real :: kappa_mean ! A mean value of kappa [Z2 T-1 ~> m2 s-1]. + real :: kappa_mean ! A mean value of kappa [H Z T-1 ~> m2 s-1 or Pa s] real :: Newton_test ! The value of relative error that will cause the next ! iteration to use Newton's method [nondim]. ! Temporary variables used in the Newton's method iterations. real :: decay_term_k ! The decay term in the diffusivity equation [Z-1 ~> m-1] - real :: decay_term_Q ! The decay term in the TKE equation - proportional to [T-1 ~> s-1] + real :: decay_term_Q ! The decay term in the TKE equation - proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] real :: I_Q ! The inverse of TKE [T2 Z-2 ~> s2 m-2] - real :: kap_src ! A source term in the kappa equation [Z T-1 ~> m s-1] - real :: v1 ! A temporary variable proportional to [T-1 ~> s-1] - real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] + real :: kap_src ! A source term in the kappa equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: v1 ! A temporary variable proportional to [H Z-1 T-1 ~> s-1 or kg m-3 s-1] + real :: v2 ! A temporary variable in [Z T-2 ~> m s-2] real :: tol_err ! The tolerance for max_err that determines when to ! stop iterating [nondim]. real :: Newton_err ! The tolerance for max_err that determines when to @@ -1271,11 +1361,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! These variables are used only for debugging. logical, parameter :: debug_soln = .false. - real :: K_err_lin ! The imbalance in the K equation [Z T-1 ~> m s-1] - real :: Q_err_lin ! The imbalance in the Q equation [Z2 T-3 ~> m2 s-3] + real :: K_err_lin ! The imbalance in the K equation [H T-1 ~> m s-1 or kg m-2 s-1] + real :: Q_err_lin ! The imbalance in the Q equation [H Z T-3 ~> m2 s-3 or kg m-1 s-3] real, dimension(nz+1) :: & - I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [Z-2 ~> m-2]. - kappa_prev, & ! The value of kappa at the start of the current iteration [Z2 T-1 ~> m2 s-1]. + I_Ld2_debug, & ! A separate version of I_Ld2 for debugging [H-1 Z-1 ~> m-2 or m kg-1]. + kappa_prev, & ! The value of kappa at the start of the current iteration [H Z T-1 ~> m2 s-1 or Pa s] TKE_prev ! The value of TKE at the start of the current iteration [Z2 T-2 ~> m2 s-2]. c_N2 = CS%C_N**2 ; c_S2 = CS%C_S**2 @@ -1333,14 +1423,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! k-1, the final changes in TKE are related by dQ(K+1) = e1(K+1)*dQ(K). eden2 = kappa0 * Idz(nz) if (tke_noflux_bottom_BC) then - eden1 = dz_Int(nz+1)*TKE_decay(nz+1) + eden1 = h_Int(nz+1)*TKE_decay(nz+1) I_eden = 1.0 / (eden2 + eden1) e1(nz+1) = eden2 * I_eden ; ome = eden1 * I_eden else e1(nz+1) = 0.0 ; ome = 1.0 endif do k=nz,2,-1 - eden1 = dz_Int(K)*TKE_decay(K) + ome * eden2 + eden1 = h_Int(K)*TKE_decay(K) + ome * eden2 eden2 = kappa0 * Idz(k-1) I_eden = 1.0 / (eden2 + eden1) e1(K) = eden2 * I_eden ; ome = eden1 * I_eden ! = 1-e1 @@ -1370,20 +1460,20 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & enddo dQ(1) = -TKE(1) if (tke_noflux_top_BC) then - tke_src = kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 - bQd1 = dz_Int(1) * TKE_decay(1) + tke_src = dz_h_Int(1)*kappa0*S2(1) + q0 * TKE_decay(1) ! Uses that kappa(1) = 0 + bQd1 = h_Int(1) * TKE_decay(1) bQ = 1.0 / (bQd1 + aQ(1)) - tke(1) = bQ * (dz_Int(1)*tke_src) + tke(1) = bQ * (h_Int(1)*tke_src) cQ(2) = aQ(1) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ else tke(1) = q0 ; cQ(2) = 0.0 ; cQcomp = 1.0 endif do K=2,ke_tke-1 dQ(K) = -TKE(K) - tke_src = (kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) - bQd1 = dz_Int(K)*(TKE_decay(K) + N2(K)*K_Q(K)) + cQcomp*aQ(k-1) + tke_src = dz_h_Int(K)*(kappa(K) + kappa0)*S2(K) + q0*TKE_decay(K) + bQd1 = h_Int(K)*(TKE_decay(K) + dz_h_Int(K)*N2(K)*K_Q(K)) + cQcomp*aQ(k-1) bQ = 1.0 / (bQd1 + aQ(k)) - tke(K) = bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + tke(K) = bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) cQ(K+1) = aQ(k) * bQ ; cQcomp = bQd1 * bQ ! = 1 - cQ enddo if ((ke_tke == nz+1) .and. .not.(tke_noflux_bottom_BC)) then @@ -1391,18 +1481,18 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dQ(nz+1) = 0.0 else k = ke_tke - tke_src = kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 + tke_src = dz_h_Int(K)*kappa0*S2(K) + q0*TKE_decay(K) ! Uses that kappa(ke_tke) = 0 if (K == nz+1) then dQ(K) = -TKE(K) - bQ = 1.0 / (dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) - tke(K) = max(TKE_min, bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1))) + bQ = 1.0 / (h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + tke(K) = max(TKE_min, bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1))) dQ(K) = tke(K) + dQ(K) else - bQ = 1.0 / ((dz_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) + bQ = 1.0 / ((h_Int(K)*TKE_decay(K) + cQcomp*aQ(k-1)) + aQ(k)) cQ(K+1) = aQ(k) * bQ ! Account for all changes deeper in the water column. dQ(K) = -TKE(K) - tke(K) = max((bQ * (dz_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & + tke(K) = max((bQ * (h_Int(K)*tke_src + aQ(k-1)*tke(K-1)) + & cQ(K+1)*(tke(K+1) - e1(K+1)*tke(K))) / (1.0 - cQ(K+1)*e1(K+1)), TKE_min) dQ(K) = tke(K) + dQ(K) @@ -1432,17 +1522,17 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(1) = 0.0 ! kappa takes boundary values of 0. cK(2) = 0.0 ; cKcomp = 1.0 - if (itt == 1) then ; dO K=2,nz - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + if (itt == 1) then ; do K=2,nz + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) enddo ; endif do K=2,nz dK(K) = -kappa(K) if (itt>1) & - I_Ld2(K) = (N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) - bKd1 = dz_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) + I_Ld2(K) = dz_h_Int(K)*(N2(K)*Ilambda2 + f2) / tke(K) + I_L2_bdry(K) + bKd1 = h_Int(K)*I_Ld2(K) + cKcomp*Idz(k-1) bK = 1.0 / (bKd1 + Idz(k)) - kappa(K) = bK * (Idz(k-1)*kappa(K-1) + dz_Int(K) * K_src(K)) + kappa(K) = bK * (Idz(k-1)*kappa(K-1) + h_Int(K) * K_src(K)) cK(K+1) = Idz(k) * bK ; cKcomp = bKd1 * bK ! = 1 - cK(K+1) ! Neglect values that are smaller than kappa_trunc. @@ -1482,12 +1572,12 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & aQ(1) = (0.5*(kappa(1)+kappa(2))+kappa0) * Idz(1) dQdz(1) = 0.5*(TKE(1) - TKE(2))*Idz(1) if (tke_noflux_top_BC) then - tke_src = dz_Int(1) * (kappa0*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & + tke_src = h_Int(1) * (kappa0*dz_h_Int(1)*S2(1) - (TKE(1) - q0)*TKE_decay(1)) - & aQ(1) * (TKE(1) - TKE(2)) - bQ = 1.0 / (aQ(1) + dz_Int(1)*TKE_decay(1)) + bQ = 1.0 / (aQ(1) + h_Int(1)*TKE_decay(1)) cQ(2) = aQ(1) * bQ - cQcomp = (dz_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) + cQcomp = (h_Int(1)*TKE_decay(1)) * bQ ! = 1 - cQ(2) dQmdK(2) = -dQdz(1) * bQ dQ(1) = bQ * tke_src else @@ -1495,14 +1585,14 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & endif do K=2,nz I_Q = 1.0 / TKE(K) - I_Ld2(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) - kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & + kap_src = h_Int(K) * (K_src(K) - I_Ld2(K)*kappa(K)) + & Idz(k-1)*(kappa(K-1)-kappa(K)) - Idz(k)*(kappa(K)-kappa(K+1)) ! Ensure that the pivot is always positive, and that 0 <= cK <= 1. ! Otherwise do not use Newton's method. - decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + dz_Int(K)*I_Ld2(K) + decay_term_k = -Idz(k-1)*dQmdK(K)*dKdQ(K-1) + h_Int(K)*I_Ld2(K) if (decay_term_k < 0.0) then ; abort_Newton = .true. ; exit ; endif bK = 1.0 / (Idz(k) + Idz(k-1)*cKcomp + decay_term_k) @@ -1528,8 +1618,8 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Solve for dQ(K)... aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) - tke_src = dz_Int(K) * (((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & - (TKE(k) - q0)*TKE_decay(k)) - & + tke_src = h_Int(K) * (dz_h_Int(K)*((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & + (TKE(k) - q0)*TKE_decay(k)) - & (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) v2 = (v1*dQmdK(K) + dQdz(k-1)*cK(K)) + & @@ -1537,7 +1627,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! Ensure that the pivot is always positive, and that 0 <= cQ <= 1. ! Otherwise do not use Newton's method. - decay_term_Q = dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) + decay_term_Q = h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K) - v2*dKdQ(K) if (decay_term_Q < 0.0) then ; abort_Newton = .true. ; exit ; endif bQ = 1.0 / (aQ(k) + (cQcomp*aQ(k-1) + decay_term_Q)) @@ -1560,11 +1650,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & dK(nz+1) = 0.0 ; dKdQ(nz+1) = 0.0 if (tke_noflux_bottom_BC) then K = nz+1 - tke_src = dz_Int(K) * (kappa0*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & + tke_src = h_Int(K) * (kappa0*dz_h_Int(K)*S2(K) - (TKE(K) - q0)*TKE_decay(K)) + & aQ(k-1) * (TKE(K-1) - TKE(K)) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) - decay_term_Q = max(0.0, dz_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) + decay_term_Q = max(0.0, h_Int(K)*TKE_decay(K) - dQdz(k-1)*dKdQ(K-1)*cQ(K)) if (decay_term_Q < 0.0) then abort_Newton = .true. else @@ -1584,9 +1674,9 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & if (debug_soln .and. (K < nz+1)) then ! Ignore this source? aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) - ! tke_src_norm = (dz_Int(K) * (kappa0*S2(K) - (TKE(K)-q0)*TKE_decay(K)) - & + ! tke_src_norm = ((kappa0*dz_Int(K)*S2(K) - h_Int(K)*(TKE(K)-q0)*TKE_decay(K)) - & ! (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) ) / & - ! (aQ(k) + (aQ(k-1) + dz_Int(K)*TKE_decay(K))) + ! (aQ(k) + (aQ(k-1) + h_Int(K)*TKE_decay(K))) endif dK(K) = 0.0 ! Ensure that TKE+dQ will not drop below 0.5*TKE. @@ -1625,23 +1715,24 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & ! The unit conversions here have not been carefully tested. if (debug_soln) then ; do K=2,nz ! In these equations, K_err_lin and Q_err_lin should be at round-off levels - ! compared with the dominant terms, perhaps, dz_Int*I_Ld2*kappa and - ! dz_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been + ! compared with the dominant terms, perhaps, h_Int*I_Ld2*kappa and + ! h_Int*TKE_decay*TKE. The exception is where, either 1) the decay term has been ! been increased to ensure a positive pivot, or 2) negative TKEs have been ! truncated, or 3) small or negative kappas have been rounded toward 0. I_Q = 1.0 / TKE(K) - I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * I_Q + I_L2_bdry(K) + I_Ld2_debug(K) = (N2(K)*Ilambda2 + f2) * dz_h_Int(K)*I_Q + I_L2_bdry(K) - kap_src = dz_Int(K) * (K_src(K) - I_Ld2(K)*kappa_prev(K)) + & + kap_src = h_Int(K) * (k_src(K) - I_Ld2(K)*kappa_prev(K)) + & (Idz(k-1)*(kappa_prev(k-1)-kappa_prev(k)) - & Idz(k)*(kappa_prev(k)-kappa_prev(k+1))) K_err_lin = -Idz(k-1)*(dK(K-1)-dK(K)) + Idz(k)*(dK(K)-dK(K+1)) + & - dz_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & + h_Int(K)*I_Ld2_debug(K)*dK(K) - kap_src - & dz_Int(K)*(N2(K)*Ilambda2 + f2)*I_Q**2*kappa_prev(K) * dQ(K) - tke_src = dz_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & - kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*TKE_decay(K)) - & - (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) + h_dz_here = 0.0 ; if (abs(dz_h_Int(K)) > 0.0) h_dz_here = 1.0 / dz_h_Int(K) + tke_src = h_Int(K) * ((kappa_prev(K) + kappa0)*S2(K) - & + kappa_prev(K)*N2(K) - (TKE_prev(K) - q0)*h_dz_here*TKE_decay(K)) - & + (aQ(k) * (TKE_prev(K) - TKE_prev(K+1)) - aQ(k-1) * (TKE_prev(K-1) - TKE_prev(K))) Q_err_lin = tke_src + (aQ(k-1) * (dQ(K-1)-dQ(K)) - aQ(k) * (dQ(k)-dQ(k+1))) - & 0.5*(TKE_prev(K)-TKE_prev(K+1))*Idz(k) * (dK(K) + dK(K+1)) - & 0.5*(TKE_prev(K)-TKE_prev(K-1))*Idz(k-1)* (dK(K-1) + dK(K)) + & @@ -1701,11 +1792,11 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, dz_Int, I_L2_bdry, f2, & local_src(1) = 0.0 ; local_src(nz+1) = 0.0 do K=2,nz diffusive_src = Idz(k-1)*(kappa(K-1)-kappa(K)) + Idz(k)*(kappa(K+1)-kappa(K)) - chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / dz_Int(K) + I_Ld2(K)) + chg_by_k0 = kappa0 * ((Idz(k-1)+Idz(k)) / h_Int(K) + I_Ld2(K)) if (diffusive_src <= 0.0) then local_src(K) = K_src(K) + chg_by_k0 else - local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / dz_Int(K) + local_src(K) = (K_src(K) + chg_by_k0) + diffusive_src / h_Int(K) endif enddo endif @@ -1790,17 +1881,17 @@ function kappa_shear_init(Time, G, GV, US, param_file, diag, CS) "The background diffusivity that is used to smooth the "//& "density and shear profiles before solving for the "//& "diffusivities. The default is the greater of KD and 1e-7 m2 s-1.", & - units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & + units="m2 s-1", default=kappa_0_default*US%Z2_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & do_not_log=just_read) call get_param(param_file, mdl, "KD_SEED_KAPPA_SHEAR", CS%kappa_seed, & "A moderately large seed value of diapycnal diffusivity that is used as a "//& "starting turbulent diffusivity in the iterations to find an energetically "//& "constrained solution for the shear-driven diffusivity.", & - units="m2 s-1", default=1.0, scale=US%m2_s_to_Z2_T) + units="m2 s-1", default=1.0, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "KD_TRUNC_KAPPA_SHEAR", CS%kappa_trunc, & "The value of shear-driven diffusivity that is considered negligible "//& "and is rounded down to 0. The default is 1% of KD_KAPPA_SHEAR_0.", & - units="m2 s-1", default=0.01*CS%kappa_0*US%Z2_T_to_m2_s, scale=US%m2_s_to_Z2_T, & + units="m2 s-1", default=0.01*CS%kappa_0*GV%HZ_T_to_m2_s, scale=GV%m2_s_to_HZ_T, & do_not_log=just_read) call get_param(param_file, mdl, "FRI_CURVATURE", CS%FRi_curvature, & "The nondimensional curvature of the function of the "//& From c57789f4145e5e7ea9079acd7e63a5e154172769 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Tue, 22 Aug 2023 15:08:29 -0600 Subject: [PATCH 387/629] Rearrange do-loops and if statements Follow Marshall Ward suggestion and rearrange the code to be closer to what the compilers will do (or we hope they would do). This commit aims to potentially enhance performance. Answers are bit-wise identical. --- src/tracer/MOM_neutral_diffusion.F90 | 66 +++++++++++++++++----------- 1 file changed, 40 insertions(+), 26 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 65e2232ab1..d0f75e8197 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -669,9 +669,9 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) ! x-flux if (CS%KhTh_use_ebt_struct) then - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - if (CS%tapering) then + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then ! compute coeff_l and coeff_r and pass them to neutral_surface_flux call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & h(I,j,:), h(I+1,j,:)) @@ -683,7 +683,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%continuous_reconstruction, h_neglect, & CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & CS%coeff_r(:)*CS%Coef_h(i+1,j,:)) - else + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & tracer%t(i,j,:), tracer%t(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), & @@ -693,12 +697,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & CS%Coef_h(i+1,j,:)) endif - endif - enddo ; enddo + enddo ; enddo + endif else - do j = G%jsc,G%jec ; do I = G%isc-1,G%iec - if (G%mask2dCu(I,j)>0.) then - if (CS%tapering) then + if (CS%tapering) then + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then ! compute coeff_l and coeff_r and pass them to neutral_surface_flux call compute_tapering_coeffs(G%ke+1, CS%hbl(I,j), CS%hbl(I+1,j), CS%coeff_l(:), CS%coeff_r(:), & h(I,j,:), h(I+1,j,:)) @@ -710,7 +714,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%continuous_reconstruction, h_neglect, & CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & CS%coeff_r(:)) - else + endif + enddo ; enddo + else + do j = G%jsc,G%jec ; do I = G%isc-1,G%iec + if (G%mask2dCu(I,j)>0.) then call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i+1,j,:), & tracer%t(i,j,:), tracer%t(i+1,j,:), & CS%uPoL(I,j,:), CS%uPoR(I,j,:), & @@ -719,15 +727,15 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%continuous_reconstruction, h_neglect, & CS%remap_CS, h_neglect_edge) endif - endif - enddo ; enddo + enddo ; enddo + endif endif ! y-flux if (CS%KhTh_use_ebt_struct) then - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - if (CS%tapering) then + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then ! compute coeff_l and coeff_r and pass them to neutral_surface_flux call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & h(i,J,:), h(i,J+1,:)) @@ -740,8 +748,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%continuous_reconstruction, h_neglect, & CS%remap_CS, h_neglect_edge, CS%coeff_l(:)*CS%Coef_h(i,j,:), & CS%coeff_r(:)*CS%Coef_h(i,j+1,:)) - else - + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & tracer%t(i,j,:), tracer%t(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), & @@ -751,12 +762,12 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%remap_CS, h_neglect_edge, CS%Coef_h(i,j,:), & CS%Coef_h(i,j+1,:)) endif - endif - enddo ; enddo + enddo ; enddo + endif else - do J = G%jsc-1,G%jec ; do i = G%isc,G%iec - if (G%mask2dCv(i,J)>0.) then - if (CS%tapering) then + if (CS%tapering) then + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then ! compute coeff_l and coeff_r and pass them to neutral_surface_flux call compute_tapering_coeffs(G%ke+1, CS%hbl(i,J), CS%hbl(i,J+1), CS%coeff_l(:), CS%coeff_r(:), & h(i,J,:), h(i,J+1,:)) @@ -769,8 +780,11 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%continuous_reconstruction, h_neglect, & CS%remap_CS, h_neglect_edge, CS%coeff_l(:), & CS%coeff_r(:)) - else - + endif + enddo ; enddo + else + do J = G%jsc-1,G%jec ; do i = G%isc,G%iec + if (G%mask2dCv(i,J)>0.) then call neutral_surface_flux(nk, CS%nsurf, CS%deg, h(i,j,:), h(i,j+1,:), & tracer%t(i,j,:), tracer%t(i,j+1,:), & CS%vPoL(i,J,:), CS%vPoR(i,J,:), & @@ -779,8 +793,8 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) CS%continuous_reconstruction, h_neglect, & CS%remap_CS, h_neglect_edge) endif - endif - enddo ; enddo + enddo ; enddo + endif endif ! Update the tracer concentration from divergence of neutral diffusive flux components From bd5fe0c2ca70b2226dd3bbae7f611ec364ed2063 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 14 May 2023 12:39:38 -0400 Subject: [PATCH 388/629] +(*)Use tv%SpV in MOM_sponge code Use tv%SpV convert thicknesses to vertical distances in apply_sponge when it is allocated to replace multiplication by GV%H_to_Z, thereby eliminating the dependence on GV%RHo_0 in this modue in non-Boussinesq mode. The new internal array dz_to_h is used to reduce the code duplication as a result of these changes. All answers in Boussinesq test cases are bitwise identical, but answers change in fully non-Boussinesq mode. In semi-Boussinesq mode answers are mathematically equivalent but change at roundoff unless RHO_0 is an integer power of 2. --- src/parameterizations/vertical/MOM_sponge.F90 | 76 ++++++++++++++----- 1 file changed, 58 insertions(+), 18 deletions(-) diff --git a/src/parameterizations/vertical/MOM_sponge.F90 b/src/parameterizations/vertical/MOM_sponge.F90 index fce1eb493d..4bdf610a24 100644 --- a/src/parameterizations/vertical/MOM_sponge.F90 +++ b/src/parameterizations/vertical/MOM_sponge.F90 @@ -347,10 +347,14 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) ! give 0 at the surface [nondim]. real :: e(SZK_(GV)+1) ! The interface heights [Z ~> m], usually negative. + real :: dz_to_h(SZK_(GV)+1) ! Factors used to convert interface height movement + ! to thickness fluxes [H Z-1 ~> nondim or kg m-3] real :: e0 ! The height of the free surface [Z ~> m]. real :: e_str ! A nondimensional amount by which the reference ! profile must be stretched for the free surfaces ! heights in the two profiles to agree [nondim]. + real :: w_mean ! The vertical displacement of water moving upward through an + ! interface within 1 timestep [Z ~> m]. real :: w ! The thickness of water moving upward through an ! interface within 1 timestep [H ~> m or kg m-2]. real :: wm ! wm is w if w is negative and 0 otherwise [H ~> m or kg m-2]. @@ -384,9 +388,15 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) "work properly with i-mean sponges and a bulk mixed layer.") do j=js,je ; do i=is,ie ; e_D(i,j,nz+1) = -G%bathyT(i,j) ; enddo ; enddo - do k=nz,1,-1 ; do j=js,je ; do i=is,ie - e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z - enddo ; enddo ; enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo ; enddo ; enddo + else + do k=nz,1,-1 ; do j=js,je ; do i=is,ie + e_D(i,j,K) = e_D(i,j,K+1) + h(i,j,k)*GV%H_to_Z + enddo ; enddo ; enddo + endif do j=js,je do i=is,ie dilate(i) = (G%bathyT(i,j) + G%Z_ref) / (e_D(i,j,1) + G%bathyT(i,j)) @@ -424,20 +434,39 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) do K=2,nz+1 ; do i=is,ie h_above(i,K) = h_above(i,K-1) + max(h(i,j,k-1)-GV%Angstrom_H, 0.0) enddo ; enddo - do K=2,nz - ! w is positive for an upward (lightward) flux of mass, resulting - ! in the downward movement of an interface. - w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H - do i=is,ie + + ! In both blocks below, w is positive for an upward (lightward) flux of mass, + ! resulting in the downward movement of an interface. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=2,nz + w_mean = damp_1pdamp * eta_mean_anom(j,K) + do i=is,ie + w = w_mean * 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + if (w > 0.0) then + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + else + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + endif + enddo + enddo + else + do K=2,nz + w = damp_1pdamp * eta_mean_anom(j,K) * GV%Z_to_H if (w > 0.0) then - w_int(i,j,K) = min(w, h_below(i,K)) - eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + do i=is,ie + w_int(i,j,K) = min(w, h_below(i,K)) + eb(i,j,k-1) = eb(i,j,k-1) + w_int(i,j,K) + enddo else - w_int(i,j,K) = max(w, -h_above(i,K)) - ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + do i=is,ie + w_int(i,j,K) = max(w, -h_above(i,K)) + ea(i,j,k) = ea(i,j,k) - w_int(i,j,K) + enddo endif enddo - enddo + endif do k=1,nz ; do i=is,ie ea_k = max(0.0, -w_int(i,j,K)) eb_k = max(0.0, w_int(i,j,K+1)) @@ -462,9 +491,20 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) damp = dt * CS%Iresttime_col(c) e(1) = 0.0 ; e0 = 0.0 - do K=1,nz - e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z - enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do K=1,nz + e(K+1) = e(K) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + dz_to_h(1) = GV%RZ_to_H / tv%SpV_avg(i,j,1) + do K=2,nz + dz_to_h(K) = 2.0*GV%RZ_to_H / (tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) + enddo + else + do K=1,nz + e(K+1) = e(K) - h(i,j,k)*GV%H_to_Z + dz_to_h(K) = GV%Z_to_H + enddo + endif e_str = e(nz+1) / CS%Ref_eta(nz+1,c) if ( CS%bulkmixedlayer ) then @@ -481,7 +521,7 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) wpb = 0.0; wb = 0.0 do k=nz,nkmb+1,-1 if (GV%Rlay(k) > Rcv_ml(i,j)) then - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w-ABS(w)) do m=1,CS%fldno @@ -537,7 +577,7 @@ subroutine apply_sponge(h, tv, dt, G, GV, US, ea, eb, CS, Rcv_ml) wpb = 0.0 wb = 0.0 do k=nz,1,-1 - w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*GV%Z_to_H, & + w = MIN((((e(K)-e0) - e_str*CS%Ref_eta(K,c)) * damp)*dz_to_h(K), & ((wb + h(i,j,k)) - GV%Angstrom_H)) wm = 0.5*(w - ABS(w)) do m=1,CS%fldno From b3c7331c9ee9306d334cd4a1ea6127fe00c4ccb5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jul 2023 09:49:08 -0400 Subject: [PATCH 389/629] *Non-Boussinesq expressions for DOME inflow rates Set DOME inflow properties using the average density rather than RHO_0 when in non-Boussinesq mode. The existing Boussinesq solutions are unchanged, but this changes the non-Boussinesq DOME solutions, which no longer depend on the Boussinesq reference density. --- src/user/DOME_initialization.F90 | 16 +++++++++++++--- 1 file changed, 13 insertions(+), 3 deletions(-) diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 4a12387d9d..638ecf80db 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -322,6 +322,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) real :: D_edge ! The thickness [Z ~> m] of the dense fluid at the ! inner edge of the inflow real :: RLay_range ! The range of densities [R ~> kg m-3]. + real :: Rlay_Ref ! The surface layer's target density [R ~> kg m-3]. real :: f_0 ! The reference value of the Coriolis parameter [T-1 ~> s-1] real :: f_inflow ! The value of the Coriolis parameter used to determine DOME inflow ! properties [T-1 ~> s-1] @@ -351,6 +352,9 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) call get_param(PF, mdl, "DENSITY_RANGE", Rlay_range, & "The range of reference potential densities in the layers.", & units="kg m-3", default=2.0, scale=US%kg_m3_to_R) + call get_param(PF, mdl, "LIGHTEST_DENSITY", Rlay_Ref, & + "The reference potential density used for layer 1.", & + units="kg m-3", default=US%R_to_kg_m3*GV%Rho0, scale=US%kg_m3_to_R) call get_param(PF, mdl, "F_0", f_0, & "The reference value of the Coriolis parameter with the betaplane option.", & units="s-1", default=0.0, scale=US%T_to_s) @@ -369,9 +373,15 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) if (.not.associated(OBC)) return - g_prime_tot = (GV%g_Earth / GV%Rho0) * Rlay_range - Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) - tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * GV%Z_to_H + if (GV%Boussinesq) then + g_prime_tot = (GV%g_Earth / GV%Rho0) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * GV%Z_to_H + else + g_prime_tot = (GV%g_Earth / (Rlay_Ref + 0.5*Rlay_range)) * Rlay_range + Def_Rad = sqrt(D_edge*g_prime_tot) / abs(f_inflow) + tr_0 = (-D_edge*sqrt(D_edge*g_prime_tot)*0.5*Def_Rad) * (Rlay_Ref + 0.5*Rlay_range) * GV%RZ_to_H + endif I_Def_Rad = 1.0 / (1.0e-3*US%L_to_m*Def_Rad) From 32b5e8aee9185de8d9b055398e79b591d332064f Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 9 Mar 2023 15:12:18 -0500 Subject: [PATCH 390/629] Separate SAL from tidal_forcing Calculation for self-attraction and loading (SAL) is separated as a new module (MOM_self_attr_load) from module MOM_tidal_forcing, as SAL is a process not limited to tides. The new module includes both online spherical harmonics method and scalar approximation. Read-in method (TIDAL_SAL_FROM_FILE) is kept in the tidal forcing module as it is specific to tides. For the iterative method (USE_PREV_TIDES), the updating part that is tied to the scalar approximation is moved to the new SAL model, while the read-in part remains in the tidal_forcing module. The tidal forcing module now only contains calculations independent from the ocean's state and the only input variables is the current time. * A new parameter CALCULATE_SAL is added, which controls SAL calculation in PressureForce independent of whether tides is on or not. The default of CALCULATE_SAL is TIDES to avoid making changes in old MOM_input. * For the unplit mode, runtime parameters calculate_SAL and use_tides are moved from init subroutines to control structures. This allows safe deallocations of the corresponding module CSs. * A new control structure for the SAL module is used by the dynamical cores and pressure force modules. * For SAL related parameters, their names still incorrectly contain TIDE or TIDAL. This will be addressed in the following commits. * A new diagnostic is added in PressureForce to output calculated SAL fields. Note that the 'e_tidal' diagnostic is unchanged and still includes SAL field for backward compatibility. * Subroutine tidal_forcing_sensitivity, which is used by the barotropic solver to take into account the scalar approximation, is renamed to scalar_SAL_sensitivity. * Documentations are updated for the cited papers. --- src/core/MOM_PressureForce.F90 | 10 +- src/core/MOM_PressureForce_FV.F90 | 81 ++++-- src/core/MOM_PressureForce_Montgomery.F90 | 70 +++-- src/core/MOM_barotropic.F90 | 34 ++- src/core/MOM_dynamics_split_RK2.F90 | 13 +- src/core/MOM_dynamics_unsplit.F90 | 20 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 20 +- .../lateral/MOM_load_love_numbers.F90 | 24 +- .../lateral/MOM_self_attr_load.F90 | 271 ++++++++++++++++++ .../lateral/MOM_spherical_harmonics.F90 | 16 +- .../lateral/MOM_tidal_forcing.F90 | 215 ++------------ 11 files changed, 491 insertions(+), 283 deletions(-) create mode 100644 src/parameterizations/lateral/MOM_self_attr_load.F90 diff --git a/src/core/MOM_PressureForce.F90 b/src/core/MOM_PressureForce.F90 index 844d9db4bc..ad76a9a9f5 100644 --- a/src/core/MOM_PressureForce.F90 +++ b/src/core/MOM_PressureForce.F90 @@ -13,6 +13,7 @@ module MOM_PressureForce use MOM_PressureForce_Mont, only : PressureForce_Mont_Bouss, PressureForce_Mont_nonBouss use MOM_PressureForce_Mont, only : PressureForce_Mont_init use MOM_PressureForce_Mont, only : PressureForce_Mont_CS +use MOM_self_attr_load, only : SAL_CS use MOM_tidal_forcing, only : tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -80,7 +81,7 @@ subroutine PressureForce(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm, pbce, e end subroutine Pressureforce !> Initialize the pressure force control structure -subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -88,7 +89,8 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_CS), intent(inout) :: CS !< Pressure force control structure - type(tidal_forcing_CS), intent(inout), optional :: tides_CSp !< Tide control structure + type(SAL_CS), intent(in), optional :: SAL_CSp !< SAL control structure + type(tidal_forcing_CS), intent(in), optional :: tides_CSp !< Tide control structure #include "version_variable.h" character(len=40) :: mdl = "MOM_PressureForce" ! This module's name. @@ -103,10 +105,10 @@ subroutine PressureForce_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) if (CS%Analytic_FV_PGF) then call PressureForce_FV_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_FV, tides_CSp) + CS%PressureForce_FV, SAL_CSp, tides_CSp) else call PressureForce_Mont_init(Time, G, GV, US, param_file, diag, & - CS%PressureForce_Mont, tides_CSp) + CS%PressureForce_Mont, SAL_CSp, tides_CSp) endif end subroutine PressureForce_init diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 281623ae84..27a4e3ae5a 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -9,6 +9,7 @@ module MOM_PressureForce_FV use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss +use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -35,6 +36,7 @@ module MOM_PressureForce_FV !> Finite volume pressure gradient control structure type, public :: PressureForce_FV_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -61,9 +63,11 @@ module MOM_PressureForce_FV logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF integer :: id_e_tidal = -1 !< Diagnostic identifier + integer :: id_e_sal = -1 !< Diagnostic identifier integer :: id_rho_pgf = -1 !< Diagnostic identifier integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier integer :: id_p_stanley = -1 !< Diagnostic identifier + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Tides control structure end type PressureForce_FV_CS @@ -115,8 +119,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ real, dimension(SZI_(G),SZJ_(G)) :: & dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the @@ -301,16 +306,33 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo + ! The following two if-statements are arranged in a way that answers are not + ! changed from old versions in which SAL is part of the tidal forcing module. + if (CS%calculate_SAL) then + ! Find and add the self-attraction and loading geopotential anomaly. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + enddo ; enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif + if (CS%tides) then ! Find and add the tidal geopotential anomaly. + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tidal(i,j)) enddo ; enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_tidal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif @@ -408,7 +430,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) end subroutine PressureForce_FV_nonBouss @@ -441,8 +465,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides [Z ~> m]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. @@ -524,7 +549,9 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 - if (CS%tides) then + ! The following two if-statements are arranged in a way that answers are not + ! changed from old versions in which SAL is part of the tidal forcing module. + if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for @@ -538,21 +565,27 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo endif -! Here layer interface heights, e, are calculated. if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) enddo ; enddo endif + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z @@ -750,12 +783,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! what is used for eta in btstep. See how e was calculated about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tidal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H enddo ; enddo endif endif @@ -797,12 +830,17 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) + if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) + if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) end subroutine PressureForce_FV_Bouss !> Initializes the finite volume pressure gradient control structure -subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -810,6 +848,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_FV_CS), intent(inout) :: CS !< Finite volume PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables @@ -824,6 +863,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS CS%diag => diag ; CS%Time => Time if (present(tides_CSp)) & CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp mdl = "MOM_PressureForce_FV" call log_version(param_file, mdl, version, "") @@ -834,6 +875,8 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) @@ -878,6 +921,10 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, tides_CS CS%id_p_stanley = register_diag_field('ocean_model', 'p_stanley', diag%axesTL, & Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & + Time, 'Self-attraction and loading height Anomaly', 'meter', conversion=US%Z_to_m) + endif if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 424e9b1a32..5223afbccb 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -9,6 +9,7 @@ module MOM_PressureForce_Mont use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -31,6 +32,7 @@ module MOM_PressureForce_Mont !> Control structure for the Montgomery potential form of pressure gradient type, public :: PressureForce_Mont_CS ; private logical :: initialized = .false. !< True if this control structure has been initialized. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: tides !< If true, apply tidal momentum forcing. real :: Rho0 !< The density used in the Boussinesq !! approximation [R ~> kg m-3]. @@ -45,8 +47,9 @@ module MOM_PressureForce_Mont real, allocatable :: PFv_bc(:,:,:) !< Meridional accelerations due to pressure gradients !! deriving from density gradients within layers [L T-2 ~> m s-2]. !>@{ Diagnostic IDs - integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1 + integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1, id_e_sal = -1 !>@} + type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure end type PressureForce_Mont_CS @@ -103,8 +106,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! of a reduced gravity form of the equations [L2 T-2 ~> m2 s-2]. dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. - e_tidal, & ! Bottom geopotential anomaly due to tidal forces from - ! astronomical sources and self-attraction and loading [Z ~> m]. + e_sal, & ! Bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_tidal, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides [Z ~> m]. geopot_bot ! Bottom geopotential relative to a temporally fixed reference value, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -180,7 +184,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif endif - if (CS%tides) then + if (CS%calculate_SAL) then ! Determine the sea surface height anomalies, to enable the calculation ! of self-attraction and loading. !$OMP parallel do default(shared) @@ -203,16 +207,23 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb SSH(i,j) = SSH(i,j) + GV%H_to_RZ * h(i,j,k) * alpha_Lay(k) enddo ; enddo ; enddo endif + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_tidal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tidal(i,j) + G%bathyT(i,j)) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*G%bathyT(i,j) + geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + G%bathyT(i,j)) enddo ; enddo endif @@ -348,7 +359,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) end subroutine PressureForce_Mont_nonBouss @@ -396,9 +409,9 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, real :: h_star(SZI_(G),SZJ_(G)) ! Layer thickness after compensation ! for compressibility [Z ~> m]. real :: SSH(SZI_(G),SZJ_(G)) ! The sea surface height anomaly, in depth units [Z ~> m]. - real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal - ! forces from astronomical sources and self- - ! attraction and loading, in depth units [Z ~> m]. + real :: e_sal(SZI_(G),SZJ_(G)) ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! and harmonic self-attraction and loading specific to tides, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. @@ -440,7 +453,8 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 - if (CS%tides) then + + if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, ! but that is not yet implemented, and the current form is correct for @@ -452,21 +466,26 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_tidal_forcing(CS%Time, SSH, e_tidal, G, US, CS%tides_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo endif -! Here layer interface heights, e, are calculated. if (CS%tides) then + call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_tidal(i,j)) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -G%bathyT(i,j) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) enddo ; enddo endif + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do k=nz,1,-1 ; do i=Isq,Ieq+1 e(i,j,K) = e(i,j,K+1) + h(i,j,k)*GV%H_to_Z @@ -588,19 +607,21 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_tidal(i,j)*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tidal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + e_sal(i,j)*GV%Z_to_H enddo ; enddo endif endif if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. + if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) end subroutine PressureForce_Mont_Bouss @@ -821,7 +842,7 @@ subroutine Set_pbce_nonBouss(p, tv, G, GV, US, GFS_scale, pbce, alpha_star) end subroutine Set_pbce_nonBouss !> Initialize the Montgomery-potential form of PGF control structure -subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_CSp) +subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, tides_CSp) type(time_type), target, intent(in) :: Time !< Current model time type(ocean_grid_type), intent(in) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -829,6 +850,7 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ type(param_file_type), intent(in) :: param_file !< Parameter file handles type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(PressureForce_Mont_CS), intent(inout) :: CS !< Montgomery PGF control structure + type(SAL_CS), intent(in), target, optional :: SAL_CSp !< SAL control structure type(tidal_forcing_CS), intent(in), target, optional :: tides_CSp !< Tides control structure ! Local variables @@ -841,6 +863,8 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ CS%diag => diag ; CS%Time => Time if (present(tides_CSp)) & CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) & + CS%SAL_CSp => SAL_CSp mdl = "MOM_PressureForce_Mont" call log_version(param_file, mdl, version, "") @@ -852,6 +876,8 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ units="kg m-3", default=1035.0, scale=US%R_to_kg_m3) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, mdl, "USE_EOS", use_EOS, default=.true., & do_not_log=.true.) ! Input for diagnostic use only. @@ -866,6 +892,10 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, tides_ allocate(CS%PFv_bc(G%isd:G%ied,G%JsdB:G%JedB,GV%ke), source=0.) endif + if (CS%calculate_SAL) then + CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & + Time, 'SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + endif if (CS%tides) then CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index adbbd3b4dd..c814c563e3 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -23,7 +23,8 @@ module MOM_barotropic use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_segment_type use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_tidal_forcing, only : tidal_forcing_sensitivity, tidal_forcing_CS +use MOM_self_attr_load, only : scalar_SAL_sensitivity +use MOM_self_attr_load, only : SAL_CS use MOM_time_manager, only : time_type, real_to_time, operator(+), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : BT_cont_type, alloc_bt_cont_type @@ -229,7 +230,7 @@ module MOM_barotropic real :: const_dyn_psurf !< The constant that scales the dynamic surface !! pressure [nondim]. Stable values are < ~1.0. !! The default is 0.9. - logical :: tides !< If true, apply tidal momentum forcing. + logical :: calculate_SAL !< If true, calculate self-attration and loading. logical :: tidal_sal_bug !< If true, the tidal self-attraction and loading anomaly in the !! barotropic solver has the wrong sign, replicating a long-standing !! bug. @@ -283,7 +284,7 @@ module MOM_barotropic !! the timing of diagnostic output. type(MOM_domain_type), pointer :: BT_Domain => NULL() !< Barotropic MOM domain type(hor_index_type), pointer :: debug_BT_HI => NULL() !< debugging copy of horizontal index_type - type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< Control structure for tides + type(SAL_CS), pointer :: SAL_CSp => NULL() !< Control structure for SAL logical :: module_is_initialized = .false. !< If true, module has been initialized integer :: isdw !< The lower i-memory limit for the wide halo arrays. @@ -1088,8 +1089,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, enddo endif - if (CS%tides) then - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL) then + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) if (CS%tidal_sal_bug) then dgeo_de = 1.0 + det_de + CS%G_extra else @@ -2845,7 +2846,7 @@ subroutine set_dtbt(G, GV, US, CS, eta, pbce, BT_cont, gtot_est, SSH_add) endif det_de = 0.0 - if (CS%tides) call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL) call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) if (CS%tidal_sal_bug) then dgeo_de = 1.0 + max(0.0, det_de + CS%G_extra) else @@ -4297,7 +4298,7 @@ end subroutine bt_mass_source !! barotropic calculation and initializes any barotropic fields that have not !! already been initialized. subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, & - restart_CS, calc_dtbt, BT_cont, tides_CSp) + restart_CS, calc_dtbt, BT_cont, SAL_CSp) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -4321,8 +4322,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe the !! effective open face areas as a function of !! barotropic flow. - type(tidal_forcing_CS), target, optional :: tides_CSp !< A pointer to the control structure of the - !! tide module. + type(SAL_CS), target, optional :: SAL_CSp !< A pointer to the control structure of the + !! SAL module. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -4348,7 +4349,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, real :: Z_to_H ! A local unit conversion factor [H Z-1 ~> nondim or kg m-3] real :: H_to_Z ! A local unit conversion factor [Z H-1 ~> nondim or m3 kg-1] real :: det_de ! The partial derivative due to self-attraction and loading of the reference - ! geopotential with the sea surface height when tides are enabled [nondim]. + ! geopotential with the sea surface height when scalar SAL are enabled [nondim]. ! This is typically ~0.09 or less. real, allocatable :: lin_drag_h(:,:) ! A spatially varying linear drag coefficient at tracer points ! that acts on the barotropic flow [H T-1 ~> m s-1 or kg m-2 s-1]. @@ -4362,6 +4363,7 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, ! the answers from the end of 2018. Otherwise, use more efficient ! or general expressions. logical :: use_BT_cont_type + logical :: use_tides character(len=48) :: thickness_units, flux_units character*(40) :: hvel_str integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -4383,8 +4385,8 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, CS%module_is_initialized = .true. CS%diag => diag ; CS%Time => Time - if (present(tides_CSp)) then - CS%tides_CSp => tides_CSp + if (present(SAL_CSp)) then + CS%SAL_CSp => SAL_CSp endif ! Read all relevant parameters and write them to the model log. @@ -4523,11 +4525,13 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) - call get_param(param_file, mdl, "TIDES", CS%tides, & + call get_param(param_file, mdl, "TIDES", use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=use_tides) det_de = 0.0 - if (CS%tides .and. associated(CS%tides_CSp)) & - call tidal_forcing_sensitivity(G, CS%tides_CSp, det_de) + if (CS%calculate_SAL .and. associated(CS%SAL_CSp)) & + call scalar_SAL_sensitivity(CS%SAL_CSp, det_de) call get_param(param_file, mdl, "BAROTROPIC_TIDAL_SAL_BUG", CS%tidal_sal_bug, & "If true, the tidal self-attraction and loading anomaly in the barotropic "//& "solver has the wrong sign, replicating a long-standing bug with a scalar "//& diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index eebb7d6b8a..ae9e304736 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -60,6 +60,8 @@ module MOM_dynamics_split_RK2 use MOM_PressureForce, only : PressureForce_init use MOM_set_visc, only : set_viscous_ML, set_visc_CS use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end use MOM_tidal_forcing, only : tidal_forcing_CS use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end use MOM_unit_scaling, only : unit_scale_type @@ -159,6 +161,7 @@ module MOM_dynamics_split_RK2 !! end of the timestep have been stored for use in the next !! predictor step. This is used to accomodate various generations !! of restart files. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: use_tides !< If true, tidal forcing is enabled. logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D !! variables that are needed to reproduce across restarts, @@ -233,6 +236,8 @@ module MOM_dynamics_split_RK2 type(set_visc_CS), pointer :: set_visc_CSp => NULL() !> A pointer to the barotropic stepping control structure type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. @@ -1276,6 +1281,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) call get_param(param_file, mdl, "BE", CS%be, & "If SPLIT is true, BE determines the relative weighting "//& "of a 2nd-order Runga-Kutta baroclinic time stepping "//& @@ -1376,9 +1383,10 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -1414,7 +1422,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%tides_CSp) + CS%SAL_CSp) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then @@ -1710,6 +1718,7 @@ subroutine end_dyn_split_RK2(CS) deallocate(CS%vertvisc_CSp) call hor_visc_end(CS%hor_visc) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) call CoriolisAdv_end(CS%CoriolisAdv) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index 80f7853744..c87e6e9958 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -87,7 +87,8 @@ module MOM_dynamics_unsplit use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -120,6 +121,8 @@ module MOM_dynamics_unsplit !! and in the calculation of the turbulent mixed layer properties !! for viscosity. The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -153,6 +156,8 @@ module MOM_dynamics_unsplit type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. @@ -625,7 +630,6 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -650,8 +654,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -668,9 +674,10 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -722,6 +729,9 @@ subroutine end_dyn_unsplit(CS) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + deallocate(CS) end subroutine end_dyn_unsplit diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index d1afca51d9..b515229566 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -86,7 +86,8 @@ module MOM_dynamics_unsplit_RK2 use MOM_open_boundary, only : open_boundary_zero_normal_flow use MOM_PressureForce, only : PressureForce, PressureForce_init, PressureForce_CS use MOM_set_visc, only : set_viscous_ML, set_visc_CS -use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_CS +use MOM_self_attr_load, only : SAL_init, SAL_end, SAL_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end, tidal_forcing_CS use MOM_unit_scaling, only : unit_scale_type use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_init, vertvisc_CS use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units @@ -123,6 +124,8 @@ module MOM_dynamics_unsplit_RK2 !! turbulent mixed layer properties for viscosity. !! The default should be true, but it is false. logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -156,6 +159,8 @@ module MOM_dynamics_unsplit_RK2 type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() !> A pointer to the set_visc control structure type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp !> A pointer to the tidal forcing control structure type(tidal_forcing_CS) :: tides_CSp !> A pointer to the ALE control structure. @@ -573,7 +578,6 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" - logical :: use_tides integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -614,8 +618,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) - call get_param(param_file, mdl, "TIDES", use_tides, & + call get_param(param_file, mdl, "TIDES", CS%use_tides, & "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) @@ -632,9 +638,10 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) - if (use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & - CS%tides_CSp) + CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc) call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & ntrunc, CS%vertvisc_CSp) @@ -685,6 +692,9 @@ subroutine end_dyn_unsplit_RK2(CS) DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + deallocate(CS) end subroutine end_dyn_unsplit_RK2 diff --git a/src/parameterizations/lateral/MOM_load_love_numbers.F90 b/src/parameterizations/lateral/MOM_load_love_numbers.F90 index 84819b5915..3d573d894d 100644 --- a/src/parameterizations/lateral/MOM_load_love_numbers.F90 +++ b/src/parameterizations/lateral/MOM_load_love_numbers.F90 @@ -1452,30 +1452,32 @@ module MOM_load_love_numbers /), (/4, lmax+1/)) !< Load Love numbers !> \namespace mom_load_love_numbers -!! This module serves the sole purpose of storing load Love number. The Love numbers are used for the self-attraction -!! and loading (SAL) calculation, which is currently embedded in MOM_tidal_forcing module. This separate module ensures -!! the readability of the tidal module. +!! This module serves the sole purpose of storing load Love number. The Love numbers are used for the spherical harmonic +!! self-attraction and loading (SAL) calculation in MOM_self_attr_load module. This separate module ensures readability +!! of the SAL module. !! !! Variable Love_Data stores the Love numbers up to degree 1440. From left to right: degree, h, l, and k. Data in this !! module is imported from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los Alamos -!! National Laboratory and University of Michigan (Barton et al. (2022) and Brus et al. (2022)). The load Love numbers +!! National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2022)]. The load Love numbers !! are from Wang et al. (2012), which are in the center of mass of total Earth system reference frame (CM). When used, -!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) (Blewitt (2003)), +!! Love numbers with degree<2 should be converted to center of mass solid Earth reference frame (CF) [Blewitt (2003)], !! as in subroutine calc_love_scaling in MOM_tidal_forcing module. !! !! References: !! -!! Barton, K.N., Nairita, P., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J., -!! Wirasaet, D., and Schindelegger, M., 2022: Performance of Model for Prediction Across Scales (MPAS) Ocean as a -!! Global Barotropic Tide Model. Journal of Advances in Modeling Earth Systems, in review. +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 !! !! Blewitt, G., 2003. Self‐consistency in reference frames, geocenter definition, and surface loading of the solid !! Earth. Journal of geophysical research: solid earth, 108(B2). !! https://doi.org/10.1029/2002JB002082 !! -!! Brus, S.R., Barton, K.N., Nairita, P., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., -!! Westerink, J., and Schindelegger, M., 2022: Scalable self attraction and loading calculations for unstructured ocean -!! models. Ocean Modelling, in review. +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 !! !! Wang, H., Xiang, L., Jia, L., Jiang, L., Wang, Z., Hu, B. and Gao, P., 2012. Load Love numbers and Green's functions !! for elastic Earth models PREM, iasp91, ak135, and modified models with refined crustal structure from Crust 2.0. diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 new file mode 100644 index 0000000000..fb27cfa346 --- /dev/null +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -0,0 +1,271 @@ +module MOM_self_attr_load + +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax +use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse +use MOM_spherical_harmonics, only : sht_CS +use MOM_load_love_numbers, only : Love_Data + +implicit none ; private + +public calc_SAL, scalar_SAL_sensitivity, SAL_init, SAL_end + +#include + +!> The control structure for the MOM_self_attr_load module +type, public :: SAL_CS ; private + logical :: use_sal_scalar !< If true, use the scalar approximation when + !! calculating self-attraction and loading. + real :: sal_scalar !< The constant of proportionality between sea surface + !! height (really it should be bottom pressure) anomalies + !! and bottom geopotential anomalies [nondim]. + logical :: use_prev_tides !< If true, use the SAL from the previous iteration of the tides + !! to facilitate convergence. + logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL + type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL + integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] + real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] + real, allocatable :: Snm_Re(:), & !< Real and imaginary SHT coefficient for SHT SAL + Snm_Im(:) !< [Z ~> m] +end type SAL_CS + +integer :: id_clock_SAL !< CPU clock for self-attraction and loading + +contains + +!> This subroutine calculates seawater self-attraction and loading based on sea surface height. This should +!! be changed into bottom pressure anomaly in the future. Note that the SAL calculation applies to all motions +!! across the spectrum. Tidal-specific methods that assume periodicity, i.e. iterative and read-in SAL, are +!! stored in MOM_tidal_forcing module. +subroutine calc_SAL(eta, eta_sal, G, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from + !! a time-mean geoid [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from + !! self-attraction and loading [Z ~> m]. + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + + ! Local variables + integer :: n, m, l + integer :: Isq, Ieq, Jsq, Jeq + integer :: i, j + real :: eta_prop + + call cpu_clock_begin(id_clock_SAL) + + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + ! use the scalar approximation, iterative tidal SAL or no SAL + call scalar_SAL_sensitivity(CS, eta_prop) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = eta_prop*eta(i,j) + enddo ; enddo + + if (CS%use_sal_sht) then ! use the spherical harmonics method + call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) + + ! Multiply scaling factors to each mode + do m = 0,CS%sal_sht_Nd + l = order2index(m, CS%sal_sht_Nd) + do n = m,CS%sal_sht_Nd + CS%Snm_Re(l+n-m) = CS%Snm_Re(l+n-m) * CS%Love_Scaling(l+n-m) + CS%Snm_Im(l+n-m) = CS%Snm_Im(l+n-m) * CS%Love_Scaling(l+n-m) + enddo + enddo + + call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) + + call pass_var(eta_sal, G%domain) + endif + + call cpu_clock_end(id_clock_SAL) +end subroutine calc_SAL + +!> This subroutine calculates the partial derivative of the local geopotential height with the input +!! sea surface height due to the scalar approximation of self-attraction and loading. +subroutine scalar_SAL_sensitivity(CS, deta_sal_deta) + type(SAL_CS), intent(in) :: CS !< The control structure returned by a previous call to SAL_init. + real, intent(out) :: deta_sal_deta !< The partial derivative of eta_sal with + !! the local value of eta [nondim]. + + if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then + deta_sal_deta = 2.0*CS%SAL_SCALAR + elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then + deta_sal_deta = CS%SAL_SCALAR + else + deta_sal_deta = 0.0 + endif +end subroutine scalar_SAL_sensitivity + +!> This subroutine calculates coefficients of the spherical harmonic modes for self-attraction and loading. +!! The algorithm is based on the SAL implementation in MPAS-ocean, which was modified by Kristin Barton from +!! routine written by K. Quinn (March 2010) and modified by M. Schindelegger (May 2017). +subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) + integer, intent(in) :: nlm !< Maximum spherical harmonics degree [nondim] + real, intent(in) :: rhoW !< The average density of sea water [R ~> kg m-3] + real, intent(in) :: rhoE !< The average density of Earth [R ~> kg m-3] + real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] + + ! Local variables + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers + integer :: n_tot ! Size of the stored Love numbers + integer :: n, m, l + + n_tot = size(Love_Data, dim=2) + + if (nlm+1 > n_tot) call MOM_error(FATAL, "MOM_tidal_forcing " // & + "calc_love_scaling: maximum spherical harmonics degree is larger than " // & + "the size of the stored Love numbers in MOM_load_love_number.") + + allocate(HDat(nlm+1), LDat(nlm+1), KDat(nlm+1)) + HDat(:) = Love_Data(2,1:nlm+1) ; LDat(:) = Love_Data(3,1:nlm+1) ; KDat(:) = Love_Data(4,1:nlm+1) + + ! Convert reference frames from CM to CF + if (nlm > 0) then + H1 = HDat(2) ; L1 = LDat(2) ; K1 = KDat(2) + HDat(2) = ( 2.0 / 3.0) * (H1 - L1) + LDat(2) = (-1.0 / 3.0) * (H1 - L1) + KDat(2) = (-1.0 / 3.0) * H1 - (2.0 / 3.0) * L1 - 1.0 + endif + + do m=0,nlm ; do n=m,nlm + l = order2index(m,nlm) + Love_Scaling(l+n-m) = (3.0 / real(2*n+1)) * (rhoW / rhoE) * (1.0 + KDat(n+1) - HDat(n+1)) + enddo ; enddo +end subroutine calc_love_scaling + +!> This subroutine initializeds the self-attraction and loading control structure. +subroutine SAL_init(G, US, param_file, CS) + type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. + type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + +# include "version_variable.h" + character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. + integer :: lmax ! Total modes of the real spherical harmonics [nondim] + real :: rhoW ! The average density of sea water [R ~> kg m-3]. + real :: rhoE ! The average density of Earth [R ~> kg m-3]. + + logical :: calculate_sal + logical :: tides, tidal_sal_from_file + + ! Read all relevant parameters and write them to the model log. + call log_version(param_file, mdl, version, "") + + call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) + + CS%use_prev_tides = .false. + tidal_sal_from_file = .false. + if (tides) then + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_prev_tides,& + default=.false., do_not_log=.True.) + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", tidal_sal_from_file,& + default=.false., do_not_log=.True.) + endif + + call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & + "If true and TIDES is true, use the scalar approximation "//& + "when calculating self-attraction and loading.", & + default=.not.tidal_sal_from_file) + if (CS%use_sal_scalar .or. CS%use_prev_tides) & + call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & + fail_if_missing=.true.) + + call get_param(param_file, mdl, "TIDAL_SAL_SHT", CS%use_sal_sht, & + "If true, use the online spherical harmonics method to calculate "//& + "self-attraction and loading term in tides.", default=.false.) + + call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, & + "If true, calculate self-attraction and loading.", default=tides) + + ! ! Default USE_SAL is TRUE for now to keep backward compatibility with old MOM_INPUT files. It should be changed to + ! ! FALSE in the future (mostly to avoid the SSH calculations in MOM_PressureForce). In that case, the following check + ! ! informs prior tidal experiments that use scalar or iterative SAL to include USE_SAL flag, as the USE_SAL flag + ! ! overrules the option flags. + ! if ((.not. calculate_sal) .and. (CS%use_prev_tides .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & + ! call MOM_error(FATAL, trim(mdl)//": USE_SAL is False but one of the options is True. Nothing will happen.") + + if (CS%use_sal_sht) then + call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & + "The maximum degree of the spherical harmonics transformation used for "// & + "calculating the self-attraction and loading term.", & + default=0, do_not_log=.not. CS%use_sal_sht) + call get_param(param_file, mdl, "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) + call get_param(param_file, mdl, "RHO_E", rhoE, & + "The mean solid earth density. This is used for calculating the "// & + "self-attraction and loading term.", units="kg m-3", & + default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) + lmax = calc_lmax(CS%sal_sht_Nd) + allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 + allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 + + allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 + call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) + call spherical_harmonics_init(G, param_file, CS%sht) + endif + + id_clock_SAL = cpu_clock_id('(Ocean SAL)', grain=CLOCK_MODULE) + +end subroutine SAL_init + +!> This subroutine deallocates memory associated with the SAL module. +subroutine SAL_end(CS) + type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call + !! to SAL_init; it is deallocated here. + if (CS%use_sal_sht) then + if (allocated(CS%Love_Scaling)) deallocate(CS%Love_Scaling) + if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) + if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) + call spherical_harmonics_end(CS%sht) + endif +end subroutine SAL_end + +!> \namespace self_attr_load +!! +!! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) +!! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or +!! storm surges, but the effect applys to all motions. +!! +!! If TIDE_USE_SAL_SCALAR is true, a scalar approximiation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usualy around 10% for global tides) of local SSH . For the tides, the +!! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, +!! Arbic et al. (2004)]. +!! +!! If TIDAL_SAL_SHT is true, a more accurate online spherical harmonic transforms are used to calculate SAL. +!! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by +!! TIDAL_SAL_SHT_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean +!! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. +!! +!! References: +!! +!! Accad, Y. and Pekeris, C.L., 1978. Solution of the tidal equations for the M2 and S2 tides in the world oceans from a +!! knowledge of the tidal potential alone. Philosophical Transactions of the Royal Society of London. Series A, +!! Mathematical and Physical Sciences, 290(1368), pp.235-266. +!! https://doi.org/10.1098/rsta.1978.0083 +!! +!! Arbic, B.K., Garner, S.T., Hallberg, R.W. and Simmons, H.L., 2004. The accuracy of surface elevations in forward +!! global barotropic and baroclinic tide models. Deep Sea Research Part II: Topical Studies in Oceanography, 51(25-26), +!! pp.3069-3101. +!! https://doi.org/10.1016/j.dsr2.2004.09.014 +!! +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 +!! +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 +end module MOM_self_attr_load diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 95a9df808c..b20df036e0 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -330,7 +330,7 @@ end function order2index !! Currently, the transforms are for t-cell fields only. !! !! This module is stemmed from SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean developed by Los -!! Alamos National Laboratory and University of Michigan (Barton et al. (2022) and Brus et al. (2022)). The algorithm +!! Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. The algorithm !! for forward and inverse transforms loosely follows Schaeffer (2013). !! !! In forward transform, a two-dimensional physical field can be projected into a series of spherical harmonics. The @@ -368,13 +368,15 @@ end function order2index !! !! References: !! -!! Barton, K.N., Nairita, P., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J., -!! Wirasaet, D., and Schindelegger, M., 2022: Performance of Model for Prediction Across Scales (MPAS) Ocean as a -!! Global Barotropic Tide Model. Journal of Advances in Modeling Earth Systems, in review. +!! Barton, K.N., Pal, N., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J.J., +!! Wirasaet, D. and Schindelegger, M., 2022. Global Barotropic Tide Modeling Using Inline Self‐Attraction and Loading in +!! MPAS‐Ocean. Journal of Advances in Modeling Earth Systems, 14(11), p.e2022MS003207. +!! https://doi.org/10.1029/2022MS003207 !! -!! Brus, S.R., Barton, K.N., Nairita, P., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., -!! Westerink, J., and Schindelegger, M., 2022: Scalable self attraction and loading calculations for unstructured ocean -!! models. Ocean Modelling, in review. +!! Brus, S.R., Barton, K.N., Pal, N., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., +!! Westerink, J.J. and Schindelegger, M., 2023. Scalable self attraction and loading calculations for unstructured ocean +!! tide models. Ocean Modelling, p.102160. +!! https://doi.org/10.1016/j.ocemod.2023.102160 !! !! Schaeffer, N., 2013. Efficient spherical harmonic transforms aimed at pseudospectral numerical simulations. !! Geochemistry, Geophysics, Geosystems, 14(3), pp.751-758. diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index b2fd8f0ea5..358ec3dc57 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -12,15 +12,10 @@ module MOM_tidal_forcing use MOM_io, only : field_exists, file_exists, MOM_read_data use MOM_time_manager, only : set_date, time_type, time_type_to_real, operator(-) use MOM_unit_scaling, only : unit_scale_type -use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax -use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse -use MOM_spherical_harmonics, only : sht_CS -use MOM_load_love_numbers, only : Love_Data implicit none ; private public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end -public tidal_forcing_sensitivity ! MOM_open_boundary uses the following to set tides on the boundary. public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency @@ -38,8 +33,6 @@ module MOM_tidal_forcing !> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private - logical :: use_sal_scalar !< If true, use the scalar approximation when - !! calculating self-attraction and loading. logical :: tidal_sal_from_file !< If true, Read the tidal self-attraction !! and loading from input files, specified !! by TIDAL_INPUT_FILE. @@ -49,7 +42,6 @@ module MOM_tidal_forcing !! equilibrium tide. Set to false if providing tidal phases !! that have already been shifted by the !! astronomical/equilibrium argument. - logical :: tidal_sal_sht !< If true, use online spherical harmonics to calculate SAL real :: sal_scalar !< The constant of proportionality between sea surface !! height (really it should be bottom pressure) anomalies !! and bottom geopotential anomalies [nondim]. @@ -76,15 +68,9 @@ module MOM_tidal_forcing cosphase_prev(:,:,:), & !< The cosine of the phase of the amphidromes in the previous tidal solutions [nondim]. sinphase_prev(:,:,:), & !< The sine of the phase of the amphidromes in the previous tidal solutions [nondim]. amp_prev(:,:,:) !< The amplitude of the previous tidal solution [Z ~> m]. - type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL - integer :: sal_sht_Nd !< Maximum degree for SHT [nondim] - real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nondim] - real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] - Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] end type tidal_forcing_CS integer :: id_clock_tides !< CPU clock for tides -integer :: id_clock_SAL !< CPU clock for self-attraction and loading contains @@ -366,12 +352,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) - call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation "//& - "when calculating self-attraction and loading.", & - default=.not.CS%tidal_sal_from_file) ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_sal_scalar .or. CS%use_prev_tides) & + if (CS%use_prev_tides) & call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & "The constant of proportionality between sea surface "//& "height (really it should be bottom pressure) anomalies "//& @@ -379,10 +361,6 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & fail_if_missing=.true.) - call get_param(param_file, mdl, "TIDAL_SAL_SHT", CS%tidal_sal_sht, & - "If true, use the online spherical harmonics method to calculate "//& - "self-attraction and loading term in tides.", default=.false.) - if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & &"to accommodate all the registered tidal constituents.")') nc @@ -542,74 +520,10 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif - if (CS%tidal_sal_sht) then - call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & - "The maximum degree of the spherical harmonics transformation used for "// & - "calculating the self-attraction and loading term for tides.", & - default=0, do_not_log=.not.CS%tidal_sal_sht) - call get_param(param_file, mdl, "RHO_0", rhoW, & - "The mean ocean density used with BOUSSINESQ true to "//& - "calculate accelerations and the mass for conservation "//& - "properties, or with BOUSSINSEQ false to convert some "//& - "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) - call get_param(param_file, mdl, "RHO_E", rhoE, & - "The mean solid earth density. This is used for calculating the "// & - "self-attraction and loading term.", & - units="kg m-3", default=5517.0, scale=US%kg_m3_to_R, & - do_not_log=.not.CS%tidal_sal_sht) - lmax = calc_lmax(CS%sal_sht_Nd) - allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 - allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 - - allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 - call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) - call spherical_harmonics_init(G, param_file, CS%sht) - id_clock_SAL = cpu_clock_id('(Ocean SAL)', grain=CLOCK_ROUTINE) - endif - id_clock_tides = cpu_clock_id('(Ocean tides)', grain=CLOCK_MODULE) end subroutine tidal_forcing_init -!> This subroutine calculates coefficients of the spherical harmonic modes for self-attraction and loading. -!! The algorithm is based on the SAL implementation in MPAS-ocean, which was modified by Kristin Barton from -!! routine written by K. Quinn (March 2010) and modified by M. Schindelegger (May 2017). -subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) - integer, intent(in) :: nlm !< Maximum spherical harmonics degree [nondim] - real, intent(in) :: rhoW !< The average density of sea water [R ~> kg m-3] - real, intent(in) :: rhoE !< The average density of Earth [R ~> kg m-3] - real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] - - ! Local variables - real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] - real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] - integer :: n_tot ! Size of the stored Love numbers - integer :: n, m, l - - n_tot = size(Love_Data, dim=2) - - if (nlm+1 > n_tot) call MOM_error(FATAL, "MOM_tidal_forcing " // & - "calc_love_scaling: maximum spherical harmonics degree is larger than " // & - "the size of the stored Love numbers in MOM_load_love_number.") - - allocate(HDat(nlm+1), LDat(nlm+1), KDat(nlm+1)) - HDat(:) = Love_Data(2,1:nlm+1) ; LDat(:) = Love_Data(3,1:nlm+1) ; KDat(:) = Love_Data(4,1:nlm+1) - - ! Convert reference frames from CM to CF - if (nlm > 0) then - H1 = HDat(2) ; L1 = LDat(2) ; K1 = KDat(2) - HDat(2) = ( 2.0 / 3.0) * (H1 - L1) - LDat(2) = (-1.0 / 3.0) * (H1 - L1) - KDat(2) = (-1.0 / 3.0) * H1 - (2.0 / 3.0) * L1 - 1.0 - endif - - do m=0,nlm ; do n=m,nlm - l = order2index(m,nlm) - Love_Scaling(l+n-m) = (3.0 / real(2*n+1)) * (rhoW / rhoE) * (1.0 + KDat(n+1) - HDat(n+1)) - enddo ; enddo -end subroutine calc_love_scaling - !> This subroutine finds a named variable in a list of files and reads its !! values into a domain-decomposed 2-d array subroutine find_in_files(filenames, varname, array, G, scale) @@ -643,47 +557,21 @@ subroutine find_in_files(filenames, varname, array, G, scale) end subroutine find_in_files -!> This subroutine calculates returns the partial derivative of the local -!! geopotential height with the input sea surface height due to self-attraction -!! and loading. -subroutine tidal_forcing_sensitivity(G, CS, deta_tidal_deta) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a previous call to tidal_forcing_init. - real, intent(out) :: deta_tidal_deta !< The partial derivative of eta_tidal with - !! the local value of eta [nondim]. - - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - deta_tidal_deta = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - deta_tidal_deta = CS%SAL_SCALAR - else - deta_tidal_deta = 0.0 - endif -end subroutine tidal_forcing_sensitivity - !> This subroutine calculates the geopotential anomalies that drive the tides, -!! including self-attraction and loading. Optionally, it also returns the -!! partial derivative of the local geopotential height with the input sea surface -!! height. For now, eta and eta_tidal are both geopotential heights in depth -!! units, but probably the input for eta should really be replaced with the -!! column mass anomalies. -subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) +!! including tidal self-attraction and loading from previous solutions. +subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< The time for the calculation. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from - !! a time-mean geoid [Z ~> m]. + type(time_type), intent(in) :: Time !< The time for the caluculation. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height !! anomalies [Z ~> m]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a !! previous call to tidal_forcing_init. ! Local variables - real, dimension(SZI_(G),SZJ_(G)) :: eta_sal !< SAL calculated by spherical harmonics real :: now ! The relative time compared with the tidal reference [T ~> s] real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] real :: cosomegat, sinomegat ! The components of the phase [nondim] - real :: eta_prop ! The nondimenional constant of proportionality between eta and eta_tidal [nondim] integer :: i, j, c, m, 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 @@ -697,16 +585,8 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) now = US%s_to_T * time_type_to_real(Time - cs%time_ref) - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - eta_prop = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - eta_prop = CS%SAL_SCALAR - else - eta_prop = 0.0 - endif - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_prop*eta(i,j) + eta_tidal(i,j) = 0.0 enddo ; enddo do c=1,CS%nc @@ -737,50 +617,10 @@ subroutine calc_tidal_forcing(Time, eta, eta_tidal, G, US, CS) enddo ; enddo enddo ; endif - if (CS%tidal_sal_sht) then - eta_sal(:,:) = 0.0 - call calc_SAL_sht(eta, eta_sal, G, CS) - - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + eta_sal(i,j) - enddo ; enddo - endif call cpu_clock_end(id_clock_tides) end subroutine calc_tidal_forcing -!> This subroutine calculates self-attraction and loading using the spherical harmonics method. -subroutine calc_SAL_sht(eta, eta_sal, G, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from - !! a time-mean geoid [Z ~> m]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from - !! self-attraction and loading [Z ~> m]. - type(tidal_forcing_CS), intent(inout) :: CS !< Tidal forcing control structure - - ! Local variables - integer :: n, m, l - - call cpu_clock_begin(id_clock_SAL) - - call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) - - ! Multiply scaling factors to each mode - do m = 0,CS%sal_sht_Nd - l = order2index(m, CS%sal_sht_Nd) - do n = m,CS%sal_sht_Nd - CS%Snm_Re(l+n-m) = CS%Snm_Re(l+n-m) * CS%Love_Scaling(l+n-m) - CS%Snm_Im(l+n-m) = CS%Snm_Im(l+n-m) * CS%Love_Scaling(l+n-m) - enddo - enddo - - call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) - - call pass_var(eta_sal, G%domain) - - call cpu_clock_end(id_clock_SAL) -end subroutine calc_SAL_sht - !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call @@ -796,13 +636,6 @@ subroutine tidal_forcing_end(CS) if (allocated(CS%cosphase_prev)) deallocate(CS%cosphase_prev) if (allocated(CS%sinphase_prev)) deallocate(CS%sinphase_prev) if (allocated(CS%amp_prev)) deallocate(CS%amp_prev) - - if (CS%tidal_sal_sht) then - if (allocated(CS%Love_Scaling)) deallocate(CS%Love_Scaling) - if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) - if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) - call spherical_harmonics_end(CS%sht) - endif end subroutine tidal_forcing_end !> \namespace tidal_forcing @@ -823,28 +656,16 @@ end subroutine tidal_forcing_end !! can be changed at run time by setting variables like TIDE_M2_FREQ, !! TIDE_M2_AMP and TIDE_M2_PHASE_T0 (for M2). !! -!! In addition, the approach to calculating self-attraction and -!! loading is set at run time. The default is to use the scalar -!! approximation, with a coefficient TIDE_SAL_SCALAR_VALUE that must -!! be set in the run-time file (for global runs, 0.094 is typical). -!! Alternately, TIDAL_SAL_FROM_FILE can be set to read the SAL from -!! a file containing the results of a previous simulation. To iterate -!! the SAL to convergence, USE_PREVIOUS_TIDES may be useful (for -!! details, see Arbic et al., 2004, DSR II). With TIDAL_SAL_FROM_FILE -!! or USE_PREVIOUS_TIDES,a list of input files must be provided to -!! describe each constituent's properties from a previous solution. -!! -!! This module also contains a method to calculate self-attraction -!! and loading using spherical harmonic transforms. The algorithm is -!! based on SAL calculation in Model for Prediction Across Scales -!! (MPAS)-Ocean developed by Los Alamos National Laboratory and -!! University of Michigan (Barton et al. (2022) and Brus et al. (2022)). -!! -!! Barton, K.N., Nairita, P., Brus, S.R., Petersen, M.R., Arbic, B.K., Engwirda, D., Roberts, A.F., Westerink, J., -!! Wirasaet, D., and Schindelegger, M., 2022: Performance of Model for Prediction Across Scales (MPAS) Ocean as a -!! Global Barotropic Tide Model. Journal of Advances in Modeling Earth Systems, in review. -!! -!! Brus, S.R., Barton, K.N., Nairita, P., Roberts, A.F., Engwirda, D., Petersen, M.R., Arbic, B.K., Wirasaet, D., -!! Westerink, J., and Schindelegger, M., 2022: Scalable self attraction and loading calculations for unstructured ocean -!! models. Ocean Modelling, in review. +!! In addition, approaches to calculate self-attraction and loading +!! due to tides (harmonics of astronomical forcing frequencies) +!! are provided. TIDAL_SAL_FROM_FILE can be set to read the phase and +!! amplitude of the tidal SAL. USE_PREVIOUS_TIDES may be useful in +!! combination with the scalar approximation to iterate the SAL to +!! convergence (for details, see Arbic et al., 2004, DSR II). With +!! TIDAL_SAL_FROM_FILE or USE_PREVIOUS_TIDES, a list of input files +!! must be provided to describe each constituent's properties from +!! a previous solution. The online SAL calculations that are functions +!! of SSH (rather should be bottom pressure anmoaly), either a scalar +!! approximation or with spherical harmonic transforms, are located in +!! MOM_self_attr_load. end module MOM_tidal_forcing From 4fec906695f8dc7ae16ead8d9d2b9b7f2a5d3b88 Mon Sep 17 00:00:00 2001 From: He Wang Date: Wed, 26 Apr 2023 09:54:15 -0400 Subject: [PATCH 391/629] Decompose output from calc_tidal_forcing The output field eta_tidal from subroutine calc_tidal_forcing originally contains both equilibrium tides and tidal SAL that is based on previous solutions (TIDAL_SAL_FROM_FILE and USE_PREV_TIDES). This commit decompose the two fields for better diagnostics. This also makes answers using USE_PREV_TIDES is not changed if only one tidal constituent is used. New diagnostics ('e_tidal_eq' and 'e_tidal_sal') are added in pressure force modules for the decomposed fields. Note that 'e_tidal' still includes all tidal fields + SAL fields to be backward compatible. --- src/core/MOM_PressureForce_FV.F90 | 54 ++++++++++++------- src/core/MOM_PressureForce_Montgomery.F90 | 50 ++++++++++------- .../lateral/MOM_tidal_forcing.F90 | 36 +++++++------ 3 files changed, 86 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 27a4e3ae5a..4dc354b01c 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -62,7 +62,9 @@ module MOM_PressureForce_FV !! By the default (1) is for a piecewise linear method logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF - integer :: id_e_tidal = -1 !< Diagnostic identifier + integer :: id_e_tide = -1 !< Diagnostic identifier + integer :: id_e_tide_eq = -1 !< Diagnostic identifier + integer :: id_e_tide_sal = -1 !< Diagnostic identifier integer :: id_e_sal = -1 !< Diagnostic identifier integer :: id_rho_pgf = -1 !< Diagnostic identifier integer :: id_rho_stanley_pgf = -1 !< Diagnostic identifier @@ -120,8 +122,9 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ dp, & ! The (positive) change in pressure across a layer [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides [Z ~> m]. + e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the @@ -324,10 +327,10 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ if (CS%tides) then ! Find and add the tidal geopotential anomaly. - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tidal(i,j)) + za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo else !$OMP parallel do default(shared) @@ -430,9 +433,12 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ endif endif - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_FV_nonBouss @@ -466,13 +472,15 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - e_tidal, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides [Z ~> m]. + e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. dM ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. real, dimension(SZI_(G)) :: & - Rho_cv_BL ! The coordinate potential density in the deepest variable + Rho_cv_BL ! The coordinate potential density in the deepest variable ! density near-surface layer [R ~> kg m-3]. real, dimension(SZI_(G),SZJ_(G)) :: & dz_geo, & ! The change in geopotential thickness through a layer [L2 T-2 ~> m2 s-2]. @@ -574,10 +582,10 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -783,7 +791,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! what is used for eta in btstep. See how e was calculated about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tidal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) @@ -830,9 +838,13 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif endif - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) + if (CS%id_rho_pgf>0) call post_data(CS%id_rho_pgf, rho_pgf, CS%diag) if (CS%id_rho_stanley_pgf>0) call post_data(CS%id_rho_stanley_pgf, rho_stanley_pgf, CS%diag) if (CS%id_p_stanley>0) call post_data(CS%id_p_stanley, p_stanley, CS%diag) @@ -922,12 +934,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, Time, 'p in PGF with Stanley correction', 'Pa', conversion=US%RL2_T2_to_Pa) endif if (CS%calculate_SAL) then - CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & - Time, 'Self-attraction and loading height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, & + Time, 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif if (CS%tides) then - CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 5223afbccb..c687c0a40a 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -47,7 +47,8 @@ module MOM_PressureForce_Mont real, allocatable :: PFv_bc(:,:,:) !< Meridional accelerations due to pressure gradients !! deriving from density gradients within layers [L T-2 ~> m s-2]. !>@{ Diagnostic IDs - integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_tidal = -1, id_e_sal = -1 + integer :: id_PFu_bc = -1, id_PFv_bc = -1, id_e_sal = -1 + integer :: id_e_tide = -1, id_e_tide_eq = -1, id_e_tide_sal = -1 !>@} type(SAL_CS), pointer :: SAL_CSp => NULL() !< SAL control structure type(tidal_forcing_CS), pointer :: tides_CSp => NULL() !< The tidal forcing control structure @@ -107,8 +108,9 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb dp_star, & ! Layer thickness after compensation for compressibility [R L2 T-2 ~> Pa]. SSH, & ! The sea surface height anomaly, in depth units [Z ~> m]. e_sal, & ! Bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - e_tidal, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides [Z ~> m]. + e_tide_eq, & ! Bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. + e_tide_sal, & ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides [Z ~> m]. geopot_bot ! Bottom geopotential relative to a temporally fixed reference value, ! including any tidal contributions [L2 T-2 ~> m2 s-2]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate @@ -215,10 +217,10 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tidal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j) + G%bathyT(i,j)) enddo ; enddo else !$OMP parallel do default(shared) @@ -359,9 +361,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_Mont_nonBouss @@ -410,8 +415,10 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! for compressibility [Z ~> m]. real :: SSH(SZI_(G),SZJ_(G)) ! The sea surface height anomaly, in depth units [Z ~> m]. real :: e_sal(SZI_(G),SZJ_(G)) ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. - real :: e_tidal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources - ! and harmonic self-attraction and loading specific to tides, in depth units [Z ~> m]. + real :: e_tide_eq(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to tidal forces from astronomical sources + ! [Z ~> m]. + real :: e_tide_sal(SZI_(G),SZJ_(G)) ! Bottom geopotential anomaly due to harmonic self-attraction and loading + ! specific to tides, in depth units [Z ~> m]. real :: p_ref(SZI_(G)) ! The pressure used to calculate the coordinate ! density [R L2 T-2 ~> Pa] (usually 2e7 Pa = 2000 dbar). real :: I_Rho0 ! 1/Rho0 [R-1 ~> m3 kg-1]. @@ -474,10 +481,10 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, endif if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tidal, G, US, CS%tides_CSp) + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tidal(i,j))) + e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -607,7 +614,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! about 200 lines above. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tidal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) @@ -619,9 +626,12 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, if (CS%id_PFu_bc>0) call post_data(CS%id_PFu_bc, CS%PFu_bc, CS%diag) if (CS%id_PFv_bc>0) call post_data(CS%id_PFv_bc, CS%PFv_bc, CS%diag) - ! To be consistent with old runs, tidal forcing diagnostic also includes SAL. - if (CS%id_e_tidal>0) call post_data(CS%id_e_tidal, e_sal+e_tidal, CS%diag) + ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. + ! New diagnostics are given for each individual field. + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) + if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) + if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) end subroutine PressureForce_Mont_Bouss @@ -893,12 +903,16 @@ subroutine PressureForce_Mont_init(Time, G, GV, US, param_file, diag, CS, SAL_CS endif if (CS%calculate_SAL) then - CS%id_e_sal = register_diag_field('ocean_model', 'e_SAL', diag%axesT1, & - Time, 'SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_sal = register_diag_field('ocean_model', 'e_sal', diag%axesT1, Time, & + 'Self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif if (CS%tides) then - CS%id_e_tidal = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, & - Time, 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide = register_diag_field('ocean_model', 'e_tidal', diag%axesT1, Time, & + 'Tidal Forcing Astronomical and SAL Height Anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_eq = register_diag_field('ocean_model', 'e_tide_eq', diag%axesT1, Time, & + 'Equilibrium tides height anomaly', 'meter', conversion=US%Z_to_m) + CS%id_e_tide_sal = register_diag_field('ocean_model', 'e_tide_sal', diag%axesT1, Time, & + 'Read-in tidal self-attraction and loading height anomaly', 'meter', conversion=US%Z_to_m) endif CS%GFS_scale = 1.0 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 358ec3dc57..fcd90a4171 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -559,14 +559,16 @@ end subroutine find_in_files !> This subroutine calculates the geopotential anomalies that drive the tides, !! including tidal self-attraction and loading from previous solutions. -subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(time_type), intent(in) :: Time !< The time for the caluculation. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_tidal !< The tidal forcing geopotential height - !! anomalies [Z ~> m]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a - !! previous call to tidal_forcing_init. +subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. ! Local variables real :: now ! The relative time compared with the tidal reference [T ~> s] @@ -578,23 +580,23 @@ subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) call cpu_clock_begin(id_clock_tides) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + if (CS%nc == 0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 ; eta_tidal(i,j) = 0.0 ; enddo ; enddo return endif now = US%s_to_T * time_type_to_real(Time - cs%time_ref) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = 0.0 - enddo ; enddo - do c=1,CS%nc m = CS%struct(c) amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & + e_tide_eq(i,j) = e_tide_eq(i,j) + (amp_cosomegat*CS%cos_struct(i,j,m) + & amp_sinomegat*CS%sin_struct(i,j,m)) enddo ; enddo enddo @@ -603,8 +605,8 @@ subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) + CS%ampsal(i,j,c) * & - (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + e_tide_sal(i,j) = e_tide_sal(i,j) + CS%ampsal(i,j,c) * & + (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) enddo ; enddo enddo ; endif @@ -612,7 +614,7 @@ subroutine calc_tidal_forcing(Time, eta_tidal, G, US, CS) cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_tidal(i,j) = eta_tidal(i,j) - CS%SAL_SCALAR*CS%amp_prev(i,j,c) * & + e_tide_sal(i,j) = e_tide_sal(i,j) - CS%sal_scalar * CS%amp_prev(i,j,c) * & (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) enddo ; enddo enddo ; endif From b69d6fbd5256cd773c18b13a63920a17b9d6531d Mon Sep 17 00:00:00 2001 From: He Wang Date: Tue, 6 Jun 2023 12:21:23 -0400 Subject: [PATCH 392/629] Fix SSH for calculating SAL with flooding points SSH for SAL is modified for grid points with topography above the reference height z_ref (assumed to be land that can be flooded). Instead of eta anomaly referenced to z_ref, eta anomaly referenced to the bottom depth is used for these grid points. --- src/core/MOM_PressureForce_FV.F90 | 5 +++-- src/core/MOM_PressureForce_Montgomery.F90 | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4dc354b01c..25301ae31d 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -315,7 +315,8 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ ! Find and add the self-attraction and loading geopotential anomaly. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref + SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & + - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) else @@ -567,7 +568,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm !$OMP parallel do default(shared) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - SSH(i,j) = -G%bathyT(i,j) - G%Z_ref + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) enddo do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index c687c0a40a..53f6a5a925 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -191,7 +191,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb ! of self-attraction and loading. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - SSH(i,j) = -G%bathyT(i,j) - G%Z_ref + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) enddo ; enddo if (use_EOS) then !$OMP parallel do default(shared) @@ -468,7 +468,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, ! barotropic tides. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 - do i=Isq,Ieq+1 ; SSH(i,j) = -G%bathyT(i,j) - G%Z_ref ; enddo + do i=Isq,Ieq+1 ; SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) ; enddo do k=1,nz ; do i=Isq,Ieq+1 SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo From b94a32c35d9674f1fb476b8803e584744bac9d94 Mon Sep 17 00:00:00 2001 From: He Wang Date: Tue, 6 Jun 2023 13:02:47 -0400 Subject: [PATCH 393/629] Renaming input parameter names for the SAL module Remove "TIDAL" and "TIDE" from the relevant input names of the SAL module, as SAL is not specific to the tides. This affects both scalar approximation and the fully online spherical harmonic options. * For scalar SAL, old parameter names are still acceptable, but a WARNING is given if these old names appear in MOM_input. * For read-in SAL, no change is made. * For iterative method (use_prev_tides), the use of TIDE_SAL_SCALAR_VALUE is completely deprecated, as this is a feature that is rarely used. * For harmonic SAL, a relatively recent feature, a hard obsolete is applied, i.e. if the old parameters are specified, a FATAL error is given, unless the new parameters also exist and match the values of the old parameters. List of input names changed: * TIDE_USE_SAL_SCALAR -> USE_SAL_SCALAR * TIDE_SAL_SCALAR_VALUE -> SAL_SCALAR_VALUE * TIDAL_SAL_SHT -> USE_SAL_HARMONICS * TIDAL_SAL_SHT_DEGREE -> SAL_HARMONICS_DEGREE --- .../lateral/MOM_self_attr_load.F90 | 173 +++++++++++------- .../lateral/MOM_tidal_forcing.F90 | 28 ++- 2 files changed, 117 insertions(+), 84 deletions(-) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index fb27cfa346..be45f64cfe 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -1,15 +1,16 @@ module MOM_self_attr_load -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE -use MOM_domains, only : pass_var -use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end, order2index, calc_lmax +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE +use MOM_domains, only : pass_var +use MOM_error_handler, only : MOM_error, FATAL, WARNING +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_obsolete_params, only : obsolete_logical, obsolete_int +use MOM_grid, only : ocean_grid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_spherical_harmonics, only : spherical_harmonics_init, spherical_harmonics_end use MOM_spherical_harmonics, only : spherical_harmonics_forward, spherical_harmonics_inverse -use MOM_spherical_harmonics, only : sht_CS -use MOM_load_love_numbers, only : Love_Data +use MOM_spherical_harmonics, only : sht_CS, order2index, calc_lmax +use MOM_load_love_numbers, only : Love_Data implicit none ; private @@ -19,19 +20,18 @@ module MOM_self_attr_load !> The control structure for the MOM_self_attr_load module type, public :: SAL_CS ; private - logical :: use_sal_scalar !< If true, use the scalar approximation when - !! calculating self-attraction and loading. - real :: sal_scalar !< The constant of proportionality between sea surface - !! height (really it should be bottom pressure) anomalies - !! and bottom geopotential anomalies [nondim]. - logical :: use_prev_tides !< If true, use the SAL from the previous iteration of the tides - !! to facilitate convergence. - logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL - type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) for SAL - integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] + logical :: use_sal_scalar !< If true, use the scalar approximation to calculate SAL. + logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL + logical :: use_tidal_sal_prev !< If true, read the tidal SAL from the previous iteration of + !! the tides to facilitate convergence. + real :: sal_scalar_value !< The constant of proportionality between sea surface height + !! (really it should be bottom pressure) anomalies and bottom + !! geopotential anomalies [nondim]. + type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) control structure + integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] - real, allocatable :: Snm_Re(:), & !< Real and imaginary SHT coefficient for SHT SAL - Snm_Im(:) !< [Z ~> m] + real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] + Snm_Im(:) !< Imaginary SHT coefficient for SHT SAL [Z ~> m] end type SAL_CS integer :: id_clock_SAL !< CPU clock for self-attraction and loading @@ -60,13 +60,15 @@ subroutine calc_SAL(eta, eta_sal, G, CS) Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - ! use the scalar approximation, iterative tidal SAL or no SAL - call scalar_SAL_sensitivity(CS, eta_prop) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta_sal(i,j) = eta_prop*eta(i,j) - enddo ; enddo + ! use the scalar approximation and/or iterative tidal SAL + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + call scalar_SAL_sensitivity(CS, eta_prop) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = eta_prop*eta(i,j) + enddo ; enddo - if (CS%use_sal_sht) then ! use the spherical harmonics method + ! use the spherical harmonics method + elseif (CS%use_sal_sht) then call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) ! Multiply scaling factors to each mode @@ -79,8 +81,13 @@ subroutine calc_SAL(eta, eta_sal, G, CS) enddo call spherical_harmonics_inverse(G, CS%sht, CS%Snm_Re, CS%Snm_Im, eta_sal, CS%sal_sht_Nd) - + ! Halo was not calculated in spherical harmonic transforms. call pass_var(eta_sal, G%domain) + + else + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_sal(i,j) = 0.0 + enddo ; enddo endif call cpu_clock_end(id_clock_SAL) @@ -93,10 +100,10 @@ subroutine scalar_SAL_sensitivity(CS, deta_sal_deta) real, intent(out) :: deta_sal_deta !< The partial derivative of eta_sal with !! the local value of eta [nondim]. - if (CS%USE_SAL_SCALAR .and. CS%USE_PREV_TIDES) then - deta_sal_deta = 2.0*CS%SAL_SCALAR - elseif (CS%USE_SAL_SCALAR .or. CS%USE_PREV_TIDES) then - deta_sal_deta = CS%SAL_SCALAR + if (CS%use_sal_scalar .and. CS%use_tidal_sal_prev) then + deta_sal_deta = 2.0*CS%sal_scalar_value + elseif (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + deta_sal_deta = CS%sal_scalar_value else deta_sal_deta = 0.0 endif @@ -140,13 +147,14 @@ subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) enddo ; enddo end subroutine calc_love_scaling -!> This subroutine initializeds the self-attraction and loading control structure. +!> This subroutine initializes the self-attraction and loading control structure. subroutine SAL_init(G, US, param_file, CS) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters. type(SAL_CS), intent(inout) :: CS !< Self-attraction and loading control structure + ! Local variables # include "version_variable.h" character(len=40) :: mdl = "MOM_self_attr_load" ! This module's name. integer :: lmax ! Total modes of the real spherical harmonics [nondim] @@ -154,58 +162,87 @@ subroutine SAL_init(G, US, param_file, CS) real :: rhoE ! The average density of Earth [R ~> kg m-3]. logical :: calculate_sal - logical :: tides, tidal_sal_from_file + logical :: tides, use_tidal_sal_file + real :: tide_sal_scalar_value ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) - - CS%use_prev_tides = .false. - tidal_sal_from_file = .false. if (tides) then - call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_prev_tides,& + call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & default=.false., do_not_log=.True.) - call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", tidal_sal_from_file,& + call get_param(param_file, '', "TIDAL_SAL_FROM_FILE", use_tidal_sal_file, & default=.false., do_not_log=.True.) endif - call get_param(param_file, mdl, "TIDE_USE_SAL_SCALAR", CS%use_sal_scalar, & - "If true and TIDES is true, use the scalar approximation "//& - "when calculating self-attraction and loading.", & - default=.not.tidal_sal_from_file) - if (CS%use_sal_scalar .or. CS%use_prev_tides) & - call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & - fail_if_missing=.true.) - - call get_param(param_file, mdl, "TIDAL_SAL_SHT", CS%use_sal_sht, & - "If true, use the online spherical harmonics method to calculate "//& - "self-attraction and loading term in tides.", default=.false.) + ! TIDE_USE_SAL_SCALAR is going to be replaced by USE_SAL_SCALAR. During the transition, the default of + ! USE_SAL_SCALAR is set to be consistent with TIDE_USE_SAL_SCALAR before the implementation of spherical + ! harmonics SAL. + ! A FATAL error is only issued when the user specified TIDE_USE_SAL_SCALAR contradicts USE_SAL_SCALAR. + call get_param(param_file, mdl, "USE_SAL_SCALAR", CS%use_sal_scalar, & + "If true, use the scalar approximation to calculate self-attraction and"//& + " loading. This parameter is to replace TIDE_USE_SAL_SCALAR, as SAL applies"//& + " to all motions. When both USE_SAL_SCALAR and TIDE_USE_SAL_SCALAR are"//& + " specified, USE_SAL_SCALAR overrides TIDE_USE_SAL_SCALAR.", & + default=tides .and. (.not.use_tidal_sal_file)) + if (tides) then + call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", warning_val=CS%use_sal_scalar, & + hint="Use USE_SAL_SCALAR instead.") + endif + + call get_param(param_file, mdl, "USE_SAL_HARMONICS", CS%use_sal_sht, & + "If true, use the online spherical harmonics method to calculate"//& + " self-attraction and loading.", default=.false.) + ! This is a more of a hard obsolete but should only impact a handful of users. + call obsolete_logical(param_file, "TIDAL_SAL_SHT", warning_val=CS%use_sal_sht, & + hint="Use USE_SAL_HARMONICS instead.") call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, & "If true, calculate self-attraction and loading.", default=tides) - - ! ! Default USE_SAL is TRUE for now to keep backward compatibility with old MOM_INPUT files. It should be changed to - ! ! FALSE in the future (mostly to avoid the SSH calculations in MOM_PressureForce). In that case, the following check - ! ! informs prior tidal experiments that use scalar or iterative SAL to include USE_SAL flag, as the USE_SAL flag - ! ! overrules the option flags. - ! if ((.not. calculate_sal) .and. (CS%use_prev_tides .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & - ! call MOM_error(FATAL, trim(mdl)//": USE_SAL is False but one of the options is True. Nothing will happen.") + if ((.not. calculate_sal) .and. (CS%use_tidal_sal_prev .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & + call MOM_error(FATAL, trim(mdl)//": CALCULATE_SAL is False but one of the options is True.") + + ! TIDE_SAL_SCALAR_VALUE is going to be replaced by SAL_SCALAR_VALUE. The following segment of codes + ! should eventually be replaced by the commented code below. + ! if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) & + ! call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + ! "The constant of proportionality between sea surface "//& + ! "height (really it should be bottom pressure) anomalies "//& + ! "and bottom geopotential anomalies. This is only used if "//& + ! "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + ! fail_if_missing=.true., units="m m-1") + ! endif + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then + CS%sal_scalar_value = -9e35 + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, "", do_not_log=.True.) + if (CS%sal_scalar_value == -9e35) then + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar_value, do_not_log=.True.) + if (CS%sal_scalar_value /= -9e35) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead.") + endif + if (CS%sal_scalar_value == -9e35) & + call MOM_error(FATAL, trim(mdl)//": USE_SAL_SCALAR is true but SAL_SCALAR_VALUE is not set.") + call log_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", units="m m-1") + endif if (CS%use_sal_sht) then - call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", CS%sal_sht_Nd, & + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & "The maximum degree of the spherical harmonics transformation used for "// & "calculating the self-attraction and loading term.", & - default=0, do_not_log=.not. CS%use_sal_sht) - call get_param(param_file, mdl, "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) + default=0) + call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", warning_val=CS%sal_sht_Nd, & + hint="Use SAL_HARMONICS_DEGREE instead.") + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) call get_param(param_file, mdl, "RHO_E", rhoE, & "The mean solid earth density. This is used for calculating the "// & "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) + default=5517.0, scale=US%kg_m3_to_R) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 @@ -235,10 +272,10 @@ end subroutine SAL_end !! !! This module contains methods to calculate self-attraction and loading (SAL) as a function of sea surface height (SSH) !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or -!! storm surges, but the effect applys to all motions. +!! storm surges, but the effect applies to all motions. !! -!! If TIDE_USE_SAL_SCALAR is true, a scalar approximiation is applied (Accad and Pekeris 1978) and the SAL is simply -!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usualy around 10% for global tides) of local SSH . For the tides, the +!! If TIDE_USE_SAL_SCALAR is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For the tides, the !! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, !! Arbic et al. (2004)]. !! diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index fcd90a4171..38286f20c5 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -33,10 +33,10 @@ module MOM_tidal_forcing !> The control structure for the MOM_tidal_forcing module type, public :: tidal_forcing_CS ; private - logical :: tidal_sal_from_file !< If true, Read the tidal self-attraction + logical :: use_tidal_sal_file !< If true, Read the tidal self-attraction !! and loading from input files, specified !! by TIDAL_INPUT_FILE. - logical :: use_prev_tides !< If true, use the SAL from the previous + logical :: use_tidal_sal_prev !< If true, use the SAL from the previous !! iteration of the tides to facilitate convergence. logical :: use_eq_phase !< If true, tidal forcing is phase-shifted to match !! equilibrium tide. Set to false if providing tidal phases @@ -344,22 +344,18 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) return endif - call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%tidal_sal_from_file, & + call get_param(param_file, mdl, "TIDAL_SAL_FROM_FILE", CS%use_tidal_sal_file, & "If true, read the tidal self-attraction and loading "//& "from input files, specified by TIDAL_INPUT_FILE. "//& "This is only used if TIDES is true.", default=.false.) - call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_prev_tides, & + call get_param(param_file, mdl, "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_prev_tides) & - call get_param(param_file, mdl, "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "TIDES and TIDE_USE_SAL_SCALAR are true.", units="m m-1", & - fail_if_missing=.true.) + if (CS%use_tidal_sal_prev) & + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, fail_if_missing=.true., & + do_not_log=.True.) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & @@ -369,7 +365,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) do c=1,4*MAX_CONSTITUENTS ; tidal_input_files(c) = "" ; enddo - if (CS%tidal_sal_from_file .or. CS%use_prev_tides) then + if (CS%use_tidal_sal_file .or. CS%use_tidal_sal_prev) then call get_param(param_file, mdl, "TIDAL_INPUT_FILE", tidal_input_files, & "A list of input files for tidal information.", & default="", fail_if_missing=.true.) @@ -484,7 +480,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) " are true.", units="radians", default=phase0_def(c)) enddo - if (CS%tidal_sal_from_file) then + if (CS%use_tidal_sal_file) then allocate(CS%cosphasesal(isd:ied,jsd:jed,nc)) allocate(CS%sinphasesal(isd:ied,jsd:jed,nc)) allocate(CS%ampsal(isd:ied,jsd:jed,nc)) @@ -502,7 +498,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) enddo endif - if (CS%USE_PREV_TIDES) then + if (CS%use_tidal_sal_prev) then allocate(CS%cosphase_prev(isd:ied,jsd:jed,nc)) allocate(CS%sinphase_prev(isd:ied,jsd:jed,nc)) allocate(CS%amp_prev(isd:ied,jsd:jed,nc)) @@ -601,7 +597,7 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) enddo ; enddo enddo - if (CS%tidal_sal_from_file) then ; do c=1,CS%nc + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -610,7 +606,7 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) enddo ; enddo enddo ; endif - if (CS%USE_PREV_TIDES) then ; do c=1,CS%nc + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc cosomegat = cos(CS%freq(c)*now) sinomegat = sin(CS%freq(c)*now) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 From 00a63e8484ba0a1eb978485c49bd479347170750 Mon Sep 17 00:00:00 2001 From: He Wang Date: Fri, 16 Jun 2023 15:07:57 -0400 Subject: [PATCH 394/629] Recover old answers with tides in Boussinesq mode This commit addresses the issue of bit level answer change with tides in Boussinesq mode. * A runtime parameter TIDES_ANSWER_DATE is added to restore old answers before the SAL module is added. The answer change is due to an reorder of summations of the SAL and tidal forcing terms. * The new version flag only applies to the analytical pressure force in Boussinesq mode, which is virtually the only configuration widely used and included in the test suite. * For Montgomery pressure and non-Boussinesq mode, the code is refactored in a more readable way. --- src/core/MOM_PressureForce_FV.F90 | 55 ++++++++---- src/core/MOM_PressureForce_Montgomery.F90 | 49 ++++++----- .../lateral/MOM_tidal_forcing.F90 | 83 +++++++++++++++++++ 3 files changed, 149 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 25301ae31d..4314c1f7df 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -11,6 +11,7 @@ module MOM_PressureForce_FV use MOM_PressureForce_Mont, only : set_pbce_Bouss, set_pbce_nonBouss use MOM_self_attr_load, only : calc_SAL, SAL_CS use MOM_tidal_forcing, only : calc_tidal_forcing, tidal_forcing_CS +use MOM_tidal_forcing, only : calc_tidal_forcing_legacy use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type @@ -62,6 +63,7 @@ module MOM_PressureForce_FV !! By the default (1) is for a piecewise linear method logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF + integer :: tide_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier integer :: id_e_tide_eq = -1 !< Diagnostic identifier integer :: id_e_tide_sal = -1 !< Diagnostic identifier @@ -309,34 +311,27 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo enddo - ! The following two if-statements are arranged in a way that answers are not - ! changed from old versions in which SAL is part of the tidal forcing module. + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then - ! Find and add the self-attraction and loading geopotential anomaly. !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then - ! Find and add the tidal geopotential anomaly. call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -472,7 +467,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! Interface height in depth units [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)) :: & - e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. + e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. + e_sal, & ! The bottom geopotential anomaly due to self-attraction and loading [Z ~> m]. e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources ! [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading @@ -560,6 +556,8 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! The following two if-statements are arranged in a way that answers are not ! changed from old versions in which SAL is part of the tidal forcing module. + + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, @@ -582,11 +580,21 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + if (CS%tide_answer_date>20230630) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = e_sal(i,j) + (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + else + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & + G, US, CS%tides_CSp) + endif !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) enddo ; enddo else !$OMP parallel do default(shared) @@ -787,12 +795,12 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm endif if (present(eta)) then - if (CS%tides) then ! eta is the sea surface height relative to a time-invariant geoid, for comparison with ! what is used for eta in btstep. See how e was calculated about 200 lines above. + if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H enddo ; enddo else !$OMP parallel do default(shared) @@ -841,7 +849,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm ! To be consistent with old runs, tidal forcing diagnostic also includes total SAL. ! New diagnostics are given for each individual field. - if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal+e_tide_eq+e_tide_sal, CS%diag) + if (CS%id_e_tide>0) call post_data(CS%id_e_tide, e_sal_tide, CS%diag) if (CS%id_e_sal>0) call post_data(CS%id_e_sal, e_sal, CS%diag) if (CS%id_e_tide_eq>0) call post_data(CS%id_e_tide_eq, e_tide_eq, CS%diag) if (CS%id_e_tide_sal>0) call post_data(CS%id_e_tide_sal, e_tide_sal, CS%diag) @@ -867,6 +875,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, ! Local variables real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [nondim] + integer :: default_answer_date ! Global answer date ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -888,6 +897,16 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) + if (CS%tides .and. GV%Boussinesq) then + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tide_answer_date, & + "The vintage of self-attraction and loading (SAL) and tidal forcing calculations in "//& + "Boussinesq mode. Values below 20230701 recover the old answers in which the SAL is "//& + "part of the tidal forcing calculation. The change is due to a reordered summation "//& + "and the difference is only at bit level.", default=20230630) + endif call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & "If true, calculate self-attraction and loading.", default=CS%tides) call get_param(param_file, "MOM", "USE_REGRIDDING", use_ALE, & diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 53f6a5a925..a22c73fa4d 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -186,6 +186,12 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb endif endif + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + geopot_bot(i,j) = -GV%g_Earth * G%bathyT(i,j) + enddo ; enddo + + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then ! Determine the sea surface height anomalies, to enable the calculation ! of self-attraction and loading. @@ -209,23 +215,20 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb SSH(i,j) = SSH(i,j) + GV%H_to_RZ * h(i,j,k) * alpha_Lay(k) enddo ; enddo ; enddo endif + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*e_sal(i,j) enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j) + G%bathyT(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - geopot_bot(i,j) = -GV%g_Earth*(e_sal(i,j) + G%bathyT(i,j)) + geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*(e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -460,7 +463,12 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo + ! Calculate and add the self-attraction and loading geopotential anomaly. if (CS%calculate_SAL) then ! Determine the surface height anomaly for calculating self attraction ! and loading. This should really be based on bottom pressure anomalies, @@ -474,22 +482,18 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, enddo ; enddo enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else + !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) enddo ; enddo endif + ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + (e_sal(i,j) + e_tide_eq(i,j) + e_tide_sal(i,j))) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo endif @@ -608,18 +612,23 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, endif ! use_EOS if (present(eta)) then - if (CS%tides) then ! eta is the sea surface height relative to a time-invariant geoid, for ! comparison with what is used for eta in btstep. See how e was calculated ! about 200 lines above. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + enddo ; enddo + if (CS%tides) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal(i,j)+e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H enddo ; enddo - else + endif + if (CS%calculate_SAL) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + e_sal(i,j)*GV%Z_to_H + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H enddo ; enddo endif endif diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 38286f20c5..948a39f2dc 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -16,6 +16,7 @@ module MOM_tidal_forcing implicit none ; private public calc_tidal_forcing, tidal_forcing_init, tidal_forcing_end +public calc_tidal_forcing_legacy ! MOM_open_boundary uses the following to set tides on the boundary. public astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency @@ -619,6 +620,88 @@ subroutine calc_tidal_forcing(Time, e_tide_eq, e_tide_sal, G, US, CS) end subroutine calc_tidal_forcing +!> This subroutine functions the same as calc_tidal_forcing but outputs a field that combines +!! previously calculated self-attraction and loading (SAL) and tidal forcings, so that old answers +!! can be preserved bitwise before SAL is separated out as an individual module. +subroutine calc_tidal_forcing_legacy(Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, G, US, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(time_type), intent(in) :: Time !< The time for the caluculation. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: e_sal !< The self-attraction and loading fields + !! calculated previously used to + !! initialized e_sal_tide [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_sal_tide !< The total geopotential height anomalies + !! due to both SAL and tidal forcings [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_eq !< The geopotential height anomalies + !! due to the equilibrium tides [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: e_tide_sal !< The geopotential height anomalies + !! due to the tidal SAL [Z ~> m]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(tidal_forcing_CS), intent(in) :: CS !< The control structure returned by a + !! previous call to tidal_forcing_init. + + ! Local variables + real :: now ! The relative time compared with the tidal reference [T ~> s] + real :: amp_cosomegat, amp_sinomegat ! The tidal amplitudes times the components of phase [Z ~> m] + real :: cosomegat, sinomegat ! The components of the phase [nondim] + real :: amp_cossin ! A temporary field that adds cosines and sines [nondim] + integer :: i, j, c, m, 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 + + call cpu_clock_begin(id_clock_tides) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = 0.0 + e_tide_eq(i,j) = 0.0 + e_tide_sal(i,j) = 0.0 + enddo ; enddo + + if (CS%nc == 0) then + return + endif + + now = US%s_to_T * time_type_to_real(Time - cs%time_ref) + + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal_tide(i,j) = e_sal(i,j) + enddo ; enddo + + do c=1,CS%nc + m = CS%struct(c) + amp_cosomegat = CS%amp(c)*CS%love_no(c) * cos(CS%freq(c)*now + CS%phase0(c)) + amp_sinomegat = CS%amp(c)*CS%love_no(c) * sin(CS%freq(c)*now + CS%phase0(c)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = (amp_cosomegat*CS%cos_struct(i,j,m) + amp_sinomegat*CS%sin_struct(i,j,m)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_eq(i,j) = e_tide_eq(i,j) + amp_cossin + enddo ; enddo + enddo + + if (CS%use_tidal_sal_file) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = CS%ampsal(i,j,c) & + * (cosomegat*CS%cosphasesal(i,j,c) + sinomegat*CS%sinphasesal(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin + enddo ; enddo + enddo ; endif + + if (CS%use_tidal_sal_prev) then ; do c=1,CS%nc + cosomegat = cos(CS%freq(c)*now) + sinomegat = sin(CS%freq(c)*now) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + amp_cossin = -CS%sal_scalar * CS%amp_prev(i,j,c) & + * (cosomegat*CS%cosphase_prev(i,j,c) + sinomegat*CS%sinphase_prev(i,j,c)) + e_sal_tide(i,j) = e_sal_tide(i,j) + amp_cossin + e_tide_sal(i,j) = e_tide_sal(i,j) + amp_cossin + enddo ; enddo + enddo ; endif + call cpu_clock_end(id_clock_tides) + +end subroutine calc_tidal_forcing_legacy + !> This subroutine deallocates memory associated with the tidal forcing module. subroutine tidal_forcing_end(CS) type(tidal_forcing_CS), intent(inout) :: CS !< The control structure returned by a previous call From 3061166a1a19a52036aa007065f07dd2efd15b0e Mon Sep 17 00:00:00 2001 From: He Wang Date: Mon, 19 Jun 2023 22:15:43 -0400 Subject: [PATCH 395/629] Refactor SAL and tides calls in Boussinesq mode Consistent with the non-Boussinesq option with the new answer option --- src/core/MOM_PressureForce_FV.F90 | 133 ++++++++++++++++++++---------- 1 file changed, 89 insertions(+), 44 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 4314c1f7df..da94add51e 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -63,7 +63,7 @@ module MOM_PressureForce_FV !! By the default (1) is for a piecewise linear method logical :: use_stanley_pgf !< If true, turn on Stanley parameterization in the PGF - integer :: tide_answer_date !< Recover old answers with tides in Boussinesq mode + integer :: tides_answer_date !< Recover old answers with tides in Boussinesq mode integer :: id_e_tide = -1 !< Diagnostic identifier integer :: id_e_tide_eq = -1 !< Diagnostic identifier integer :: id_e_tide_sal = -1 !< Diagnostic identifier @@ -554,53 +554,79 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm G_Rho0 = GV%g_Earth / GV%Rho0 rho_ref = CS%Rho0 - ! The following two if-statements are arranged in a way that answers are not - ! changed from old versions in which SAL is part of the tidal forcing module. + if (CS%tides_answer_date>20230630) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -G%bathyT(i,j) + enddo ; enddo - ! Calculate and add the self-attraction and loading geopotential anomaly. - if (CS%calculate_SAL) then - ! Determine the surface height anomaly for calculating self attraction - ! and loading. This should really be based on bottom pressure anomalies, - ! but that is not yet implemented, and the current form is correct for - ! barotropic tides. - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 - do i=Isq,Ieq+1 - SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo enddo - do k=1,nz ; do i=Isq,Ieq+1 - SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) enddo ; enddo - enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal(i,j) = 0.0 - enddo ; enddo - endif + endif - ! Calculate and add the tidal geopotential anomaly. - if (CS%tides) then - if (CS%tide_answer_date>20230630) then + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e_sal_tide(i,j) = e_sal(i,j) + (e_tide_eq(i,j) + e_tide_sal(i,j)) + e(i,j,nz+1) = e(i,j,nz+1) - (e_tide_eq(i,j) + e_tide_sal(i,j)) enddo ; enddo + endif + else ! Old answers + ! Calculate and add the self-attraction and loading geopotential anomaly. + if (CS%calculate_SAL) then + ! Determine the surface height anomaly for calculating self attraction + ! and loading. This should really be based on bottom pressure anomalies, + ! but that is not yet implemented, and the current form is correct for + ! barotropic tides. + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + SSH(i,j) = min(-G%bathyT(i,j) - G%Z_ref, 0.0) + enddo + do k=1,nz ; do i=Isq,Ieq+1 + SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z + enddo ; enddo + enddo + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e_sal(i,j) = 0.0 + enddo ; enddo + endif + + ! Calculate and add the tidal geopotential anomaly. + if (CS%tides) then call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) + enddo ; enddo endif - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal_tide(i,j)) - enddo ; enddo - else - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - e(i,j,nz+1) = -(G%bathyT(i,j) + e_sal(i,j)) - enddo ; enddo endif !$OMP parallel do default(shared) @@ -797,16 +823,35 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm if (present(eta)) then ! eta is the sea surface height relative to a time-invariant geoid, for comparison with ! what is used for eta in btstep. See how e was calculated about 200 lines above. - if (CS%tides) then - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H - enddo ; enddo - else + if (CS%tides_answer_date>20230630) then !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H + eta(i,j) = e(i,j,1)*GV%Z_to_H enddo ; enddo + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + (e_tide_eq(i,j)+e_tide_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif + if (CS%calculate_SAL) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = eta(i,j) + e_sal(i,j)*GV%Z_to_H + enddo ; enddo + endif + else ! Old answers + if (CS%tides) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = e(i,j,1)*GV%Z_to_H + (e_sal_tide(i,j))*GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta(i,j) = (e(i,j,1) + e_sal(i,j))*GV%Z_to_H + enddo ; enddo + endif endif endif @@ -901,7 +946,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tide_answer_date, & + call get_param(param_file, mdl, "TIDES_ANSWER_DATE", CS%tides_answer_date, & "The vintage of self-attraction and loading (SAL) and tidal forcing calculations in "//& "Boussinesq mode. Values below 20230701 recover the old answers in which the SAL is "//& "part of the tidal forcing calculation. The change is due to a reordered summation "//& From 3515b804ecb0c98f06b50a56ab95d997efc78a69 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 17 Aug 2023 01:30:25 -0400 Subject: [PATCH 396/629] Change SAL related parameter names This commit revises changes of some parameter names from a previous commit. * Logical switch TIDE_USE_SAL_SCALAR is obsolete and replaced by SAL_SCALAR_APPROX. * TIDE_SAL_SCALAR_VALUE is replaced by SAL_SCALAR_VALUE. The old parameter name is still accepted but a warning is given. * Logical switch TIDAL_SAL_SHT is obsolete and replaced by SAL_HARMONICS. * TIDAL_SAL_SHT_DEGREE is obsolete and replaced by SAL_HARMONICS_DEGREE. * RHO_E is replaced by RHO_SOLID_EARTH. --- src/diagnostics/MOM_obsolete_params.F90 | 5 ++ .../lateral/MOM_self_attr_load.F90 | 86 ++++++------------- .../lateral/MOM_spherical_harmonics.F90 | 11 +-- .../lateral/MOM_tidal_forcing.F90 | 2 +- 4 files changed, 38 insertions(+), 66 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 21a09dfdbb..7614eb210c 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -111,6 +111,11 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "SMOOTH_RI", hint="Instead use N_SMOOTH_RI.") + call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", hint="Use SAL_SCALAR_APPROX instead.") + call obsolete_logical(param_file, "TIDAL_SAL_SHT", hint="Use SAL_HARMONICS instead.") + call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", hint="Use SAL_HARMONICS_DEGREE instead.") + call obsolete_real(param_file, "RHO_E", hint="Use RHO_SOLID_EARTH instead.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index be45f64cfe..fa5d973989 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -3,7 +3,7 @@ module MOM_self_attr_load use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_MODULE use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_error, FATAL, WARNING -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param, get_param, log_version, param_file_type use MOM_obsolete_params, only : obsolete_logical, obsolete_int use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -169,6 +169,10 @@ subroutine SAL_init(G, US, param_file, CS) call log_version(param_file, mdl, version, "") call get_param(param_file, '', "TIDES", tides, default=.false., do_not_log=.True.) + call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, "If true, calculate "//& + " self-attraction and loading.", default=tides, do_not_log=.True.) + if (.not. calculate_sal) return + if (tides) then call get_param(param_file, '', "USE_PREVIOUS_TIDES", CS%use_tidal_sal_prev, & default=.false., do_not_log=.True.) @@ -176,73 +180,39 @@ subroutine SAL_init(G, US, param_file, CS) default=.false., do_not_log=.True.) endif - ! TIDE_USE_SAL_SCALAR is going to be replaced by USE_SAL_SCALAR. During the transition, the default of - ! USE_SAL_SCALAR is set to be consistent with TIDE_USE_SAL_SCALAR before the implementation of spherical - ! harmonics SAL. - ! A FATAL error is only issued when the user specified TIDE_USE_SAL_SCALAR contradicts USE_SAL_SCALAR. - call get_param(param_file, mdl, "USE_SAL_SCALAR", CS%use_sal_scalar, & + call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & "If true, use the scalar approximation to calculate self-attraction and"//& - " loading. This parameter is to replace TIDE_USE_SAL_SCALAR, as SAL applies"//& - " to all motions. When both USE_SAL_SCALAR and TIDE_USE_SAL_SCALAR are"//& - " specified, USE_SAL_SCALAR overrides TIDE_USE_SAL_SCALAR.", & - default=tides .and. (.not.use_tidal_sal_file)) - if (tides) then - call obsolete_logical(param_file, "TIDE_USE_SAL_SCALAR", warning_val=CS%use_sal_scalar, & - hint="Use USE_SAL_SCALAR instead.") - endif - - call get_param(param_file, mdl, "USE_SAL_HARMONICS", CS%use_sal_sht, & + " loading.", default=tides .and. (.not.use_tidal_sal_file)) + call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & "If true, use the online spherical harmonics method to calculate"//& " self-attraction and loading.", default=.false.) - ! This is a more of a hard obsolete but should only impact a handful of users. - call obsolete_logical(param_file, "TIDAL_SAL_SHT", warning_val=CS%use_sal_sht, & - hint="Use USE_SAL_HARMONICS instead.") - - call get_param(param_file, mdl, "CALCULATE_SAL", calculate_sal, & - "If true, calculate self-attraction and loading.", default=tides) - if ((.not. calculate_sal) .and. (CS%use_tidal_sal_prev .or. CS%use_sal_scalar .or. CS%use_sal_sht)) & - call MOM_error(FATAL, trim(mdl)//": CALCULATE_SAL is False but one of the options is True.") - - ! TIDE_SAL_SCALAR_VALUE is going to be replaced by SAL_SCALAR_VALUE. The following segment of codes - ! should eventually be replaced by the commented code below. - ! if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) & - ! call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & - ! "The constant of proportionality between sea surface "//& - ! "height (really it should be bottom pressure) anomalies "//& - ! "and bottom geopotential anomalies. This is only used if "//& - ! "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & - ! fail_if_missing=.true., units="m m-1") - ! endif + if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then - CS%sal_scalar_value = -9e35 - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, "", do_not_log=.True.) - if (CS%sal_scalar_value == -9e35) then - call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", CS%sal_scalar_value, do_not_log=.True.) - if (CS%sal_scalar_value /= -9e35) & - call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& - "Use SAL_SCALAR_VALUE instead.") - endif - if (CS%sal_scalar_value == -9e35) & - call MOM_error(FATAL, trim(mdl)//": USE_SAL_SCALAR is true but SAL_SCALAR_VALUE is not set.") - call log_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & "The constant of proportionality between sea surface "//& "height (really it should be bottom pressure) anomalies "//& "and bottom geopotential anomalies. This is only used if "//& - "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", units="m m-1") + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) endif if (CS%use_sal_sht) then call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & "The maximum degree of the spherical harmonics transformation used for "// & "calculating the self-attraction and loading term.", & - default=0) - call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", warning_val=CS%sal_sht_Nd, & - hint="Use SAL_HARMONICS_DEGREE instead.") - call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, do_not_log=.True.) - call get_param(param_file, mdl, "RHO_E", rhoE, & + default=0, do_not_log=.not.CS%use_sal_sht) + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & + units="kg m-3", do_not_log=.True.) + call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & "The mean solid earth density. This is used for calculating the "// & "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R) + default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 @@ -274,14 +244,14 @@ end subroutine SAL_end !! (rather, it should be bottom pressure anomaly). SAL is primarily used for fast evolving processes like tides or !! storm surges, but the effect applies to all motions. !! -!! If TIDE_USE_SAL_SCALAR is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply -!! a fraction (set by TIDE_SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For the tides, the -!! scalar approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, +!! If SAL_SCALAR_APPROX is true, a scalar approximation is applied (Accad and Pekeris 1978) and the SAL is simply +!! a fraction (set by SAL_SCALAR_VALUE, usually around 10% for global tides) of local SSH . For tides, the scalar +!! approximation can also be used to iterate the SAL to convergence [see USE_PREVIOUS_TIDES in MOM_tidal_forcing, !! Arbic et al. (2004)]. !! -!! If TIDAL_SAL_SHT is true, a more accurate online spherical harmonic transforms are used to calculate SAL. +!! If SAL_HARMONICS is true, a more accurate online spherical harmonic transforms are used to calculate SAL. !! Subroutines in module MOM_spherical_harmonics are called and the degree of spherical harmonic transforms is set by -!! TIDAL_SAL_SHT_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean +!! SAL_HARMONICS_DEGREE. The algorithm is based on SAL calculation in Model for Prediction Across Scales (MPAS)-Ocean !! developed by Los Alamos National Laboratory and University of Michigan [Barton et al. (2022) and Brus et al. (2023)]. !! !! References: diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index b20df036e0..2a72d26a20 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -217,7 +217,7 @@ subroutine spherical_harmonics_init(G, param_file, CS) integer :: is, ie, js, je integer :: i, j, k integer :: m, n - integer :: Nd_tidal_SAL ! Maximum degree for tidal SAL + integer :: Nd_SAL ! Maximum degree for SAL ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_spherical_harmonics" ! This module's name. @@ -228,11 +228,8 @@ subroutine spherical_harmonics_init(G, param_file, CS) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "TIDAL_SAL_SHT_DEGREE", Nd_tidal_SAL, & - "The maximum degree of the spherical harmonics transformation used for "// & - "calculating the self-attraction and loading term for tides.", & - default=0, do_not_log=.true.) - CS%ndegree = Nd_tidal_SAL + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", Nd_SAL, "", default=0, do_not_log=.true.) + CS%ndegree = Nd_SAL CS%lmax = calc_lmax(CS%ndegree) call get_param(param_file, mdl, "SHT_REPRODUCING_SUM", CS%reprod_sum, & "If true, use reproducing sums (invariant to PE layout) in inverse transform "// & @@ -361,7 +358,7 @@ end function order2index !! array vectorization. !! !! The maximum degree of the spherical harmonics is a runtime parameter and the maximum used by all SHT applications. -!! At the moment, it is only decided by TIDAL_SAL_SHT_DEGREE. +!! At the moment, it is only decided by SAL_HARMONICS_DEGREE. !! !! The forward transforms involve a global summation. Runtime flag SHT_REPRODUCING_SUM controls whether this is done !! in a bit-wise reproducing way or not. diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 948a39f2dc..1ef55fff7f 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -356,7 +356,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) ! If it is being used, sal_scalar MUST be specified in param_file. if (CS%use_tidal_sal_prev) & call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, fail_if_missing=.true., & - do_not_log=.True.) + units="m m-1", do_not_log=.True.) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & From c6b6143373daf3cb13ecfea8e92f11a72d616f69 Mon Sep 17 00:00:00 2001 From: He Wang Date: Thu, 17 Aug 2023 14:46:21 -0400 Subject: [PATCH 397/629] Modify reading SAL related parameters * An incident of incorrect indent is fixed in SAL_int. * Parameters read in SAL_int is moved out from if statements. DO_NOT_LOG is used to prevent logging unused parameters. * Reading SAL_SCALAR_VALUE in tidal_forcing_init is now consistent with SAL_init. * Some unused variables in tidal_forcing_init are removed. --- .../lateral/MOM_self_attr_load.F90 | 55 +++++++++---------- .../lateral/MOM_tidal_forcing.F90 | 20 ++++--- 2 files changed, 39 insertions(+), 36 deletions(-) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index fa5d973989..20d239eb53 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -181,38 +181,35 @@ subroutine SAL_init(G, US, param_file, CS) endif call get_param(param_file, mdl, "SAL_SCALAR_APPROX", CS%use_sal_scalar, & - "If true, use the scalar approximation to calculate self-attraction and"//& - " loading.", default=tides .and. (.not.use_tidal_sal_file)) + "If true, use the scalar approximation to calculate self-attraction and "//& + "loading.", default=tides .and. (.not. use_tidal_sal_file)) + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) call get_param(param_file, mdl, "SAL_HARMONICS", CS%use_sal_sht, & - "If true, use the online spherical harmonics method to calculate"//& - " self-attraction and loading.", default=.false.) - - if (CS%use_sal_scalar .or. CS%use_tidal_sal_prev) then - call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & - units="m m-1", default=0.0, do_not_log=.True.) - if (tide_sal_scalar_value/=0.0) & - call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& - "Use SAL_SCALAR_VALUE instead." ) - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar_value, & - "The constant of proportionality between sea surface "//& - "height (really it should be bottom pressure) anomalies "//& - "and bottom geopotential anomalies. This is only used if "//& - "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & - default=tide_sal_scalar_value, units="m m-1", & - do_not_log=(.not. CS%use_sal_scalar) .and. (.not. CS%use_tidal_sal_prev)) - endif + "If true, use the online spherical harmonics method to calculate "//& + "self-attraction and loading.", default=.false.) + call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & + "The maximum degree of the spherical harmonics transformation used for "// & + "calculating the self-attraction and loading term.", & + default=0, do_not_log=(.not. CS%use_sal_sht)) + call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & + units="kg m-3", do_not_log=.True.) + call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & + "The mean solid earth density. This is used for calculating the "// & + "self-attraction and loading term.", units="kg m-3", & + default=5517.0, scale=US%kg_m3_to_R, do_not_log=(.not. CS%use_sal_sht)) if (CS%use_sal_sht) then - call get_param(param_file, mdl, "SAL_HARMONICS_DEGREE", CS%sal_sht_Nd, & - "The maximum degree of the spherical harmonics transformation used for "// & - "calculating the self-attraction and loading term.", & - default=0, do_not_log=.not.CS%use_sal_sht) - call get_param(param_file, '', "RHO_0", rhoW, default=1035.0, scale=US%kg_m3_to_R, & - units="kg m-3", do_not_log=.True.) - call get_param(param_file, mdl, "RHO_SOLID_EARTH", rhoE, & - "The mean solid earth density. This is used for calculating the "// & - "self-attraction and loading term.", units="kg m-3", & - default=5517.0, scale=US%kg_m3_to_R, do_not_log=.not. CS%use_sal_sht) lmax = calc_lmax(CS%sal_sht_Nd) allocate(CS%Snm_Re(lmax)); CS%Snm_Re(:) = 0.0 allocate(CS%Snm_Im(lmax)); CS%Snm_Im(:) = 0.0 diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index 1ef55fff7f..eb481f2131 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -256,10 +256,8 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. character(len=128) :: mesg character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) + real :: tide_sal_scalar_value integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc - integer :: lmax ! Total modes of the real spherical harmonics [nondim] - real :: rhoW ! The average density of sea water [R ~> kg m-3]. - real :: rhoE ! The average density of Earth [R ~> kg m-3]. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd; jed = G%jed @@ -353,10 +351,18 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) "If true, use the SAL from the previous iteration of the "//& "tides to facilitate convergent iteration. "//& "This is only used if TIDES is true.", default=.false.) - ! If it is being used, sal_scalar MUST be specified in param_file. - if (CS%use_tidal_sal_prev) & - call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, fail_if_missing=.true., & - units="m m-1", do_not_log=.True.) + call get_param(param_file, '', "TIDE_SAL_SCALAR_VALUE", tide_sal_scalar_value, & + units="m m-1", default=0.0, do_not_log=.True.) + if (tide_sal_scalar_value/=0.0) & + call MOM_error(WARNING, "TIDE_SAL_SCALAR_VALUE is a deprecated parameter. "//& + "Use SAL_SCALAR_VALUE instead." ) + call get_param(param_file, mdl, "SAL_SCALAR_VALUE", CS%sal_scalar, & + "The constant of proportionality between sea surface "//& + "height (really it should be bottom pressure) anomalies "//& + "and bottom geopotential anomalies. This is only used if "//& + "USE_SAL_SCALAR is true or USE_PREVIOUS_TIDES is true.", & + default=tide_sal_scalar_value, units="m m-1", & + do_not_log=(.not. CS%use_tidal_sal_prev)) if (nc > MAX_CONSTITUENTS) then write(mesg,'("Increase MAX_CONSTITUENTS in MOM_tidal_forcing.F90 to at least",I3, & From 095a3b5fe7a60a2eb796232d0c97ea345ef1b87e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 22 Aug 2023 16:44:30 -0400 Subject: [PATCH 398/629] *+Use TIDES_ANSWER_DATE with semi-Boussinesq tides Use TIDES_ANSWER_DATE with an additional if-block to recover the dev/gfdl answers in semi-Boussinesq mode runs with tides enabled, similarly to what is already being done in Boussinesq mode. This changes some answers for the nonBous_global and tides_025 test cases back to those that would be obtained with the code on dev/gfdl. TIDES_ANSWER_DATE is now logged in all cases with tides, so the MOM_parameter_doc files change in some non-Boussinesq cases. --- src/core/MOM_PressureForce_FV.F90 | 33 +++++++++++++++++++++---------- 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index da94add51e..64df200f31 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -127,6 +127,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ e_tide_eq, & ! The bottom geopotential anomaly due to tidal forces from astronomical sources [Z ~> m]. e_tide_sal, & ! The bottom geopotential anomaly due to harmonic self-attraction and loading ! specific to tides [Z ~> m]. + e_sal_tide, & ! The summation of self-attraction and loading and tidal forcing [Z ~> m]. dM, & ! The barotropic adjustment to the Montgomery potential to ! account for a reduced gravity model [L2 T-2 ~> m2 s-2]. za ! The geopotential anomaly (i.e. g*e + alpha_0*pressure) at the @@ -320,19 +321,31 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ enddo ; enddo call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) - enddo ; enddo + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * e_sal(i,j) + enddo ; enddo + endif endif ! Calculate and add the tidal geopotential anomaly. if (CS%tides) then - call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) - !$OMP parallel do default(shared) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) - enddo ; enddo + if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq)) then + call calc_tidal_forcing(CS%Time, e_tide_eq, e_tide_sal, G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * (e_tide_eq(i,j) + e_tide_sal(i,j)) + enddo ; enddo + else ! This block recreates older answers with tides. + if (.not.CS%calculate_SAL) e_sal(:,:) = 0.0 + call calc_tidal_forcing_legacy(CS%Time, e_sal, e_sal_tide, e_tide_eq, e_tide_sal, & + G, US, CS%tides_CSp) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + za(i,j) = za(i,j) - GV%g_Earth * e_sal_tide(i,j) + enddo ; enddo + endif endif if (CS%GFS_scale < 1.0) then @@ -942,7 +955,7 @@ subroutine PressureForce_FV_init(Time, G, GV, US, param_file, diag, CS, SAL_CSp, units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "TIDES", CS%tides, & "If true, apply tidal momentum forcing.", default=.false.) - if (CS%tides .and. GV%Boussinesq) then + if (CS%tides) then call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) From 24160d59976e87c2aeef68238a0d34b5d46b9e10 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 15 Aug 2023 09:26:42 -0400 Subject: [PATCH 399/629] *Non-Boussinesq revision of MOM.F90 for restarts This commit revises the internal code in step_MOM and extract_surface_state to work in fully non-Boussinesq mode without any dependencies on the Boussinesq reference density and provide updates needed to reproduce answers across restarts in non-Boussinesq mode. The subroutine calls from this module have already been revised, so only this file needs to be updated. The specific changes include: - Rescaled the nominal mixed layer depth variables HFREEZE, HMIX_SFC_PROP and HMIX_UV_SFC_PROP for determining surface properties to eliminate unit conversion factors during the run. This changes the units of 3 elements of the MOM_control_struct and one internal variable and adds 3 new internal variables. - Call calc_derived_thermo to update SpV_avg at the start of step_MOM if the internal ocean state depends on the surface pressure and that surface pressure has been passed in from the driver. There are 3 new internal variables and in some cases a new blocking halo update to enable these changes. All Boussinesq solutions are bitwise identical with this commit. It changes answers in some non-Boussinesq fully coupled or ice-ocean configurations. Other non-Boussinesq mode cases are mathematically equivalent in the case where RHO_0 = RHO_KV_CONVERT and bitwise identical if RHO_KV_CONVERT is an integer power of 2. This commit corrects issues with reproducability across restarts in the non-Boussinesq cases where the answer changes. --- src/core/MOM.F90 | 87 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 62 insertions(+), 25 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index c9b8ea42c0..e59c9ac60a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -337,14 +337,14 @@ module MOM ! These elements are used to control the calculation and error checking of the surface state real :: Hmix !< Diagnostic mixed layer thickness over which to !! average surface tracer properties when a bulk - !! mixed layer is not used [Z ~> m], or a negative value + !! mixed layer is not used [H ~> m or kg m-2], or a negative value !! if a bulk mixed layer is being used. - real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is - !! computed [Z ~> m]. The actual depth over which melt potential is + real :: HFrz !< If HFrz > 0, the nominal depth over which melt potential is computed + !! [H ~> m or kg m-2]. The actual depth over which melt potential is !! computed is min(HFrz, OBLD), where OBLD is the boundary layer depth. !! If HFrz <= 0 (default), melt potential will not be computed. real :: Hmix_UV !< Depth scale over which to average surface flow to - !! feedback to the coupler/driver [Z ~> m] when + !! feedback to the coupler/driver [H ~> m or kg m-2] when !! bulk mixed layer is not used, or a negative value !! if a bulk mixed layer is being used. logical :: check_bad_sfc_vals !< If true, scan surface state for ridiculous values. @@ -516,6 +516,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! various unit conversion factors integer :: ntstep ! time steps between tracer updates or diabatic forcing integer :: n_max ! number of steps to take in this call + integer :: halo_sz, dynamics_stencil integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, n integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -538,6 +539,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS ! multiple dynamic timesteps. logical :: do_dyn ! If true, dynamics are updated with this call. logical :: do_thermo ! If true, thermodynamics and remapping may be applied with this call. + logical :: nonblocking_p_surf_update ! A flag to indicate whether surface properties + ! can use nonblocking halo updates logical :: cycle_start ! If true, do calculations that are only done at the start of ! a stepping cycle (whatever that may mean). logical :: cycle_end ! If true, do calculations and diagnostics that are only done at @@ -647,13 +650,11 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS dt_therm = dt*ntstep endif - if (associated(forces%p_surf)) p_surf => forces%p_surf - if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) CS%tv%p_surf => forces%p_surf - !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) + nonblocking_p_surf_update = G%nonblocking_updates .and. & + .not.(CS%use_p_surf_in_EOS .and. associated(forces%p_surf) .and. & + allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) if (.not.associated(forces%taux) .or. .not.associated(forces%tauy)) & call MOM_error(FATAL,'step_MOM:forces%taux,tauy not associated') call create_group_pass(pass_tau_ustar_psurf, forces%taux, forces%tauy, G%Domain) @@ -663,12 +664,26 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS 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 + if (nonblocking_p_surf_update) then call start_group_pass(pass_tau_ustar_psurf, G%Domain) else call do_group_pass(pass_tau_ustar_psurf, G%Domain) endif call cpu_clock_end(id_clock_pass) + + if (associated(forces%p_surf)) p_surf => forces%p_surf + if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. + CS%tv%p_surf => NULL() + if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) then + CS%tv%p_surf => forces%p_surf + + if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) + endif + endif + else ! This step only updates the thermodynamics so setting timesteps is simpler. n_max = 1 @@ -687,7 +702,13 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS CS%tv%p_surf => NULL() if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then CS%tv%p_surf => fluxes%p_surf - if (allocated(CS%tv%SpV_avg)) call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) + if (allocated(CS%tv%SpV_avg)) then + call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) + ! The internal ocean state depends on the surface pressues, so update SpV_avg. + call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) + halo_sz = max(halo_sz, 1) + call calc_derived_thermo(CS%tv, h, G, GV, US, halo=halo_sz, debug=CS%debug) + endif endif endif @@ -714,7 +735,7 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (CS%stoch_CS%do_sppt .OR. CS%stoch_CS%pert_epbl) call update_stochastics(CS%stoch_CS) if (do_dyn) then - if (G%nonblocking_updates) & + if (nonblocking_p_surf_update) & call complete_group_pass(pass_tau_ustar_psurf, G%Domain, clock=id_clock_pass) if (CS%interp_p_surf) then @@ -1987,6 +2008,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical, allocatable, dimension(:,:,:) :: PCM_cell ! If true, PCM remapping should be used in a cell. type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h + real :: Hmix_z, Hmix_UV_z ! Temporary variables with averaging depths [Z ~> m] + real :: HFrz_z ! Temporary variable with the melt potential depth [Z ~> m] real :: default_val ! default value for a parameter logical :: write_geom_files ! If true, write out the grid geometry files. logical :: new_sim ! If true, this has been determined to be a new simulation @@ -2223,22 +2246,23 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (bulkmixedlayer) then CS%Hmix = -1.0 ; CS%Hmix_UV = -1.0 else - call get_param(param_file, "MOM", "HMIX_SFC_PROP", CS%Hmix, & + call get_param(param_file, "MOM", "HMIX_SFC_PROP", Hmix_z, & "If BULKMIXEDLAYER is false, HMIX_SFC_PROP is the depth "//& "over which to average to find surface properties like "//& "SST and SSS or density (but not surface velocities).", & units="m", default=1.0, scale=US%m_to_Z) - call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", CS%Hmix_UV, & + call get_param(param_file, "MOM", "HMIX_UV_SFC_PROP", Hmix_UV_z, & "If BULKMIXEDLAYER is false, HMIX_UV_SFC_PROP is the depth "//& "over which to average to find surface flow properties, "//& "SSU, SSV. A non-positive value indicates no averaging.", & units="m", default=0.0, scale=US%m_to_Z) endif - call get_param(param_file, "MOM", "HFREEZE", CS%HFrz, & + call get_param(param_file, "MOM", "HFREEZE", HFrz_z, & "If HFREEZE > 0, melt potential will be computed. The actual depth "//& "over which melt potential is computed will be min(HFREEZE, OBLD), "//& "where OBLD is the boundary layer depth. If HFREEZE <= 0 (default), "//& - "melt potential will not be computed.", units="m", default=-1.0, scale=US%m_to_Z) + "melt potential will not be computed.", & + units="m", default=-1.0, scale=US%m_to_Z) call get_param(param_file, "MOM", "INTERPOLATE_P_SURF", CS%interp_p_surf, & "If true, linearly interpolate the surface pressure "//& "over the coupling time step, using the specified value "//& @@ -2525,6 +2549,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call verticalGridInit( param_file, CS%GV, US ) GV => CS%GV + ! Now that the vertical grid has been initialized, rescale parameters that depend on factors + ! that are set with the vertical grid to their desired units. This added rescaling step would + ! be unnecessary if the vertical grid were initialized earlier in this routine. + if (.not.bulkmixedlayer) then + CS%Hmix = (US%Z_to_m * GV%m_to_H) * Hmix_z + CS%Hmix_UV = (US%Z_to_m * GV%m_to_H) * Hmix_UV_z + endif + CS%HFrz = (US%Z_to_m * GV%m_to_H) * HFrz_z + ! Shift from using the temporary dynamic grid type to using the final (potentially static) ! and properly rotated ocean-specific grid type and horizontal index type. if (CS%rotate_index) then @@ -3168,6 +3201,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Update derived thermodynamic quantities. if (allocated(CS%tv%SpV_avg)) then + !### There may be a restart issue here with the surface pressure not being updated? call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif @@ -3415,7 +3449,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) do_not_log=.true.) if (use_ice_shelf .and. associated(CS%Hml)) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & - "Mixed layer thickness", "meter", conversion=US%Z_to_m) + "Mixed layer thickness", "m", conversion=US%Z_to_m) endif ! Register scalar unit conversion factors. @@ -3497,7 +3531,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! After the ANSWERS_2018 flag has been obsoleted, H_rescale will be 1. real :: T_freeze(SZI_(CS%G)) !< freezing temperature [C ~> degC] real :: pres(SZI_(CS%G)) !< Pressure to use for the freezing temperature calculation [R L2 T-2 ~> Pa] - real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [Z C ~> m degC] + real :: delT(SZI_(CS%G)) !< Depth integral of T-T_freeze [H C ~> m degC or degC kg m-2] logical :: use_temperature !< If true, temperature and salinity are used as state variables. integer :: i, j, k, is, ie, js, je, nz, numberOfErrors, ig, jg integer :: isd, ied, jsd, jed @@ -3572,9 +3606,12 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo else ! (CS%Hmix >= 0.0) - H_rescale = 1.0 ; if (CS%answer_date < 20190101) H_rescale = GV%H_to_Z + H_rescale = 1.0 depth_ml = CS%Hmix - if (CS%answer_date >= 20190101) depth_ml = CS%Hmix*GV%Z_to_H + if (CS%answer_date < 20190101) then + H_rescale = GV%H_to_Z + depth_ml = GV%H_to_Z*CS%Hmix + endif ! Determine the mean tracer properties of the uppermost depth_ml fluid. !$OMP parallel do default(shared) private(depth,dh) @@ -3645,7 +3682,7 @@ subroutine extract_surface_state(CS, sfc_state_in) ! This assumes that u and v halos have already been updated. if (CS%Hmix_UV>0.) then depth_ml = CS%Hmix_UV - if (CS%answer_date >= 20190101) depth_ml = CS%Hmix_UV*GV%Z_to_H + if (CS%answer_date < 20190101) depth_ml = GV%H_to_Z*CS%Hmix_UV !$OMP parallel do default(shared) private(depth,dh,hv) do J=js-1,ie do i=is,ie @@ -3719,9 +3756,9 @@ subroutine extract_surface_state(CS, sfc_state_in) do k=1,nz call calculate_TFreeze(CS%tv%S(is:ie,j,k), pres(is:ie), T_freeze(is:ie), CS%tv%eqn_of_state) do i=is,ie - depth_ml = min(CS%HFrz, CS%visc%MLD(i,j)) - if (depth(i) + h(i,j,k)*GV%H_to_Z < depth_ml) then - dh = h(i,j,k)*GV%H_to_Z + depth_ml = min(CS%HFrz, (US%Z_to_m*GV%m_to_H)*CS%visc%MLD(i,j)) + if (depth(i) + h(i,j,k) < depth_ml) then + dh = h(i,j,k) elseif (depth(i) < depth_ml) then dh = depth_ml - depth(i) else @@ -3743,7 +3780,7 @@ subroutine extract_surface_state(CS, sfc_state_in) if (G%mask2dT(i,j)>0.) then ! instantaneous melt_potential [Q R Z ~> J m-2] - sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%Rho0 * delT(i) + sfc_state%melt_potential(i,j) = CS%tv%C_p * GV%H_to_RZ * delT(i) endif enddo enddo ! end of j loop From 1872d3b03d0c47b5b118f0cd50d3407efc40188b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jul 2023 10:32:16 -0400 Subject: [PATCH 400/629] *Revise BFB_set_coord and BFB_buoyancy_forcing Revised BFB_set_coord and BFB_buoyancy_forcing to be consistent with other instances of a linear equation of state, and to set g_prime in non-Boussinesq mode similarly to how it is set in other places. Also use RESTORE_FLUX_RHO in place of RHO_0 when to specify the densities that are used to convert the piston velocities into restoring heat or salt fluxes with BFB_buoyancy_forcing, like in other places in the MOM6 code. This change will change answers by default when BFB_set_coord is used, but the old Boussinesq answers can be recovered by setting the reference salinity S_REF to 38.75 ppt or by setting RHO_T0_S0 to 1003.0 kg m-3. --- src/user/BFB_initialization.F90 | 31 ++++++++++++++++++++-------- src/user/BFB_surface_forcing.F90 | 35 ++++++++++++++++++++++++-------- 2 files changed, 48 insertions(+), 18 deletions(-) diff --git a/src/user/BFB_initialization.F90 b/src/user/BFB_initialization.F90 index 3efc908ffb..67381bfdc5 100644 --- a/src/user/BFB_initialization.F90 +++ b/src/user/BFB_initialization.F90 @@ -38,8 +38,11 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + real :: Rho_T0_S0 ! The density at T=0, S=0 [R ~> kg m-3] real :: dRho_dT ! The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS ! The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] real :: SST_s, T_bot ! Temperatures at the surface and seafloor [C ~> degC] + real :: S_ref ! Reference salinity [S ~> ppt] real :: rho_top, rho_bot ! Densities at the surface and seafloor [R ~> kg m-3] integer :: k, nz ! This include declares and sets the variable "version". @@ -47,23 +50,33 @@ subroutine BFB_set_coord(Rlay, g_prime, GV, US, param_file) character(len=40) :: mdl = "BFB_initialization" ! This module's name. call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "DRHO_DT", drho_dt, & - "Rate of change of density with temperature.", & - units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & + "The partial derivative of density with temperature.", & + units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "SST_S", SST_s, & - "SST at the southern edge of the domain.", units="degC", default=20.0, scale=US%degC_to_C) + "SST at the southern edge of the domain.", & + units="degC", default=20.0, scale=US%degC_to_C) call get_param(param_file, mdl, "T_BOT", T_bot, & "Bottom temperature", units="degC", default=5.0, scale=US%degC_to_C) - rho_top = GV%Rho0 + drho_dt*SST_s - rho_bot = GV%Rho0 + drho_dt*T_bot + call get_param(param_file, mdl, "S_REF", S_ref, & + "The initial salinities.", units="PSU", default=35.0, scale=US%ppt_to_S) + rho_top = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*SST_s + rho_bot = (Rho_T0_S0 + dRho_dS*S_ref) + dRho_dT*T_bot nz = GV%ke do k = 1,nz Rlay(k) = (rho_bot - rho_top)/(nz-1)*real(k-1) + rho_top - if (k >1) then - g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (GV%Rho0) - else + if (k==1) then g_prime(k) = GV%g_Earth + elseif (GV%Boussinesq) then + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / GV%Rho0 + else + g_prime(k) = (Rlay(k) - Rlay(k-1)) * GV%g_Earth / (0.5*(Rlay(k) + Rlay(k-1))) endif enddo diff --git a/src/user/BFB_surface_forcing.F90 b/src/user/BFB_surface_forcing.F90 index f3d04980f6..fcbd66e1d8 100644 --- a/src/user/BFB_surface_forcing.F90 +++ b/src/user/BFB_surface_forcing.F90 @@ -29,12 +29,17 @@ module BFB_surface_forcing real :: Rho0 !< The density used in the Boussinesq approximation [R ~> kg m-3]. real :: G_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2] real :: Flux_const !< The restoring rate at the surface [Z T-1 ~> m s-1]. + real :: rho_restore !< The density that is used to convert piston velocities into salt + !! or heat fluxes with salinity or temperature restoring [R ~> kg m-3] real :: SST_s !< SST at the southern edge of the linear forcing ramp [C ~> degC] real :: SST_n !< SST at the northern edge of the linear forcing ramp [C ~> degC] + real :: S_ref !< Reference salinity used throughout the domain [S ~> ppt] real :: lfrslat !< Southern latitude where the linear forcing ramp begins [degrees_N] or [km] real :: lfrnlat !< Northern latitude where the linear forcing ramp ends [degrees_N] or [km] - real :: drho_dt !< Rate of change of density with temperature [R C-1 ~> kg m-3 degC-1]. - !! Note that temperature is being used as a dummy variable here. + real :: Rho_T0_S0 !< The density at T=0, S=0 [R ~> kg m-3] + real :: dRho_dT !< The partial derivative of density with temperature [R C-1 ~> kg m-3 degC-1] + real :: dRho_dS !< The partial derivative of density with salinity [R S-1 ~> kg m-3 ppt-1] + !! Note that temperature and salinity are being used as dummy variables here. !! All temperatures are converted into density. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -125,7 +130,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) call MOM_error(FATAL, "User_buoyancy_surface_forcing: " // & "Temperature and salinity restoring used without modification." ) - rhoXcp = CS%Rho0 * fluxes%C_p + rhoXcp = CS%rho_restore * fluxes%C_p do j=js,je ; do i=is,ie ! Set Temp_restore and Salin_restore to the temperature (in [C ~> degC]) and ! salinity (in [S ~> ppt]) that are being restored toward. @@ -134,7 +139,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) fluxes%heat_added(i,j) = (G%mask2dT(i,j) * (rhoXcp * CS%Flux_const)) * & (Temp_restore - sfc_state%SST(i,j)) - fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%Rho0*CS%Flux_const)) * & + fluxes%vprec(i,j) = - (G%mask2dT(i,j) * (CS%rho_restore*CS%Flux_const)) * & ((Salin_restore - sfc_state%SSS(i,j)) / (0.5 * (Salin_restore + sfc_state%SSS(i,j)))) enddo ; enddo else @@ -144,7 +149,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) ! "Buoyancy restoring used without modification." ) ! The -1 is because density has the opposite sign to buoyancy. - buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%Rho0 + buoy_rest_const = -1.0 * (CS%G_Earth * CS%Flux_const) / CS%rho_restore Temp_restore = 0.0 do j=js,je ; do i=is,ie ! Set density_restore to an expression for the surface potential @@ -158,8 +163,7 @@ subroutine BFB_buoyancy_forcing(sfc_state, fluxes, day, dt, G, US, CS) (G%geoLatT(i,j) - CS%lfrslat) + CS%SST_s endif - density_restore = Temp_restore*CS%drho_dt + CS%Rho0 - + density_restore = (CS%Rho_T0_S0 + CS%dRho_dS*CS%S_ref) + CS%dRho_dT*Temp_restore fluxes%buoy(i,j) = G%mask2dT(i,j) * buoy_rest_const * & (density_restore - sfc_state%sfc_density(i,j)) enddo ; enddo @@ -216,9 +220,17 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) call get_param(param_file, mdl, "SST_N", CS%SST_n, & "SST at the northern edge of the linear forcing ramp.", & units="degC", default=10.0, scale=US%degC_to_C) - call get_param(param_file, mdl, "DRHO_DT", CS%drho_dt, & - "The rate of change of density with temperature.", & + call get_param(param_file, mdl, "DRHO_DT", CS%dRho_dT, & + "The partial derivative of density with temperature.", & units="kg m-3 K-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC) + call get_param(param_file, mdl, "DRHO_DS", CS%dRho_dS, & + "The partial derivative of density with salinity.", & + units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + call get_param(param_file, mdl, "RHO_T0_S0", CS%Rho_T0_S0, & + "The density at T=0, S=0.", units="kg m-3", default=1000.0, scale=US%kg_m3_to_R) + call get_param(param_file, mdl, "S_REF", CS%S_ref, & + "The reference salinity used here throughout the domain.", & + units="PSU", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& @@ -231,6 +243,11 @@ subroutine BFB_surface_forcing_init(Time, G, US, param_file, diag, CS) default=0.0, units="m day-1", scale=US%m_to_Z*US%T_to_s) ! Convert CS%Flux_const from m day-1 to m s-1. CS%Flux_const = CS%Flux_const / 86400.0 + call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & + "The density that is used to convert piston velocities into salt or heat "//& + "fluxes with RESTORE_SALINITY or RESTORE_TEMPERATURE.", & + units="kg m-3", default=CS%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(CS%Flux_const==0.0)) endif end subroutine BFB_surface_forcing_init From d4aa10857b7679701fdbd44ea67adc6213c0800c Mon Sep 17 00:00:00 2001 From: Ian Grooms Date: Tue, 29 Aug 2023 09:39:55 -0600 Subject: [PATCH 401/629] Add Leith+E (#251) * Add Leith+E This commit adds the 2D Leith+E closure, which uses a modified 2D Leith biharmonic viscosity paired with a harmonic backscatter. ('Modified' here is not used in the same sense as 'modified 2D Leith'; it just means that the biharmonic coefficient is modified to account for enstrophy backscatter.) Variables are often named 'leithy' to refer to Leith+E. The parameterization is controlled by three main entries in user_nl_mom: 1. USE_LEITHY = True 2. LEITH_CK = 1.0 3. LEITH_BI_CONST = 8.0 To use Leith+E you should have LAPLACIAN=True and BIHARMONIC=True. (It doesn't hurt to be explicit and also set LEITH_AH=False, along with any other viscous closures, but this is not required. If USE_LEITHY=True it will not use any of the other schemes. It does use the background value of the biharmonic coefficient as a minimum, but ignores the background harmonic value.) LEITH_CK is the fraction of energy dissipated by the biharmonic term that gets backscattered by the harmonic term (it's a target; the backscatter rate is not exact.) Recommended values between 0 and 1. LEITH_BI_CONST is Upsilon^6 where Upsilon is the ratio between the grid scale and the dissipation scale for enstrophy. Values should be greater than or equal to 1; 8 is a good place to start. The code is sensitive to the background value of Ah; specifically, if Ah is too large, the code is unstable. This is because the backscatter coefficient is proportional to Ah, and if Ah is large then you get large backscatter. If your code is unstable, consider reducing, e.g., `AH_VEL_SCALE`. * Background Ah This commit updates the code so that it uses the background Ah as a minimum. Previously, if `SMAGORINSKY_AH = True`, Leith+E would use the Smag value of Ah as the minimum, which is incorrect. * Improve logging Removed `do_not_log` condition on `USE_LEITHY` * Fix Leithy Logic Added one line to fix the fact that the code would only work as intended if either (i) writing out Ah_h, or (ii) in debug mode. Also swapped .le. and .lt. for <= and <. --- .../lateral/MOM_hor_visc.F90 | 379 ++++++++++++++++-- 1 file changed, 345 insertions(+), 34 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 9037c71c5a..5bd3809a85 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -69,6 +69,11 @@ module MOM_hor_visc logical :: use_beta_in_Leith !< If true, includes the beta term in the Leith viscosity logical :: Leith_Ah !< If true, use a biharmonic form of 2D Leith !! nonlinear eddy viscosity. AH is the background. + logical :: use_Leithy !< If true, use a biharmonic form of 2D Leith + !! nonlinear eddy viscosity with harmonic backscatter. + !! Ah is the background. Leithy = Leith+E + real :: c_K !< Fraction of energy dissipated by the biharmonic term + !! that gets backscattered in the Leith+E scheme. [nondim] logical :: use_QG_Leith_visc !< If true, use QG Leith nonlinear eddy viscosity. !! KH is the background value. logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic @@ -149,10 +154,12 @@ module MOM_hor_visc n1n1_m_n2n2_q !< Factor n1**2-n2**2 in the anisotropic direction tensor at q-points [nondim] real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: & - dx2h, & !< Pre-calculated dx^2 at h points [L2 ~> m2] - dy2h, & !< Pre-calculated dy^2 at h points [L2 ~> m2] - 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] + dx_dyT, & !< Pre-calculated dx/dy at h points [nondim] + dy_dxT, & !< Pre-calculated dy/dx at h points [nondim] + m_const_leithy, & !< Pre-calculated .5*sqrt(c_K)*max{dx,dy} [L ~> m] + m_leithy_max !< Pre-calculated 4./max(dx,dy)^2 at h points [L-2 ~> m-2] real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEMB_PTR_) :: & dx2q, & !< Pre-calculated dx^2 at q points [L2 ~> m2] dy2q, & !< Pre-calculated dy^2 at q points [L2 ~> m2] @@ -261,18 +268,23 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Del2u, & ! The u-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_u, & ! Thickness interpolated to u points [H ~> m or kg m-2]. vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dy_smooth, & ! y-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - ubtav ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + ubtav, & ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] + vort_xy_dx_smooth, & ! x-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - vbtav ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + vbtav, & ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] + v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [T-1 ~> s-1] div_xx, & ! Estimate of horizontal divergence at h-points [T-1 ~> s-1] sh_xx, & ! horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] + sh_xx_smooth, & ! horizontal tension from smoothed velocity including metric terms [T-1 ~> s-1] sh_xx_bt, & ! barotropic horizontal tension (du/dx - dv/dy) including metric terms [T-1 ~> s-1] str_xx,& ! str_xx is the diagonal term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. @@ -283,23 +295,28 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_vort_mag_h_2d, & ! Magnitude of 2d vorticity gradient at h-points [L-1 T-1 ~> m-1 s-1] grad_div_mag_h, & ! Magnitude of divergence gradient at h-points [L-1 T-1 ~> m-1 s-1] dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] + dudx_smooth, dvdy_smooth, & ! components in the horizontal tension from smoothed velocity [T-1 ~> s-1] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot ! The total thickness of all layers [Z ~> m] + htot, & ! The total thickness of all layers [Z ~> m] + m_leithy ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] real, dimension(SZIB_(G),SZJB_(G)) :: & dvdx, dudy, & ! components in the shearing strain [T-1 ~> s-1] + dvdx_smooth, dudy_smooth, & ! components in the shearing strain from smoothed velocity [T-1 ~> s-1] dDel2vdx, dDel2udy, & ! Components in the biharmonic equivalent of the shearing strain [L-2 T-1 ~> m-2 s-1] dvdx_bt, dudy_bt, & ! components in the barotropic shearing strain [T-1 ~> s-1] sh_xy, & ! horizontal shearing strain (du/dy + dv/dx) including metric terms [T-1 ~> s-1] + sh_xy_smooth, & ! horizontal shearing strain from smoothed velocity including metric terms [T-1 ~> s-1] sh_xy_bt, & ! barotropic horizontal shearing strain (du/dy + dv/dx) inc. metric terms [T-1 ~> s-1] str_xy, & ! str_xy is the cross term in the stress tensor [H L2 T-2 ~> m3 s-2 or kg s-2], but ! at some points in the code it is not yet layer integrated, so is in [L2 T-2 ~> m2 s-2]. str_xy_GME, & ! smoothed cross term in the stress tensor from GME [L2 T-2 ~> m2 s-2] bhstr_xy, & ! A copy of str_xy that only contains the biharmonic contribution [H L2 T-2 ~> m3 s-2 or kg s-2] vort_xy, & ! Vertical vorticity (dv/dx - du/dy) including metric terms [T-1 ~> s-1] + vort_xy_smooth, & ! Vertical vorticity including metric terms, smoothed [T-1 ~> s-1] grad_vort_mag_q, & ! Magnitude of vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] @@ -346,6 +363,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] + real :: AhLthy ! 2D Leith+E biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Shear_mag_bc ! Shear_mag value in backscatter [T-1 ~> s-1] real :: sh_xx_sq ! Square of tension (sh_xx) [T-2 ~> s-2] real :: sh_xy_sq ! Square of shearing strain (sh_xy) [T-2 ~> s-2] @@ -397,6 +415,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Kh, & ! Laplacian viscosity (h or q) [L2 T-1 ~> m2 s-1] Shear_mag, & ! magnitude of the shear (h or q) [T-1 ~> s-1] vert_vort_mag, & ! magnitude of the vertical vorticity gradient (h or q) [L-1 T-1 ~> m-1 s-1] + vert_vort_mag_smooth, & ! magnitude of gradient of smoothed vertical vorticity (h or q) [L-1 T-1 ~> m-1 s-1] hrat_min, & ! h_min divided by the thickness at the stress point (h or q) [nondim] visc_bound_rem ! fraction of overall viscous bounds that remain to be applied (h or q) [nondim] @@ -409,6 +428,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 + m_leithy(:,:) = 0. ! Initialize + if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally apply_OBC = .true. @@ -561,7 +582,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP grid_Ah, grid_Kh, d_Del2u, d_Del2v, d_str, & !$OMP Kh, Ah, AhSm, AhLth, local_strain, Sh_F_pow, & !$OMP dDel2vdx, dDel2udy, Del2vort_q, Del2vort_h, KE, & - !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff & + !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, & + !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & + !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & + !$OMP sh_xx_smooth, sh_xy_smooth, u_smooth, v_smooth, & + !$OMP vert_vort_mag_smooth, m_leithy, AhLthy & !$OMP ) do k=1,nz @@ -590,6 +615,30 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, dudy(I,J) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo + if (CS%use_Leithy) then + ! Smooth the velocity. Right now it happens twice. In the future + ! one might make the number of smoothing cycles a user-specified parameter + u_smooth(:,:) = u(:,:,k) + v_smooth(:,:) = v(:,:,k) + call smooth_x9(CS, G, field_u=u_smooth,field_v=v_smooth) ! one call applies the filter twice + ! Calculate horizontal tension from smoothed velocity + do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + dudx_smooth(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u_smooth(I,j) - & + G%IdyCu(I-1,j) * u_smooth(I-1,j)) + dvdy_smooth(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v_smooth(i,J) - & + G%IdxCv(i,J-1) * v_smooth(i,J-1)) + sh_xx_smooth(i,j) = dudx_smooth(i,j) - dvdy_smooth(i,j) + enddo ; enddo + + ! Components for the shearing strain from smoothed velocity + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + dvdx_smooth(I,J) = CS%DY_dxBu(I,J) * & + (v_smooth(i+1,J)*G%IdyCv(i+1,J) - v_smooth(i,J)*G%IdyCv(i,J)) + dudy_smooth(I,J) = CS%DX_dyBu(I,J) * & + (u_smooth(I,j+1)*G%IdxCu(I,j+1) - u_smooth(I,j)*G%IdxCu(I,j)) + enddo ; enddo + end if ! use Leith+E + if (CS%id_normstress > 0) then do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 NoSt(i,j,k) = sh_xx(i,j) @@ -743,6 +792,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). + ! dudy_smooth and dvdx_smooth do not (yet) include modifications at OBCs from above. + if (CS%no_slip) then + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + else + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + sh_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) + enddo ; enddo + endif + endif ! use Leith+E + ! Evaluate Del2u = x.Div(Grad u) and Del2v = y.Div( Grad u) if (CS%biharmonic) then do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 @@ -780,12 +843,24 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + if (CS%no_slip) then + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + else + do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + vort_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) + enddo ; enddo + endif + endif + ! Divergence do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 div_xx(i,j) = dudx(i,j) + dvdy(i,j) enddo ; enddo - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then ! Vorticity gradient do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 @@ -798,6 +873,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo + if (CS%use_Leithy) then + ! Gradient of smoothed vorticity + do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) + vort_xy_dx_smooth(i,J) = DY_dxBu * & + (vort_xy_smooth(I,J) * G%IdyCu(I,j) - vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j)) + enddo ; enddo + + do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) + vort_xy_dy_smooth(I,j) = DX_dyBu * & + (vort_xy_smooth(I,J) * G%IdxCv(i,J) - vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1)) + enddo ; enddo + endif ! If Leithy + ! Laplacian of vorticity do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) @@ -880,6 +970,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) enddo ; enddo + if (CS%use_Leithy) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + vert_vort_mag_smooth(i,j) = SQRT((0.5*(vort_xy_dx_smooth(i,J) + & + vort_xy_dx_smooth(i,J-1)))**2 + & + (0.5*(vort_xy_dy_smooth(I,j) + & + vort_xy_dy_smooth(I-1,j)))**2 ) + enddo ; enddo + endif ! Leithy + endif ! CS%Leith_Kh if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then @@ -905,6 +1004,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Laplacian) then + ! Determine the Laplacian viscosity at h points, using the + ! largest value from several parameterizations. Also get + ! the Laplacian component of str_xx. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -919,9 +1022,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - ! Determine the Laplacian viscosity at h points, using the - ! largest value from several parameterizations. - ! Static (pre-computed) background viscosity do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Kh(i,j) = CS%Kh_bg_xx(i,j) @@ -995,6 +1095,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. + ! The harmonic component of str_xx is added in the biharmonic loop. + if (CS%use_Leithy) then + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = 0. + enddo ; enddo + end if + if (CS%id_Kh_h>0 .or. CS%debug) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Kh_h(i,j,k) = Kh(i,j) @@ -1028,7 +1136,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = 0.0 enddo ; enddo - endif + endif ! Get Kh at h points and get Laplacian component of str_xx if (CS%anisotropic) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1041,12 +1149,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%biharmonic) then ! Determine the biharmonic viscosity at h points, using the - ! largest value from several parameterizations. + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xx. do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Ah(i,j) = CS%Ah_bg_xx(i,j) enddo ; enddo - if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah)) then + if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 @@ -1072,12 +1181,50 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Get m_leithy + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLth = CS%Biharm6_const_xx(i,j) * inv_PI6 * abs(Del2vort_h) + if (AhLth <= CS%Ah_bg_xx(i,j)) then + m_leithy(i,j) = 0.0 + else + if ((CS%m_const_leithy(i,j)*vert_vort_mag(i,j)) < abs(vort_xy_smooth(i,j))) then + m_leithy(i,j) = CS%c_K * (vert_vort_mag(i,j) / vort_xy_smooth(i,j))**2 + else + m_leithy(i,j) = CS%m_leithy_max(i,j) + endif + endif + enddo ; enddo + ! Smooth m_leithy + call smooth_x9(CS, G, field_h=m_leithy, zero_land=.true.) + ! Get Ah + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & + (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) + AhLthy = CS%Biharm6_const_xx(i,j) * inv_PI6 * & + sqrt(max(0.,Del2vort_h**2 - m_leithy(i,j)*vert_vort_mag_smooth(i,j)**2)) + Ah(i,j) = max(CS%Ah_bg_xx(i,j), AhLthy) + enddo ; enddo + ! Smooth Ah before applying upper bound + ! square, then smooth, then square root + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = Ah(i,j)**2 + enddo ; enddo + call smooth_x9(CS, G, field_h=Ah_h(:,:,k)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Ah_h(i,j,k) = sqrt(Ah_h(i,j,k)) + Ah(i,j) = Ah_h(i,j,k) + enddo ; enddo + endif + if (CS%bound_Ah .and. .not. CS%better_bound_Ah) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xx(i,j)) enddo ; enddo endif - endif ! Smagorinsky_Ah or Leith_Ah + endif ! Smagorinsky_Ah or Leith_Ah or Leith+E if (use_MEKE_Au) then ! *Add* the MEKE contribution @@ -1111,6 +1258,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + if (CS%use_Leithy) then + ! Compute Leith+E Kh after bounds have been applied to Ah + ! and after it has been smoothed. Kh = -m_leithy * Ah + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + Kh(i,j) = -m_leithy(i,j) * Ah(i,j) + Kh_h(i,j,k) = Kh(i,j) + enddo ; enddo + endif + if (CS%id_grid_Re_Ah>0) then do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 KE = 0.125 * ((u(I,j,k) + u(I-1,j,k))**2 + (v(i,J,k) + v(i,J-1,k))**2) @@ -1126,10 +1282,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, str_xx(i,j) = str_xx(i,j) + d_str + if (CS%use_Leithy) str_xx(i,j) = str_xx(i,j) - Kh(i,j) * sh_xx_smooth(i,j) + ! Keep a copy of the biharmonic contribution for backscatter parameterization bhstr_xx(i,j) = d_str * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo - endif + endif ! Get biharmonic coefficient at h points and biharmonic part of str_xx if (CS%biharmonic) then ! Gradient of Laplacian, for use in bi-harmonic term @@ -1218,6 +1376,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Laplacian) then + ! Determine the Laplacian viscosity at q points, using the + ! largest value from several parameterizations. Also get the + ! Laplacian component of str_xy. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1232,9 +1394,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif - ! Determine the Laplacian viscosity at q points, using the - ! largest value from several parameterizations. - ! Static (pre-computed) background viscosity do J=js-1,Jeq ; do I=is-1,Ieq Kh(I,J) = CS%Kh_bg_xy(I,J) @@ -1301,6 +1460,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + Kh(I,J) = Kh_h(i+1,j+1,k) + end if + if (CS%id_Kh_q>0 .or. CS%debug) & Kh_q(I,J,k) = Kh(I,J) @@ -1311,14 +1475,20 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, sh_xy_q(I,J,k) = sh_xy(I,J) enddo ; enddo - do J=js-1,Jeq ; do I=is-1,Ieq - str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) - enddo ; enddo + if ( .not. CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy(I,J) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + str_xy(I,J) = -Kh(I,J) * sh_xy_smooth(I,J) + enddo ; enddo + endif else do J=js-1,Jeq ; do I=is-1,Ieq str_xy(I,J) = 0. enddo ; enddo - endif + endif ! get harmonic coefficient Kh at q points and harmonic part of str_xy if (CS%anisotropic) then do J=js-1,Jeq ; do I=is-1,Ieq @@ -1331,7 +1501,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%biharmonic) then ! Determine the biharmonic viscosity at q points, using the - ! largest value from several parameterizations. + ! largest value from several parameterizations. Also get the + ! biharmonic component of str_xy. do J=js-1,Jeq ; do I=is-1,Ieq Ah(I,J) = CS%Ah_bg_xy(I,J) enddo ; enddo @@ -1395,6 +1566,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif + ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points + if (CS%use_Leithy) then + do J=js-1,Jeq ; do I=is-1,Ieq + Ah(I,J) = Ah_h(i+1,j+1,k) + enddo ; enddo + end if + if (CS%id_Ah_q>0 .or. CS%debug) then do J=js-1,Jeq ; do I=is-1,Ieq Ah_q(I,J,k) = Ah(I,J) @@ -1410,7 +1588,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Keep a copy of the biharmonic contribution for backscatter parameterization bhstr_xy(I,J) = d_str * (hq(I,J) * G%mask2dBu(I,J) * CS%reduction_xy(I,J)) enddo ; enddo - endif + endif ! Get Ah at q points and biharmonic part of str_xy if (CS%use_GME) then ! The wider halo here is to permit one pass of smoothing without a halo update. @@ -1937,6 +2115,10 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "If true, use a biharmonic Leith nonlinear eddy "//& "viscosity.", default=.false., do_not_log=.not.CS%biharmonic) if (.not.CS%biharmonic) CS%Leith_Ah = .false. + call get_param(param_file, mdl, "USE_LEITHY", CS%use_Leithy, & + "If true, use a biharmonic Leith nonlinear eddy "//& + "viscosity together with a harmonic backscatter.", & + default=.false.) call get_param(param_file, mdl, "BOUND_AH", CS%bound_Ah, & "If true, the biharmonic coefficient is locally limited "//& "to be stable.", default=.true., do_not_log=.not.CS%biharmonic) @@ -1995,12 +2177,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "Coriolis acceleration. The default is set by MAXVEL.", & units="m s-1", default=maxvel*US%L_T_to_m_s, scale=US%m_s_to_L_T, & do_not_log=.not.(CS%Smagorinsky_Ah .and. CS%bound_Coriolis)) - call get_param(param_file, mdl, "LEITH_BI_CONST", Leith_bi_const, & "The nondimensional biharmonic Leith constant, "//& "typical values are thus far undetermined.", units="nondim", default=0.0, & - fail_if_missing=CS%Leith_Ah, do_not_log=.not.CS%Leith_Ah) - + fail_if_missing=(CS%Leith_Ah .or. CS%use_Leithy), & + do_not_log=.not.(CS%Leith_Ah .or. CS%use_Leithy)) call get_param(param_file, mdl, "USE_LAND_MASK_FOR_HVISC", CS%use_land_mask, & "If true, use the land mask for the computation of thicknesses "//& "at velocity locations. This eliminates the dependence on arbitrary "//& @@ -2032,6 +2213,16 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "with the Gent and McWilliams parameterization.", default=.false.) call get_param(param_file, mdl, "SPLIT", split, & "Use the split time stepping if true.", default=.true., do_not_log=.true.) + if (CS%use_Leithy) then + if (.not.(CS%biharmonic .and. CS%Laplacian)) then + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + "LAPLACIAN and BIHARMONIC must both be True when USE_LEITHY=True.") + endif + call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, & + "Fraction of biharmonic dissipation that gets backscattered, "//& + "in Leith+E.", units="nondim", default=1.0) + endif + if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") @@ -2150,9 +2341,13 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ALLOC_(CS%Biharm_const2_xy(IsdB:IedB,JsdB:JedB)) ; CS%Biharm_const2_xy(:,:) = 0.0 endif endif - if (CS%Leith_Ah) then - ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 - ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then + ALLOC_(CS%biharm6_const_xx(isd:ied,jsd:jed)) ; CS%biharm6_const_xx(:,:) = 0.0 + ALLOC_(CS%biharm6_const_xy(IsdB:IedB,JsdB:JedB)) ; CS%biharm6_const_xy(:,:) = 0.0 + endif + if (CS%use_Leithy) then + ALLOC_(CS%m_const_leithy(isd:ied,jsd:jed)) ; CS%m_const_leithy(:,:) = 0.0 + ALLOC_(CS%m_leithy_max(isd:ied,jsd:jed)) ; CS%m_leithy_max(:,:) = 0.0 endif if (CS%Re_Ah > 0.0) then ALLOC_(CS%Re_Ah_const_xx(isd:ied,jsd:jed)); CS%Re_Ah_const_xx(:,:) = 0.0 @@ -2295,6 +2490,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (CS%Leith_Ah) then CS%biharm6_const_xx(i,j) = Leith_bi_const * (grid_sp_h3 * grid_sp_h3) endif + if (CS%use_Leithy) then + CS%biharm6_const_xx(i,j) = Leith_bi_const * max(G%dxT(i,j),G%dyT(i,j))**6 + CS%m_const_leithy(i,j) = 0.5 * sqrt(CS%c_K) * max(G%dxT(i,j),G%dyT(i,j)) + CS%m_leithy_max(i,j) = 4. / max(G%dxT(i,j),G%dyT(i,j))**2 + endif CS%Ah_bg_xx(i,j) = MAX(Ah, Ah_vel_scale * grid_sp_h2 * sqrt(grid_sp_h2)) if (CS%Re_Ah > 0.0) CS%Re_Ah_const_xx(i,j) = grid_sp_h3 / CS%Re_Ah if (Ah_time_scale > 0.) CS%Ah_bg_xx(i,j) = & @@ -2317,7 +2517,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) (abs(G%CoriolisBu(I,J)) * BoundCorConst) endif endif - if (CS%Leith_Ah) then + if ((CS%Leith_Ah) .or. (CS%use_Leithy))then CS%biharm6_const_xy(I,J) = Leith_bi_const * (grid_sp_q3 * grid_sp_q3) endif CS%Ah_bg_xy(I,J) = MAX(Ah, Ah_vel_scale * grid_sp_q2 * sqrt(grid_sp_q2)) @@ -2659,6 +2859,113 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) enddo ! s-loop end subroutine smooth_GME +!> Apply a 9-point smoothing filter twice to reduce horizontal two-grid-point noise +!! Note that this subroutine does not conserve mass or angular momentum, so don't use it +!! in situations where you need conservation. Also can't apply it to Ah and Kh in the +!! horizontal_viscosity subroutine because they are not supposed to be halo-updated. +!! But you _can_ apply them to Kh_h and Ah_h. +subroutine smooth_x9(CS, G, field_h, field_u, field_v, field_q, zero_land) + type(hor_visc_CS), intent(in) :: CS !< Control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: field_h !< field to be smoothed + !! at h points + real, dimension(SZIB_(G),SZJ_(G)), optional, intent(inout) :: field_u !< field to be smoothed + !! at u points + real, dimension(SZI_(G),SZJB_(G)), optional, intent(inout) :: field_v !< field to be smoothed + !! at v points + real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: field_q !< field to be smoothed + !! at q points + logical, optional, intent(in) :: zero_land !< An optional argument + !! indicating whether to set values + !! on land to zero (.true.) or + !! whether to ignore land values + !! (.false. or not present) + ! local variables. It would be good to make the _original variables allocatable. + real, dimension(SZI_(G),SZJ_(G)) :: field_h_original + real, dimension(SZIB_(G),SZJ_(G)) :: field_u_original + real, dimension(SZI_(G),SZJB_(G)) :: field_v_original + real, dimension(SZIB_(G),SZJB_(G)) :: field_q_original + real, dimension(3,3) :: weights, local_weights ! averaging weights for smoothing, nondimensional + logical :: zero_land_val ! actual value of zero_land optional argument + integer :: i, j, s + 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 + + weights = reshape([1., 2., 1., 2., 4., 2., 1., 2., 1.],shape(weights))/16. + + if (present(zero_land)) then + zero_land_val = zero_land + else + zero_land_val = .false. + endif + + if (present(field_h)) then + call pass_var(field_h, G%Domain, halo=2) ! Halo size 2 ensures that you can smooth twice + do s=1,0,-1 + field_h_original(:,:) = field_h(:,:) + ! apply smoothing on field_h + do j=js-s,je+s ; do i=is-s,ie+s + ! skip land points + if (G%mask2dT(i,j)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dT(i-1:i+1,j-1:j+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_h(i,j) = sum(local_weights*field_h_original(i-1:i+1,j-1:j+1)) + enddo ; enddo + enddo + call pass_var(field_h, G%Domain) + endif + + if (present(field_u)) then + call pass_vector(field_u, field_v, G%Domain, halo=2) + do s=1,0,-1 + field_u_original(:,:) = field_u(:,:) + ! apply smoothing on field_u + do j=js-s,je+s ; do I=Isq-s,Ieq+s + ! skip land points + if (G%mask2dCu(I,j)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dCu(I-1:I+1,j-1:j+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_u(I,j) = sum(local_weights*field_u_original(I-1:I+1,j-1:j+1)) + enddo ; enddo + + field_v_original(:,:) = field_v(:,:) + ! apply smoothing on field_v + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s + ! skip land points + if (G%mask2dCv(i,J)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dCv(i-1:i+1,J-1:J+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_v(i,J) = sum(local_weights*field_v_original(i-1:i+1,J-1:J+1)) + enddo ; enddo + enddo + call pass_vector(field_u, field_v, G%Domain) + endif + + if (present(field_q)) then + call pass_var(field_q, G%Domain, halo=2, position=CORNER) + do s=1,0,-1 + field_q_original(:,:) = field_q(:,:) + ! apply smoothing on field_q + do J=Jsq-s,Jeq+s ; do I=Isq-s,Ieq+s + ! skip land points + if (G%mask2dBu(I,J)==0.) cycle + ! compute local weights + local_weights = weights*G%mask2dBu(I-1:I+1,J-1:J+1) + if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) + field_q(I,J) = sum(local_weights*field_q_original(I-1:I+1,J-1:J+1)) + enddo ; enddo + enddo + call pass_var(field_q, G%Domain, position=CORNER) + endif + +end subroutine smooth_x9 + !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure @@ -2691,9 +2998,13 @@ subroutine hor_visc_end(CS) if (CS%Smagorinsky_Ah) then DEALLOC_(CS%Biharm_const_xx) ; DEALLOC_(CS%Biharm_const_xy) endif - if (CS%Leith_Ah) then + if ((CS%Leith_Ah) .or. (CS%use_Leithy)) then DEALLOC_(CS%Biharm6_const_xx) ; DEALLOC_(CS%Biharm6_const_xy) endif + if (CS%use_Leithy) then + DEALLOC_(CS%m_const_leithy) + DEALLOC_(CS%m_leithy_max) + endif if (CS%Re_Ah > 0.0) then DEALLOC_(CS%Re_Ah_const_xx) ; DEALLOC_(CS%Re_Ah_const_xy) endif From 279ee1cb14b31dae69dc0d25e094987e6ee43aab Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Aug 2023 18:38:11 -0400 Subject: [PATCH 402/629] Use GV%dZ_subroundoff Use the minimal vertical distance GV%dZ_subroundoff in 8 spots in 2 files in place of GV%H_to_Z*GV%H_subroundoff. Four internal variables were renamed for clarity of purpose in porous_widths_layer and PressureForce_Mont_Bouss. Also modified the non-Boussinesq units in a description of two integrated energy diagnostics from [H L4 T-3 ~> kg m2 s-3] to [H L4 T-3 ~> W]; these units are equivalent but the latter is more informative. Answers in all Boussinesq test cases and the existing non-Boussinesq test case in the MOM6-examples test suite are bitwise identical. --- src/core/MOM_PressureForce_Montgomery.F90 | 16 ++++++++-------- src/core/MOM_porous_barriers.F90 | 16 ++++++++-------- src/diagnostics/MOM_diagnostics.F90 | 4 ++-- 3 files changed, 18 insertions(+), 18 deletions(-) diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index a22c73fa4d..3de713c801 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -428,7 +428,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, real :: G_Rho0 ! G_Earth / Rho0 [L2 Z-1 T-2 R-1 ~> m4 s-2 kg-1]. real :: PFu_bc, PFv_bc ! The pressure gradient force due to along-layer ! compensated density gradients [L T-2 ~> m s-2] - real :: h_neglect ! A thickness that is so small it is usually lost + real :: dz_neglect ! A vertical distance that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. logical :: use_p_atm ! If true, use the atmospheric pressure. logical :: use_EOS ! If true, density is calculated from T & S using @@ -459,7 +459,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, "can no longer be used with a compressible EOS. Use #define ANALYTIC_FV_PGF.") endif - h_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff I_Rho0 = 1.0/CS%Rho0 G_Rho0 = GV%g_Earth / GV%Rho0 @@ -582,7 +582,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, !$OMP parallel do default(shared) private(h_star,PFu_bc,PFv_bc) do k=1,nz do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + h_neglect + h_star(i,j) = (e(i,j,K) - e(i,j,K+1)) + dz_neglect enddo ; enddo do j=js,je ; do I=Isq,Ieq PFu_bc = -1.0*(rho_star(i+1,j,k) - rho_star(i,j,k)) * (G%IdxCu(I,j) * & @@ -676,7 +676,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) real :: Rho0xG ! g_Earth * Rho0 [R L2 Z-1 T-2 ~> kg s-2 m-2] logical :: use_EOS ! If true, density is calculated from T & S using ! an equation of state. - real :: z_neglect ! A thickness that is so small it is usually lost + real :: dz_neglect ! A vertical distance that is so small it is usually lost ! in roundoff and can be neglected [Z ~> m]. integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, nz, i, j, k @@ -687,14 +687,14 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) Rho0xG = Rho0 * GV%g_Earth G_Rho0 = GV%g_Earth / GV%Rho0 use_EOS = associated(tv%eqn_of_state) - z_neglect = GV%H_subroundoff*GV%H_to_Z + dz_neglect = GV%dZ_subroundoff if (use_EOS) then if (present(rho_star)) then !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) pbce(i,j,1) = GFS_scale * rho_star(i,j,1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 @@ -706,7 +706,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) !$OMP parallel do default(shared) private(Ihtot,press,rho_in_situ,T_int,S_int,dR_dT,dR_dS) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = GV%H_to_Z / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) press(i) = -Rho0xG*(e(i,j,1) - G%Z_ref) enddo call calculate_density(tv%T(:,j,1), tv%S(:,j,1), press, rho_in_situ, & @@ -735,7 +735,7 @@ subroutine Set_pbce_Bouss(e, tv, G, GV, US, Rho0, GFS_scale, pbce, rho_star) !$OMP parallel do default(shared) private(Ihtot) do j=Jsq,Jeq+1 do i=Isq,Ieq+1 - Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + z_neglect) + Ihtot(i) = 1.0 / ((e(i,j,1)-e(i,j,nz+1)) + dz_neglect) pbce(i,j,1) = GV%g_prime(1) * GV%H_to_Z enddo do k=2,nz ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index d73d96b242..e212581993 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -80,7 +80,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) logical, dimension(SZIB_(G),SZJB_(G)) :: do_I ! Booleans for calculation at u or v points ! updated while moving up layers real :: A_layer ! Integral of fractional open width from bottom to current layer [Z ~> m] - real :: h_min ! ! The minimum layer thickness [Z ~> m] + real :: dz_min ! The minimum layer thickness [Z ~> m] real :: dmask ! The depth below which porous barrier is not applied [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq @@ -100,7 +100,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) call calc_eta_at_uv(eta_u, eta_v, CS%eta_interp, dmask, h, tv, G, GV, US) - h_min = GV%Angstrom_H * GV%H_to_Z + dz_min = GV%Angstrom_Z ! u-points do j=js,je ; do I=Isq,Ieq ; do_I(I,j) = .False. ; enddo ; enddo @@ -125,7 +125,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) do k=nk,1,-1 ; do j=js,je ; do I=Isq,Ieq ; if (do_I(I,j)) then call calc_por_layer(G%porous_DminU(I,j), G%porous_DmaxU(I,j), G%porous_DavgU(I,j), & eta_u(I,j,K), A_layer, do_I(I,j)) - if (eta_u(I,j,K) - (eta_u(I,j,K+1)+h_min) > 0.0) then + if (eta_u(I,j,K) - (eta_u(I,j,K+1)+dz_min) > 0.0) then pbv%por_face_areaU(I,j,k) = min(1.0, (A_layer - A_layer_prev(I,j)) / (eta_u(I,j,K) - eta_u(I,j,K+1))) else pbv%por_face_areaU(I,j,k) = 0.0 ! use calc_por_interface() might be a better choice @@ -157,7 +157,7 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) do k=nk,1,-1 ; do J=Jsq,Jeq ; do i=is,ie ; if (do_I(i,J)) then call calc_por_layer(G%porous_DminV(i,J), G%porous_DmaxV(i,J), G%porous_DavgV(i,J), & eta_v(i,J,K), A_layer, do_I(i,J)) - if (eta_v(i,J,K) - (eta_v(i,J,K+1)+h_min) > 0.0) then + if (eta_v(i,J,K) - (eta_v(i,J,K+1)+dz_min) > 0.0) then pbv%por_face_areaV(i,J,k) = min(1.0, (A_layer - A_layer_prev(i,J)) / (eta_v(i,J,K) - eta_v(i,J,K+1))) else pbv%por_face_areaV(i,J,k) = 0.0 ! use calc_por_interface() might be a better choice @@ -286,7 +286,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) ! local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: eta ! Layer interface heights [Z ~> m]. - real :: h_neglect ! Negligible thicknesses [Z ~> m] + real :: dz_neglect ! A negligible height difference [Z ~> m] integer :: i, j, k, nk, is, ie, js, je, Isq, Ieq, Jsq, Jeq is = G%isc; ie = G%iec; js = G%jsc; je = G%jec; nk = GV%ke @@ -295,7 +295,7 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) ! currently no treatment for using optional find_eta arguments if present call find_eta(h, tv, G, GV, US, eta, halo_size=1) - h_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff do K=1,nk+1 do j=js,je ; do I=Isq,Ieq ; eta_u(I,j,K) = dmask ; enddo ; enddo @@ -333,10 +333,10 @@ subroutine calc_eta_at_uv(eta_u, eta_v, interp, dmask, h, tv, G, GV, US, eta_bt) case (ETA_INTERP_HARM) ! Harmonic mean do K=1,nk+1 do j=js,je ; do I=Isq,Ieq ; if (G%porous_DavgU(I,j) < dmask) then - eta_u(I,j,K) = 2.0 * (eta(i,j,K) * eta(i+1,j,K)) / (eta(i,j,K) + eta(i+1,j,K) + h_neglect) + eta_u(I,j,K) = 2.0 * (eta(i,j,K) * eta(i+1,j,K)) / (eta(i,j,K) + eta(i+1,j,K) + dz_neglect) endif ; enddo ; enddo do J=Jsq,Jeq ; do i=is,ie ; if (G%porous_DavgV(i,J) < dmask) then - eta_v(i,J,K) = 2.0 * (eta(i,j,K) * eta(i,j+1,K)) / (eta(i,j,K) + eta(i,j+1,K) + h_neglect) + eta_v(i,J,K) = 2.0 * (eta(i,j,K) * eta(i,j+1,K)) / (eta(i,j,K) + eta(i,j+1,K) + dz_neglect) endif ; enddo ; enddo enddo case default diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index c23712d8e7..253b7189e3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -957,9 +957,9 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS 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 :: 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] + ! [H L4 T-3 ~> m5 s-3 or W] 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 L4 T-3 ~> m5 s-3 or W] real :: KE_h(SZI_(G),SZJ_(G)) ! A KE term contribution at tracer points ! [H L2 T-3 ~> m3 s-3 or W m-2] From 7d199ca052f5934b9717ca1247b40971468d61b8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 31 Jul 2023 03:20:04 -0400 Subject: [PATCH 403/629] +*Revise non-Boussinesq offline tracer diffusivity Rescale the units diapycnal diffusivity used in the offline tracer mode to work in [H Z T-1 ~> m2 s-1 or kg m-1 s-1], making it consistent with what has already been done for other diapycnal diffusivities. This change involves changes to the units of arguments to update_offline_from_files and ALE_offline_inputs and to two elements of offline_transport_CS. It also includes a new thermo_vary_type argument to offline_diabatic_ale, as well as a call to thickness_to_dz in that same routine to set the values of the newly added 3-d array of the vertical distances across layers and a change in name and units of the inverse thickness variable used to find the fluxes. All answers are bitwise identical in Boussinesq mode, but in offline tracer calculations in non-Boussinesq mode they will change to become independent of the Boussinesq reference density. --- src/ALE/MOM_ALE.F90 | 5 +++-- src/core/MOM.F90 | 2 +- src/tracer/MOM_offline_aux.F90 | 5 +++-- src/tracer/MOM_offline_main.F90 | 24 +++++++++++++++--------- 4 files changed, 22 insertions(+), 14 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index b8f60b2830..4d7445093a 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -504,13 +504,14 @@ subroutine ALE_offline_inputs(CS, G, GV, US, h, tv, Reg, uhtr, vhtr, Kd, debug, type(ALE_CS), pointer :: CS !< Regridding parameters and options type(ocean_grid_type), intent(in ) :: G !< Ocean grid informations type(verticalGrid_type), intent(in ) :: GV !< Ocean vertical grid structure - 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(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamic variable structure type(tracer_registry_type), pointer :: Reg !< Tracer registry structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: uhtr !< Zonal mass fluxes [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: vhtr !< Meridional mass fluxes [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivities [Z2 T-1 ~> m2 s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: Kd !< Input diffusivities + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] logical, intent(in ) :: debug !< If true, then turn checksums type(ocean_OBC_type), pointer :: OBC !< Open boundary structure ! Local variables diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e59c9ac60a..86040e8969 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1826,7 +1826,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS ! The functions related to column physics of tracers is performed separately in ALE mode if (do_vertical) then call offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS%offline_CSp, & - CS%h, eatr, ebtr) + CS%h, CS%tv, eatr, ebtr) endif ! Last thing that needs to be done is the final ALE remapping diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index 7619cac2bd..bd105439c7 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -642,7 +642,8 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s real, dimension(SZI_(G),SZJ_(G)), & intent(inout) :: mld !< Averaged mixed layer depth [Z ~> m] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - intent(inout) :: Kd !< Diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1] + intent(inout) :: Kd !< Diapycnal diffusivities at interfaces + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] type(forcing), intent(inout) :: fluxes !< Fields with surface fluxes integer, intent(in ) :: ridx_sum !< Read index for sum, mean, and surf files integer, intent(in ) :: ridx_snap !< Read index for snapshot file @@ -696,7 +697,7 @@ subroutine update_offline_from_files(G, GV, US, nk_input, mean_file, sum_file, s ! Check if reading vertical diffusivities or entrainment fluxes call MOM_read_data( mean_file, 'Kd_interface', Kd(:,:,1:nk_input+1), G%Domain, & - timelevel=ridx_sum, position=CENTER, scale=US%m2_s_to_Z2_T) + timelevel=ridx_sum, position=CENTER, scale=GV%m2_s_to_HZ_T) ! This block makes sure that the fluxes control structure, which may not be used in the solo_driver, ! contains netMassIn and netMassOut which is necessary for the applyTracerBoundaryFluxesInOut routine diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index dcce81ef73..06af35cefd 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -22,7 +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_interface_heights, only : calc_derived_thermo, thickness_to_dz 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 @@ -121,7 +121,8 @@ module MOM_offline_main real :: minimum_forcing_depth !< The smallest depth over which fluxes can be applied [H ~> m or kg m-2]. !! This is copied from diabatic_CS controlling how tracers follow freshwater fluxes - real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_max !< Runtime parameter specifying the maximum value of vertical diffusivity + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real :: min_residual !< The minimum amount of total mass flux before exiting the main advection !! routine [H L2 ~> m3 or kg] !>@{ Diagnostic manager IDs for some fields that may be of interest when doing offline transport @@ -169,7 +170,7 @@ module MOM_offline_main !< Amount of fluid entrained from the layer below within !! one time step [H ~> m or kg m-2] ! Fields at T-points on interfaces - real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:,:,:) :: Kd !< Vertical diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, allocatable, dimension(:,:,:) :: h_end !< Thicknesses at the end of offline timestep [H ~> m or kg m-2] real, allocatable, dimension(:,:) :: mld !< Mixed layer depths at thickness points [Z ~> m] @@ -651,7 +652,7 @@ end function remaining_transport_sum !> The vertical/diabatic driver for offline tracers. First the eatr/ebtr associated with the interpolated !! vertical diffusivities are calculated and then any tracer column functions are done which can include !! vertical diffuvities and source/sink terms. -subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_pre, eatr, ebtr) +subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_pre, tv, eatr, ebtr) type(forcing), intent(inout) :: fluxes !< pointers to forcing fields type(time_type), intent(in) :: Time_start !< starting time of a segment, as a time type @@ -662,17 +663,20 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p type(offline_transport_CS), pointer :: CS !< control structure from initialize_MOM real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h_pre !< layer thicknesses before advection [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) :: eatr !< Entrainment from layer above [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ebtr !< Entrainment from layer below [H ~> m or kg m-2] + ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & sw, sw_vis, sw_nir !< Save old values of shortwave radiation [Q R Z T-1 ~> W m-2] - real :: I_hval ! An inverse thickness [H-1 ~> m2 kg-1] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across layers [Z ~> m] + real :: I_dZval ! An inverse distance between layer centers [Z-1 ~> m] integer :: i, j, k, is, ie, js, je, nz integer :: k_nonzero - real :: Kd_bot ! Near-bottom diffusivity [Z2 T-1 ~> m2 s-1] + real :: Kd_bot ! Near-bottom diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] nz = GV%ke is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -687,6 +691,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p call MOM_tracer_chkinv("Before offline_diabatic_ale", G, GV, h_pre, CS%tracer_reg) endif + call thickness_to_dz(h_pre, tv, dz, G, GV, US) + eatr(:,:,:) = 0. ebtr(:,:,:) = 0. ! Calculate eatr and ebtr if vertical diffusivity is read @@ -713,8 +719,8 @@ subroutine offline_diabatic_ale(fluxes, Time_start, Time_end, G, GV, US, CS, h_p eatr(i,j,1) = 0. enddo ; enddo do k=2,nz ; do j=js,je ; do i=is,ie - I_hval = 1.0 / (GV%H_subroundoff + 0.5*(h_pre(i,j,k-1) + h_pre(i,j,k))) - eatr(i,j,k) = GV%Z_to_H**2 * CS%dt_offline_vertical * I_hval * CS%Kd(i,j,k) + I_dZval = 1.0 / (GV%dZ_subroundoff + 0.5*(dz(i,j,k-1) + dz(i,j,k))) + eatr(i,j,k) = CS%dt_offline_vertical * I_dZval * CS%Kd(i,j,k) ebtr(i,j,k-1) = eatr(i,j,k) enddo ; enddo ; enddo do j=js,je ; do i=is,ie @@ -1418,7 +1424,7 @@ subroutine offline_transport_init(param_file, CS, diabatic_CSp, G, GV, US) call get_param(param_file, mdl, "KD_MAX", CS%Kd_max, & "The maximum permitted increment for the diapycnal "//& "diffusivity from TKE-based parameterizations, or a "//& - "negative value for no limit.", units="m2 s-1", default=-1.0, scale=US%m2_s_to_Z2_T) + "negative value for no limit.", units="m2 s-1", default=-1.0, scale=GV%m2_s_to_HZ_T) call get_param(param_file, mdl, "MIN_RESIDUAL_TRANSPORT", CS%min_residual, & "How much remaining transport before the main offline advection is exited. "//& "The default value corresponds to about 1 meter of difference in a grid cell", & From 72fbee0e92abd1caa858b0cd24f0e0e97673587f Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 12 Aug 2023 11:23:32 -0400 Subject: [PATCH 404/629] +Obsolete 18 2018_ANSWERS runtime parameters Obsoleted 18 2018_ANSWERS parameters in 26 modules, with obsoleting message hints indicating the corresponding ANSWER_DATE parameters. The runtime parameters that have been obsoleted are DEFAULT_2018_ANSWERS, SURFACE_FORCING_2018_ANSWERS, WIND_GYRES_2018_ANSWERS, BAROTROPIC_2018_ANSWERS, EPBL_2018_ANSWERS, HOR_REGRID_2018_ANSWERS, HOR_VISC_2018_ANSWERS, IDL_HURR_2018_ANSWERS, MEKE_GEOMETRIC_2018_ANSWERS, ODA_2018_ANSWERS, OPTICS_2018_ANSWERS, REGULARIZE_LAYERS_2018_ANSWERS, REMAPPING_2018_ANSWERS, SET_DIFF_2018_ANSWERS, SET_VISC_2018_ANSWERS, SURFACE_2018_ANSWERS, TIDAL_MIXING_2018_ANSWERS and VERT_FRICTION_2018_ANSWERS. These changes will cause cases that use these older parameters to fail with a useful error message, but this change has been discussed and agreed to by the MOM6 community on July 17, 2023. All answers are bitwise identical in any cases that work. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 19 +---- .../solo_driver/MOM_surface_forcing.F90 | 21 +---- src/ALE/MOM_ALE.F90 | 21 +---- src/ALE/MOM_regridding.F90 | 19 +---- src/core/MOM.F90 | 21 +---- src/core/MOM_barotropic.F90 | 21 +---- src/core/MOM_open_boundary.F90 | 19 +---- src/diagnostics/MOM_diagnostics.F90 | 19 +---- src/diagnostics/MOM_obsolete_params.F90 | 33 ++++++++ src/framework/MOM_diag_mediator.F90 | 21 +---- .../MOM_state_initialization.F90 | 65 ++------------- .../MOM_tracer_initialization_from_Z.F90 | 40 +-------- src/ocean_data_assim/MOM_oda_driver.F90 | 22 +---- .../lateral/MOM_hor_visc.F90 | 19 +---- .../lateral/MOM_lateral_mixing_coeffs.F90 | 19 +---- .../lateral/MOM_thickness_diffuse.F90 | 20 +---- .../vertical/MOM_ALE_sponge.F90 | 82 ++----------------- .../vertical/MOM_energetic_PBL.F90 | 19 +---- .../vertical/MOM_opacity.F90 | 21 +---- .../vertical/MOM_regularize_layers.F90 | 19 +---- .../vertical/MOM_set_diffusivity.F90 | 21 +---- .../vertical/MOM_set_viscosity.F90 | 21 +---- .../vertical/MOM_tidal_mixing.F90 | 42 +--------- .../vertical/MOM_vert_friction.F90 | 22 +---- src/tracer/MOM_neutral_diffusion.F90 | 19 +---- src/user/Idealized_Hurricane.F90 | 20 +---- 26 files changed, 90 insertions(+), 595 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 713f04dc18..164193f6d7 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -1284,10 +1284,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! or other equivalent files. logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. 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 - ! the answers from the end of 2018. Otherwise, use a simpler - ! expression to calculate gustiness. type(time_type) :: Time_frc type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. @@ -1586,22 +1582,11 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "SURFACE_FORCING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use a simpler expression to calculate gustiness.", & - default=default_2018_answers) - ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "SURFACE_FORCING_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the gustiness "//& "calculations. Values below 20190101 recover the answers from the end "//& - "of 2018, while higher values use a simpler expression to calculate gustiness. "//& - "If both SURFACE_FORCING_2018_ANSWERS and SURFACE_FORCING_ANSWER_DATE are "//& - "specified, the latter takes precedence.", default=default_answer_date) + "of 2018, while higher values use a simpler expression to calculate gustiness.", & + default=default_answer_date) 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", & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 8d46a80cae..5a37b18604 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1529,11 +1529,6 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C # include "version_variable.h" real :: flux_const_default ! The unscaled value of FLUXCONST [m day-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 - ! the answers from the end of 2018. Otherwise, use a form of the gyre - ! wind stresses that are rotationally invariant and more likely to be - ! the same between compilers. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1769,24 +1764,12 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "WIND_GYRES_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions for the gyre friction velocities "//& - "that are rotationally invariant and more likely to be the same between compilers.", & - default=default_2018_answers) - ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "WIND_GYRES_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions used to set gyre wind stresses. "//& "Values below 20190101 recover the answers from the end of 2018, "//& "while higher values use a form of the gyre wind stresses that are "//& - "rotationally invariant and more likely to be the same between compilers. "//& - "If both WIND_GYRES_2018_ANSWERS and WIND_GYRES_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date) + "rotationally invariant and more likely to be the same between compilers.", & + default=default_answer_date) else CS%answer_date = 20190101 endif diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 4d7445093a..e1c8e6911e 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -170,10 +170,6 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) character(len=80) :: string, vel_string ! Temporary strings real :: filter_shallow_depth, filter_deep_depth ! Depth ranges of filtering [H ~> m or kg m-2] 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 for remapping - ! that recover the answers from the end of 2018. Otherwise, use more - ! robust and accurate forms of mathematically equivalent expressions. logical :: check_reconstruction logical :: check_remapping logical :: force_bounds_in_subcell @@ -231,25 +227,12 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call initialize_remapping( CS%remapCS, string, & diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index c238c2aa61..1b006dbbd3 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -209,8 +209,6 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m logical :: tmpLogical, do_sum, main_parameters logical :: coord_is_state_dependent, ierr integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the remapping expressions to use. integer :: regrid_answer_date ! The vintage of the regridding expressions to use. real :: tmpReal ! A temporary variable used in setting other variables [various] @@ -275,25 +273,12 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call set_regrid_params(CS, remap_answer_date=remap_answer_date) call get_param(param_file, mdl, "REGRIDDING_ANSWER_DATE", regrid_answer_date, & diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 86040e8969..ce001483ff 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2028,10 +2028,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: bound_salinity ! If true, salt is added to keep salinity above ! a minimum value, and the deficit is reported. 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 for the surface properties that recover - ! the answers from the end of 2018. Otherwise, use more appropriate - ! expressions that differ at roundoff for non-Boussinesq cases. logical :: use_conT_absS ! If true, the prognostics T & S are conservative temperature ! and absolute salinity. Care should be taken to convert them ! to potential temperature and practical salinity before @@ -2383,24 +2379,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, "MOM", "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=non_Bous) - call get_param(param_file, "MOM", "SURFACE_2018_ANSWERS", answers_2018, & - "If true, use expressions for the surface properties that recover the answers "//& - "from the end of 2018. Otherwise, use more appropriate expressions that differ "//& - "at roundoff for non-Boussinesq cases.", default=default_2018_answers, do_not_log=non_Bous) - ! Revise inconsistent default answer dates. - if (.not.non_Bous) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, "MOM", "SURFACE_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions for the surface properties. Values below "//& "20190101 recover the answers from the end of 2018, while higher values "//& - "use updated and more robust forms of the same expressions. "//& - "If both SURFACE_2018_ANSWERS and SURFACE_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=non_Bous) + "use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=non_Bous) if (non_Bous) CS%answer_date = 99991231 call get_param(param_file, "MOM", "USE_DIABATIC_TIME_BUG", CS%use_diabatic_time_bug, & diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index c814c563e3..e6f243a11c 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -4358,10 +4358,6 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, type(group_pass_type) :: pass_static_data, pass_q_D_Cor type(group_pass_type) :: pass_bt_hbt_btav, pass_a_polarity 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 for the barotropic solver that recover - ! the answers from the end of 2018. Otherwise, use more efficient - ! or general expressions. logical :: use_BT_cont_type logical :: use_tides character(len=48) :: thickness_units, flux_units @@ -4505,24 +4501,11 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "BAROTROPIC_2018_ANSWERS", answers_2018, & - "If true, use expressions for the barotropic solver that recover the answers "//& - "from the end of 2018. Otherwise, use more efficient or general expressions.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "BAROTROPIC_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the barotropic solver. "//& "Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values uuse more efficient or general expressions. "//& - "If both BAROTROPIC_2018_ANSWERS and BAROTROPIC_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "while higher values uuse more efficient or general expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "TIDES", use_tides, & diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index ba8b8ce818..36a71e3d52 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -422,11 +422,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG real :: Lscale_in, Lscale_out ! parameters controlling tracer values at the boundaries [L ~> m] - logical :: answers_2018 ! If true, use the order of arithmetic and expressions for remapping - ! that recover the answers from the end of 2018. Otherwise, use more - ! robust and accurate forms of mathematically equivalent expressions. 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 :: check_reconstruction, check_remapping, force_bounds_in_subcell character(len=64) :: remappingScheme ! This include declares and sets the variable "version". @@ -676,23 +672,12 @@ subroutine open_boundary_config(G, US, param_file, OBC) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - ! Revise inconsistent default answer dates for remapping. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", OBC%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date) allocate(OBC%remap_CS) call initialize_remapping(OBC%remap_CS, remappingScheme, boundary_extrapolation = .false., & diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 253b7189e3..aeb25bc351 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -1572,12 +1572,10 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag character(len=48) :: thickness_units, flux_units logical :: use_temperature, adiabatic 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. integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. - logical :: remap_answers_2018 CS%initialized = .true. @@ -1608,25 +1606,12 @@ subroutine MOM_diagnostics_init(MIS, ADp, CDp, Time, G, GV, US, param_file, diag call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "SPLIT", split, default=.true., do_not_log=.true.) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 7614eb210c..b1f4444b1b 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -115,6 +115,39 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "TIDAL_SAL_SHT", hint="Use SAL_HARMONICS instead.") call obsolete_int(param_file, "TIDAL_SAL_SHT_DEGREE", hint="Use SAL_HARMONICS_DEGREE instead.") call obsolete_real(param_file, "RHO_E", hint="Use RHO_SOLID_EARTH instead.") + call obsolete_logical(param_file, "DEFAULT_2018_ANSWERS", hint="Instead use DEFAULT_ANSWER_DATE.") + + call obsolete_logical(param_file, "SURFACE_FORCING_2018_ANSWERS", & + hint="Instead use SURFACE_FORCING_ANSWER_DATE.") + call obsolete_logical(param_file, "WIND_GYRES_2018_ANSWERS", & + hint="Instead use WIND_GYRES_ANSWER_DATE.") + + call obsolete_logical(param_file, "BAROTROPIC_2018_ANSWERS", & + hint="Instead use BAROTROPIC_ANSWER_DATE.") + call obsolete_logical(param_file, "EPBL_2018_ANSWERS", hint="Instead use EPBL_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_REGRID_2018_ANSWERS", & + hint="Instead use HOR_REGRID_ANSWER_DATE.") + call obsolete_logical(param_file, "HOR_VISC_2018_ANSWERS", & + hint="Instead use HOR_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "IDL_HURR_2018_ANSWERS", & + hint="Instead use IDL_HURR_ANSWER_DATE.") + call obsolete_logical(param_file, "MEKE_GEOMETRIC_2018_ANSWERS", & + hint="Instead use MEKE_GEOMETRIC_ANSWER_DATE.") + call obsolete_logical(param_file, "ODA_2018_ANSWERS", hint="Instead use ODA_ANSWER_DATE.") + call obsolete_logical(param_file, "OPTICS_2018_ANSWERS", hint="Instead use OPTICS_ANSWER_DATE.") + call obsolete_logical(param_file, "REGULARIZE_LAYERS_2018_ANSWERS", & + hint="Instead use REGULARIZE_LAYERS_ANSWER_DATE.") + call obsolete_logical(param_file, "REMAPPING_2018_ANSWERS", & + hint="Instead use REMAPPING_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_DIFF_2018_ANSWERS", & + hint="Instead use SET_DIFF_ANSWER_DATE.") + call obsolete_logical(param_file, "SET_VISC_2018_ANSWERS", & + hint="Instead use SET_VISC_ANSWER_DATE.") + call obsolete_logical(param_file, "SURFACE_2018_ANSWERS", hint="Instead use SURFACE_ANSWER_DATE.") + call obsolete_logical(param_file, "TIDAL_MIXING_2018_ANSWERS", & + hint="Instead use TIDAL_MIXING_ANSWER_DATE.") + call obsolete_logical(param_file, "VERT_FRICTION_2018_ANSWERS", & + hint="Instead use VERT_FRICTION_ANSWER_DATE.") ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 58511c866b..61290cb579 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3144,15 +3144,11 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) ! Local variables integer :: ios, i, new_unit logical :: opened, new_file - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. 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. character(len=8) :: this_pe character(len=240) :: doc_file, doc_file_dflt, doc_path character(len=240), allocatable :: diag_coords(:) @@ -3182,25 +3178,12 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & 'If true, use a grid index coordinate convention for diagnostic axes. ',& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index ddccf4a754..fc676781bc 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1130,10 +1130,6 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) 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. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust @@ -1169,26 +1165,11 @@ subroutine trim_for_ice(PF, G, GV, US, ALE_CSp, tv, h, just_read) call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", & - default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", & + "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) else @@ -2505,17 +2486,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just logical :: homogenize, useALEremapping, remap_full_column, remap_general, remap_old_alg integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. - logical :: hor_regrid_answers_2018 - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use ! for horizontal regridding. Values below 20190101 recover the ! answers from 2018, while higher values use expressions that have @@ -2596,55 +2570,26 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) call get_param(PF, mdl, "TEMP_SALT_INIT_VERTICAL_REMAP_ONLY", pre_gridded, & "If true, initial conditions are on the model horizontal grid. " //& "Extrapolation over missing ocean values is done using an ICE-9 "//& "procedure with vertical ALE remapping .", & default=.false., do_not_log=just_read) if (useALEremapping) then - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", & - default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 - endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", & - default=default_remap_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif - call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", & - default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (GV%Boussinesq) then - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 - endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", & - default=default_hor_reg_ans_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=just_read.or.(.not.GV%Boussinesq)) if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (.not.useALEremapping) then diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index decd197b2b..808430df2c 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -87,17 +87,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust ! forms of the same remapping expressions. - logical :: hor_regrid_answers_2018 - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: hor_regrid_answer_date ! The vintage of the order of arithmetic and expressions to use ! for horizontal regridding. Values below 20190101 recover the ! answers from 2018, while higher values use expressions that have @@ -125,46 +118,21 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) if (useALE) then - call get_param(PF, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 - endif call get_param(PF, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) endif - call get_param(PF, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizonal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (GV%Boussinesq) then - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 - endif call get_param(PF, mdl, "HOR_REGRID_ANSWER_DATE", hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) hor_regrid_answer_date = max(hor_regrid_answer_date, 20230701) if (PRESENT(homogenize)) homog=homogenize diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index fc67b20e87..875051b6c7 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -182,11 +182,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) character(len=80) :: basin_var character(len=80) :: remap_scheme character(len=80) :: bias_correction_file, inc_file - logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. 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. if (associated(CS)) call MOM_error(FATAL, 'Calling oda_init with associated control structure') allocate(CS) @@ -253,25 +249,11 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) call get_param(PF, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(PF, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(PF, mdl, "ODA_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from original version of the ODA driver. Otherwise, use updated and "//& - "more robust forms of the same expressions.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(PF, mdl, "ODA_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions used by the ODA driver "//& "Values below 20190101 recover the answers from the end of 2018, while higher "//& - "values use updated and more robust forms of the same expressions. "//& - "If both ODA_2018_ANSWERS and ODA_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) inputdir = slasher(inputdir) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index f9a35c1e3d..2d1c38abf9 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -1758,11 +1758,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) logical :: split ! If true, use the split time stepping scheme. ! If false and USE_GME = True, issue a FATAL error. logical :: use_MEKE ! If true, the MEKE parameterization is in use. - logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. 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 character(len=200) :: inputdir, filename ! Input file names and paths character(len=80) :: Kh_var ! Input variable names real :: deg2rad ! Converts degrees to radians [radians degree-1] @@ -1793,24 +1789,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "HOR_VISC_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal viscosity. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "HOR_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the horizontal "//& "viscosity calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions. If both HOR_VISC_2018_ANSWERS and HOR_VISC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index d3ee675269..1bf416b00a 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -1110,8 +1110,6 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) ! default value is roughly (pi / (the age of the universe)). logical :: Gill_equatorial_Ld, use_FGNV_streamfn, use_MEKE, in_use integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 integer :: remap_answer_date ! The vintage of the order of arithmetic and expressions to use ! for remapping. Values below 20190101 recover the remapping ! answers from 2018, while higher values use more robust @@ -1505,25 +1503,12 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) call get_param(param_file, mdl, "INTERNAL_WAVE_SPEED_TOL", wave_speed_tol, & diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 1de4c9ba6b..248a90d76a 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -2090,10 +2090,6 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) real :: Stanley_coeff ! Coefficient relating the temperature gradient and sub-gridscale ! temperature variance [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 :: MEKE_GEOM_answers_2018 ! If true, use expressions in the MEKE_GEOMETRIC calculation - ! that recover the answers from the original implementation. - ! Otherwise, use expressions that satisfy rotational symmetry. integer :: i, j CS%initialized = .true. @@ -2246,24 +2242,10 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "MEKE_GEOMETRIC_2018_ANSWERS", MEKE_GEOM_answers_2018, & - "If true, use expressions in the MEKE_GEOMETRIC calculation that recover the "//& - "answers from the original implementation. Otherwise, use expressions that "//& - "satisfy rotational symmetry.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for MEKE_geometric. - if (GV%Boussinesq) then - if (MEKE_GEOM_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.MEKE_GEOM_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& "Values below 20190101 recover the answers from the original implementation, "//& - "while higher values use expressions that satisfy rotational symmetry. "//& - "If both MEKE_GEOMETRIC_2018_ANSWERS and MEKE_GEOMETRIC_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "while higher values use expressions that satisfy rotational symmetry.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%MEKE_GEOM_answer_date = max(CS%MEKE_GEOM_answer_date, 20230701) endif diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 1faeed00ba..508362c4cc 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -180,15 +180,6 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date - logical :: hor_regrid_answers_2018 ! If true, use the order of arithmetic for horizontal regridding - ! that recovers the answers from the end of 2018. Otherwise, use - ! rotationally symmetric forms of the same expressions. - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -226,45 +217,20 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - endif - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) - call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018. Otherwise, use rotationally symmetric "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (GV%Boussinesq) then - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 - endif call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date, do_not_log=.not.GV%Boussinesq) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%hor_regrid_answer_date = max(CS%hor_regrid_answer_date, 20230701) CS%time_varying_sponges = .false. @@ -477,15 +443,6 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest logical :: use_sponge logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date - logical :: hor_regrid_answers_2018 ! If true, use the order of arithmetic for horizontal regridding - ! that recovers the answers from the end of 2018. Otherwise, use - ! rotationally symmetric forms of the same expressions. - integer :: default_hor_reg_ans_date ! The default setting for hor_regrid_answer_date integer :: i, j, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v if (associated(CS)) then @@ -522,41 +479,18 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date) - call get_param(param_file, mdl, "HOR_REGRID_2018_ANSWERS", hor_regrid_answers_2018, & - "If true, use the order of arithmetic for horizontal regridding that recovers "//& - "the answers from the end of 2018 and retain a bug in the 3-dimensional mask "//& - "returned in certain cases. Otherwise, use rotationally symmetric "//& - "forms of the same expressions and initialize the mask properly.", & - default=default_2018_answers) - ! Revise inconsistent default answer dates for horizontal regridding. - default_hor_reg_ans_date = default_answer_date - if (hor_regrid_answers_2018 .and. (default_hor_reg_ans_date >= 20190101)) default_hor_reg_ans_date = 20181231 - if (.not.hor_regrid_answers_2018 .and. (default_hor_reg_ans_date < 20190101)) default_hor_reg_ans_date = 20190101 + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date) call get_param(param_file, mdl, "HOR_REGRID_ANSWER_DATE", CS%hor_regrid_answer_date, & "The vintage of the order of arithmetic for horizontal regridding. "//& "Dates before 20190101 give the same answers as the code did in late 2018, "//& "while later versions add parentheses for rotational symmetry. "//& - "Dates after 20230101 use reproducing sums for global averages. "//& - "If both HOR_REGRID_2018_ANSWERS and HOR_REGRID_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_hor_reg_ans_date) + "Dates after 20230101 use reproducing sums for global averages.", & + default=default_answer_date) call get_param(param_file, mdl, "SPONGE_DATA_ONGRID", CS%spongeDataOngrid, & "When defined, the incoming sponge data are "//& "assumed to be on the model grid " , & diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 06c3915d84..17da7aceb3 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -1962,10 +1962,6 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) integer :: isd, ied, jsd, jed integer :: mstar_mode, LT_enhance, wT_mode 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 the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. logical :: use_temperature, use_omega logical :: use_la_windsea isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -2006,24 +2002,11 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "EPBL_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for horizontal viscosity. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "EPBL_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the energetic "//& "PBL calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions. If both EPBL_2018_ANSWERS and EPBL_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index ac93e54785..c48308a912 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -962,11 +962,7 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) real :: PenSW_absorb_minthick ! A thickness that is used to absorb the remaining shortwave heat ! flux when that flux drops below PEN_SW_FLUX_ABSORB [H ~> m or kg m-2] real :: PenSW_minthick_dflt ! The default for PenSW_absorb_minthick [m] - logical :: answers_2018 ! If true, use the order of arithmetic and expressions that recover the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. 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 integer :: isd, ied, jsd, jed, nz, n isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -1067,25 +1063,10 @@ subroutine opacity_init(Time, G, GV, US, param_file, diag, CS, optics) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "OPTICS_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated expressions for "//& - "handling the absorption of small remaining shortwave fluxes.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for optics. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "OPTICS_ANSWER_DATE", optics%answer_date, & "The vintage of the order of arithmetic and expressions in the optics calculations. "//& "Values below 20190101 recover the answers from the end of 2018, while "//& - "higher values use updated and more robust forms of the same expressions. "//& - "If both OPTICS_2018_ANSWERS and OPTICS_ANSWER_DATE are "//& - "specified, the latter takes precedence.", & + "higher values use updated and more robust forms of the same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) optics%answer_date = max(optics%answer_date, 20230701) diff --git a/src/parameterizations/vertical/MOM_regularize_layers.F90 b/src/parameterizations/vertical/MOM_regularize_layers.F90 index d4034d699c..b00238f60c 100644 --- a/src/parameterizations/vertical/MOM_regularize_layers.F90 +++ b/src/parameterizations/vertical/MOM_regularize_layers.F90 @@ -719,10 +719,6 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) # include "version_variable.h" character(len=40) :: mdl = "MOM_regularize_layers" ! This module's name. 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 the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. logical :: just_read integer :: isd, ied, jsd, jed isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -760,24 +756,11 @@ subroutine regularize_layers_init(Time, G, GV, param_file, diag, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231, do_not_log=just_read) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=just_read.or.(.not.GV%Boussinesq)) - call get_param(param_file, mdl, "REGULARIZE_LAYERS_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use updated and more robust forms of the "//& - "same expressions.", default=default_2018_answers, do_not_log=just_read.or.(.not.GV%Boussinesq)) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "REGULARIZE_LAYERS_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the regularize "//& "layers calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions. If both REGULARIZE_LAYERS_2018_ANSWERS and "//& - "REGULARIZE_LAYERS_ANSWER_DATE are specified, the latter takes precedence.", & + "same expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) endif diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index c792f5200e..c404e94459 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2067,10 +2067,6 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ real :: decay_length ! The maximum decay scale for the BBL diffusion [H ~> m or kg m-2] logical :: ML_use_omega 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 the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_set_diffusivity" ! This module's name. @@ -2124,24 +2120,11 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "SET_DIFF_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "SET_DIFF_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set diffusivity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions. "//& - "If both SET_DIFF_2018_ANSWERS and SET_DIFF_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) ! CS%use_tidal_mixing is set to True if an internal tidal dissipation scheme is to be used. diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 9a99bc6b26..a6c463a7b9 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2233,10 +2233,6 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS 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. - 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 the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. logical :: adiabatic, use_omega, MLE_use_PBL_MLD logical :: use_KPP logical :: use_regridding ! If true, use the ALE algorithm rather than layered @@ -2266,24 +2262,11 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "SET_VISC_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "SET_VISC_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the set viscosity "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions. "//& - "If both SET_VISC_2018_ANSWERS and SET_VISC_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "BOTTOMDRAGLAW", CS%bottomdraglaw, & "If true, the bottom stress is calculated with a drag "//& diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 95ffe19afb..6e53679549 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -230,15 +230,6 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di logical :: int_tide_dissipation logical :: read_tideamp integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the remapping answers from 2018. If false, use more - ! robust forms of the same remapping expressions. - integer :: default_remap_ans_date ! The default setting for remap_answer_date - integer :: default_tide_ans_date ! The default setting for tides_answer_date - logical :: tide_answers_2018 ! If true, use the order of arithmetic and expressions that recover the - ! answers from the end of 2018. Otherwise, use updated and more robust - ! forms of the same expressions. character(len=20) :: tmpstr, int_tide_profile_str character(len=20) :: CVMix_tidal_scheme_str, tidal_energy_type character(len=200) :: filename, h2_file, Niku_TKE_input_file ! Input file names @@ -295,44 +286,19 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "TIDAL_MIXING_2018_ANSWERS", tide_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for the tidal mixing. - default_tide_ans_date = default_answer_date - if (GV%Boussinesq) then - if (tide_answers_2018 .and. (default_tide_ans_date >= 20190101)) default_tide_ans_date = 20181231 - if (.not.tide_answers_2018 .and. (default_tide_ans_date < 20190101)) default_tide_ans_date = 20190101 - endif call get_param(param_file, mdl, "TIDAL_MIXING_ANSWER_DATE", CS%tidal_answer_date, & "The vintage of the order of arithmetic and expressions in the tidal mixing "//& "calculations. Values below 20190101 recover the answers from the end of 2018, "//& - "while higher values use updated and more robust forms of the same expressions. "//& - "If both TIDAL_MIXING_2018_ANSWERS and TIDAL_MIXING_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_tide_ans_date, do_not_log=.not.GV%Boussinesq) + "while higher values use updated and more robust forms of the same expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%tidal_answer_date = max(CS%tidal_answer_date, 20230701) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - default_remap_ans_date = default_answer_date - if (GV%Boussinesq) then - if (remap_answers_2018 .and. (default_remap_ans_date >= 20190101)) default_remap_ans_date = 20181231 - if (.not.remap_answers_2018 .and. (default_remap_ans_date < 20190101)) default_remap_ans_date = 20190101 - endif call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_remap_ans_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) if (CS%int_tide_dissipation) then diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index b0b47bf2b1..212512dabf 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2247,11 +2247,6 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & real :: Kv_BBL ! A viscosity in the bottom boundary layer with a simple scheme [H Z T-1 ~> m2 s-1 or Pa s] real :: Kv_back_z ! A background kinematic viscosity [Z2 T-1 ~> m2 s-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 the - !! answers from the end of 2018. Otherwise, use expressions that do not - !! use an arbitrary and hard-coded maximum viscous coupling coefficient - !! between layers. integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, nz character(len=200) :: kappa_gl90_file, inputdir, kdgl90_varname ! This include declares and sets the variable "version". @@ -2282,28 +2277,13 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "VERT_FRICTION_2018_ANSWERS", answers_2018, & - "If true, use the order of arithmetic and expressions that recover the answers "//& - "from the end of 2018. Otherwise, use expressions that do not use an arbitrary "//& - "hard-coded maximum viscous coupling coefficient between layers.", & - default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates. - if (GV%Boussinesq) then - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 - endif call get_param(param_file, mdl, "VERT_FRICTION_ANSWER_DATE", CS%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 hard-coded "//& "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.", & + "magnitude of the wind stress in some non-Boussinesq cases.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 21201db590..720e0012b0 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -129,10 +129,6 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, ! Local variables character(len=80) :: string ! Temporary strings integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. - logical :: default_2018_answers ! The default setting for the various 2018_ANSWERS flags. - logical :: remap_answers_2018 ! If true, use the order of arithmetic and expressions that - ! recover the answers for remapping from the end of 2018. - ! Otherwise, use more robust forms of the same expressions. logical :: boundary_extrap if (associated(CS)) then @@ -191,23 +187,12 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101), do_not_log=.not.GV%Boussinesq) - call get_param(param_file, mdl, "REMAPPING_2018_ANSWERS", remap_answers_2018, & - "If true, use the order of arithmetic and expressions that recover the "//& - "answers from the end of 2018. Otherwise, use updated and more robust "//& - "forms of the same expressions.", default=default_2018_answers, do_not_log=.not.GV%Boussinesq) - ! Revise inconsistent default answer dates for remapping. - if (remap_answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.remap_answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "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. "//& - "If both REMAPPING_2018_ANSWERS and REMAPPING_ANSWER_DATE are specified, the "//& - "latter takes precedence.", default=default_answer_date, do_not_log=.not.GV%Boussinesq) + "robust and accurate forms of mathematically equivalent expressions.", & + default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%remap_answer_date = max(CS%remap_answer_date, 20230701) call initialize_remapping( CS%remap_CS, string, boundary_extrapolation=boundary_extrap, & answer_date=CS%remap_answer_date ) diff --git a/src/user/Idealized_Hurricane.F90 b/src/user/Idealized_Hurricane.F90 index 5dd8084fbd..0c9d5cd330 100644 --- a/src/user/Idealized_Hurricane.F90 +++ b/src/user/Idealized_Hurricane.F90 @@ -104,10 +104,6 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) real :: dP ! The pressure difference across the hurricane [R L2 T-2 ~> Pa] 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 - ! case that recover the answers from the end of 2018. Otherwise use - ! expressions that are rescalable and respect rotational symmetry. ! This include declares and sets the variable "version". # include "version_variable.h" @@ -174,23 +170,11 @@ subroutine idealized_hurricane_wind_init(Time, G, US, param_file, CS) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) - call get_param(param_file, mdl, "DEFAULT_2018_ANSWERS", default_2018_answers, & - "This sets the default value for the various _2018_ANSWERS parameters.", & - default=(default_answer_date<20190101)) - call get_param(param_file, mdl, "IDL_HURR_2018_ANSWERS", answers_2018, & - "If true, use expressions driving the idealized hurricane test case that recover "//& - "the answers from the end of 2018. Otherwise use expressions that are rescalable "//& - "and respect rotational symmetry.", default=default_2018_answers) - - ! Revise inconsistent default answer dates. - if (answers_2018 .and. (default_answer_date >= 20190101)) default_answer_date = 20181231 - if (.not.answers_2018 .and. (default_answer_date < 20190101)) default_answer_date = 20190101 call get_param(param_file, mdl, "IDL_HURR_ANSWER_DATE", CS%answer_date, & "The vintage of the expressions in the idealized hurricane test case. "//& "Values below 20190101 recover the answers from the end of 2018, while higher "//& - "values use expressions that are rescalable and respect rotational symmetry. "//& - "If both IDL_HURR_2018_ANSWERS and IDL_HURR_ANSWER_DATE are specified, "//& - "the latter takes precedence.", default=default_answer_date) + "values use expressions that are rescalable and respect rotational symmetry.", & + default=default_answer_date) ! The following parameters are model run-time parameters which are used ! and logged elsewhere and so should not be logged here. The default From 9f7f86d304d664e5a7ed63271cfb8ef32644d876 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 29 Aug 2023 10:37:01 -0400 Subject: [PATCH 405/629] Autoconf: Update deps m4 macros This patch updates the macros used in the `ac/deps` directory. It includes a bugfix in the library testing, and also bundles the macro for testing Fortran links to C libraries. Both of these macros were already in `ac/m4` but unused by `ac/deps`. No problems were observed in any recent FMS builds, although in principle they could have been affected by these errors. The issues were only detected when the macros were used in an unrelated project (LM3 land model). These issues are due to code duplication in `ac/m4` and `ac/deps/m4`. This separation was intended to draw a clear logical separation between MOM6 and its FMS dependency, and only provide what is required by each respective build. But perhaps there are some flaws in this thinking, and may warrant further discussion. --- ac/deps/m4/ax_fc_check_c_lib.m4 | 45 +++++++++++++++++++++++++++++++++ ac/deps/m4/ax_fc_check_lib.m4 | 13 +++++----- 2 files changed, 52 insertions(+), 6 deletions(-) create mode 100644 ac/deps/m4/ax_fc_check_c_lib.m4 diff --git a/ac/deps/m4/ax_fc_check_c_lib.m4 b/ac/deps/m4/ax_fc_check_c_lib.m4 new file mode 100644 index 0000000000..af5765282a --- /dev/null +++ b/ac/deps/m4/ax_fc_check_c_lib.m4 @@ -0,0 +1,45 @@ +dnl AX_FC_CHECK_C_LIB(LIBRARY, FUNCTION, +dnl [ACTION-IF-FOUND], [ACTION-IF-NOT-FOUND], +dnl [OTHER-LDFLAGS], [OTHER-LIBS]) +dnl +dnl This macro checks if a C library can be referenced by a Fortran compiler. +dnl +dnl Results are cached in `ax_fc_cv_c_lib_LIBRARY_FUNCTION`. +dnl +dnl NOTE: Might be possible to rewrite this to use `AX_FC_CHECK_BIND_C`. +dnl +AC_DEFUN([AX_FC_CHECK_C_LIB], [ + AS_VAR_PUSHDEF([ax_fc_C_Lib], [ax_fc_cv_c_lib_$1_$2]) + m4_ifval([$5], + [ax_fc_c_lib_msg_LDFLAGS=" with $5"], + [ax_fc_c_lib_msg_LDFLAGS=""] + ) + AC_CACHE_CHECK( + [for $2 in -l$1$ax_fc_c_lib_msg_LDFLAGS], [ax_fc_cv_c_lib_$1_$2], [ + ax_fc_check_c_lib_save_LDFLAGS=$LDFLAGS + LDFLAGS="$6 $LDFLAGS" + ax_fc_check_c_lib_save_LIBS=$LIBS + LIBS="-l$1 $7 $LIBS" + AC_LINK_IFELSE( + [AC_LANG_PROGRAM([],[dnl +dnl begin code block + interface + subroutine test() bind(c, name="$2") + end subroutine test + end interface + call test]) +dnl end code block + ], + [AS_VAR_SET([ax_fc_C_Lib], [yes])], + [AS_VAR_SET([ax_fc_C_Lib], [no])] + ) + LDFLAGS=$ax_fc_check_c_lib_save_LDFLAGS + LIBS=$ax_fc_check_c_lib_save_LIBS + ] + ) + AS_VAR_IF([ax_fc_C_Lib], [yes], + [m4_default([$3], [LIBS="-l$1 $LIBS"])], + [$4] + ) + AS_VAR_POPDEF([ax_fc_C_Lib]) +]) diff --git a/ac/deps/m4/ax_fc_check_lib.m4 b/ac/deps/m4/ax_fc_check_lib.m4 index c0accab6cd..a7f848cd60 100644 --- a/ac/deps/m4/ax_fc_check_lib.m4 +++ b/ac/deps/m4/ax_fc_check_lib.m4 @@ -18,7 +18,7 @@ dnl library with different -L flags, or perhaps other ld configurations. dnl dnl Results are cached in the ax_fc_cv_lib_LIBRARY_FUNCTION variable. dnl -AC_DEFUN([AX_FC_CHECK_LIB],[dnl +AC_DEFUN([AX_FC_CHECK_LIB],[ AS_VAR_PUSHDEF([ax_fc_Lib], [ax_fc_cv_lib_$1_$2]) m4_ifval([$6], [ax_fc_lib_msg_LDFLAGS=" with $6"], @@ -29,14 +29,15 @@ AC_DEFUN([AX_FC_CHECK_LIB],[dnl LDFLAGS="$6 $LDFLAGS" ax_fc_check_lib_save_LIBS=$LIBS LIBS="-l$1 $7 $LIBS" - AS_IF([test -n $3], + AS_IF([test -n "$3"], [ax_fc_use_mod="use $3"], [ax_fc_use_mod=""]) - AC_LINK_IFELSE([ - AC_LANG_PROGRAM([], [dnl + AC_LINK_IFELSE([dnl +dnl Begin 7-column code block +AC_LANG_PROGRAM([], [dnl $ax_fc_use_mod - call $2]dnl - ) + call $2])dnl +dnl End code block ], [AS_VAR_SET([ax_fc_Lib], [yes])], [AS_VAR_SET([ax_fc_Lib], [no])] From 7b7052e9b691468e650686d9ba38dade5c5b4ed5 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 6 Sep 2023 13:55:23 -0600 Subject: [PATCH 406/629] Describe local variables and make code consistent --- .../vertical/MOM_vert_friction.F90 | 169 ++++++++---------- 1 file changed, 75 insertions(+), 94 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 5a62e835f8..eab2f2d29d 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -166,7 +166,7 @@ module MOM_vert_friction integer :: id_au_vv = -1, id_av_vv = -1, id_au_gl90_vv = -1, id_av_gl90_vv = -1 integer :: id_du_dt_str = -1, id_dv_dt_str = -1 integer :: id_h_u = -1, id_h_v = -1, id_hML_u = -1 , id_hML_v = -1 - integer :: id_FPdiag_u = -1, id_FPdiag_v = -1 , id_FPw2x = -1 !W id_FPhbl_u = -1, id_FPhbl_v = -1 + integer :: id_FPw2x = -1 !W id_FPhbl_u = -1, id_FPhbl_v = -1 integer :: id_tauFP_u = -1, id_tauFP_v = -1 !W, id_FPtau2x_u = -1, id_FPtau2x_v = -1 integer :: id_FPtau2s_u = -1, id_FPtau2s_v = -1, id_FPtau2w_u = -1, id_FPtau2w_v = -1 integer :: id_taux_bot = -1, id_tauy_bot = -1 @@ -210,47 +210,40 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure ! local variables - ! WGL; TODO: add description to local variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: FPdiag_u !< this is for ... - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: FPdiag_v - real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u - real, dimension(SZI_(G),SZJB_(G)) :: hbl_v - integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u - integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v - real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u - real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v - real, dimension(SZIB_(G),SZJ_(G)) :: taux_u - real, dimension(SZI_(G),SZJB_(G)) :: tauy_v - real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u - real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v - - ! GMM; TODO: make arrays allocatable if possible - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v - - real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp, omega_tmp - real :: du, dv, depth, sigma, Wind_x, Wind_y - real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh - real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG - real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w - integer :: kblmin, kbld, kp1 - integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth at u-pts [H ~> m] + real, dimension(SZI_(G),SZJB_(G)) :: hbl_v !< boundary layer depth at v-pts [H ~> m] + integer, dimension(SZIB_(G),SZJ_(G)) :: kbl_u !< index of the BLD at u-pts [nondim] + integer, dimension(SZI_(G),SZJB_(G)) :: kbl_v !< index of the BLD at v-pts [nondim] + real, dimension(SZIB_(G),SZJ_(G)) :: ustar2_u !< ustar squared at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v !< ustar squared at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< zonal wind stress at u-pts [R L Z T-2 ~> Pa] + real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< meridional wind stress at v-pts [R L Z T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u !< angle between wind and x-axis at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v !< angle between wind and y-axis at v-pts [rad] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !< kinematic zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v !< kinematic mer. mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u !< downgradient zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauyDG_u !< downgradient meri mtm flux at u-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauxDG_v !< downgradient zonal mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tauyDG_v !< downgradient meri mtm flux at v-pts [L2 T-2 ~> m2 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2s_u !< angle between mtm flux and vert shear at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2s_v !< angle between mtm flux and vert shear at v-pts [rad] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u !< angle between mtm flux and wind at u-pts [rad] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v !< angle between mtm flux and wind at v-pts [rad] + + real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp, omega_tmp !< constants and dummy variables + real :: du, dv, depth, sigma, Wind_x, Wind_y !< intermediate variables + real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh !< intermediate variables + real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables + real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles + integer :: kblmin, kbld, kp1, k, nz !< vertical indices + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq ! horizontal indices is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke pi = 4. * atan2(1.,1.) Cemp_CG = 3.6 kblmin = 1 - FPdiag_u(:,:,:) = 0.0 - FPdiag_v(:,:,:) = 0.0 taux_u(:,:) = 0. tauy_v(:,:) = 0. @@ -292,7 +285,7 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US depth = 0.0 do k = 1, nz depth = depth + CS%h_u(I,j,k) - if( (depth .ge. hbl_u(I,j)) .and. (kbl_u(I,j) .eq. 0 ) .and. (k > (kblmin-1)) ) then + if( (depth >= hbl_u(I,j)) .and. (kbl_u(I,j) == 0 ) .and. (k > (kblmin-1)) ) then kbl_u(I,j) = k hbl_u(I,j) = depth endif @@ -303,18 +296,18 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US do J = Jsq,Jeq do i = is,ie if( (G%mask2dCv(i,J) > 0.5) ) then - tmp = MAX ( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1) ) ) - hbl_v(i,J) = (G%mask2dT(i,j)* hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) /tmp - tmp = MAX(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1) ) ) - taux = ( G%mask2dCu(i ,j )*taux_u(i ,j ) + G%mask2dCu(i ,j+1)*taux_u(i ,j+1) & - + G%mask2dCu(i-1,j )*taux_u(i-1,j ) + G%mask2dCu(i-1,j+1)*taux_u(i-1,j+1) ) / tmp - ustar2_v(i,J) = sqrt( tauy_v(i,J)*tauy_v(i,J) + taux*taux ) - omega_w2x_v(i,J) = atan2( tauy_v(i,J) , taux ) + tmp = max( 1.0 ,(G%mask2dT(i,j) + G%mask2dT(i,j+1))) + hbl_v(i,J) = (G%mask2dT(i,j) * hbl_h(i,J) + G%mask2dT(i,j+1) * hbl_h(i,j+1)) /tmp + tmp = max(1.0, (G%mask2dCu(i,j) + G%mask2dCu(i,j+1) + G%mask2dCu(i-1,j) + G%mask2dCu(i-1,j+1))) + taux = ( G%mask2dCu(i ,j) * taux_u(i ,j) + G%mask2dCu(i ,j+1) * taux_u(i ,j+1) & + + G%mask2dCu(i-1,j) * taux_u(i-1,j) + G%mask2dCu(i-1,j+1) * taux_u(i-1,j+1)) / tmp + ustar2_v(i,J) = sqrt(tauy_v(i,J)*tauy_v(i,J) + taux*taux) + omega_w2x_v(i,J) = atan2( tauy_v(i,J), taux ) tauyDG_v(i,J,1) = tauy_v(i,J) depth = 0.0 do k = 1, nz depth = depth + CS%h_v(i,J,k) - if( (depth .ge. hbl_v(i,J)) .and. (kbl_v(i,J) .eq. 0 ) .and. (k > (kblmin-1)) ) then + if( (depth >= hbl_v(i,J)) .and. (kbl_v(i,J) == 0) .and. (k > (kblmin-1))) then kbl_v(i,J) = k hbl_v(i,J) = depth endif @@ -331,7 +324,7 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US ! Compute downgradient stresses do k = 1, nz - kp1 = MIN( k+1 , nz) + kp1 = min( k+1 , nz) do j = js ,je do I = Isq , Ieq tauxDG_u(I,j,k+1) = CS%a_u(I,j,kp1) * (ui(I,j,k) - ui(I,j,kp1)) @@ -376,7 +369,7 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US tau_u(:,:,:) = 0.0 tau_v(:,:,:) = 0.0 - !w Default implicit (I) stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] Profiles + ! stress magnitude tau_[uv] & direction Omega_tau2(w,s,x)_[uv] do j = js,je do I = Isq,Ieq if( (G%mask2dCu(I,j) > 0.5) ) then @@ -386,7 +379,6 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US Omega_tau2w_u(I,j,1) = 0.0 Omega_tau2s_u(I,j,1) = 0.0 - ! WGL; TODO: can we use set_v_at_u to get tauyDG_u? do k=1,nz kp1 = MIN(k+1 , nz) tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) @@ -409,7 +401,6 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US Omega_tau2w_v(i,J,1) = 0.0 Omega_tau2s_v(i,J,1) = 0.0 - ! WGL; TODO: can we use set_u_at_v to get tauxDG_v? do k=1,nz-1 kp1 = MIN(k+1 , nz) tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) @@ -429,9 +420,8 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US do j = js,je do I = Isq,Ieq if( (G%mask2dCu(I,j) > 0.5) ) then - kbld = MIN( (kbl_u(I,j)) , (nz-2) ) + kbld = min( (kbl_u(I,j)) , (nz-2) ) if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 - !w if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff ! surface boundary conditions @@ -439,7 +429,7 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US tauNLup = 0.0 do k=1, kbld depth = depth + CS%h_u(I,j,k) - sigma = MIN ( 1.0 , depth / hbl_u(i,j) ) + sigma = min( 1.0 , depth / hbl_u(i,j) ) ! linear stress mag tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) @@ -449,32 +439,31 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US ! rotate to wind coordinates Wind_x = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) Wind_y = ustar2_u(I,j) * sin(omega_w2x_u(I,j)) - tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) - tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) - omega_w2s = atan2( tauNL_CG , tauNL_DG ) + tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) + tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) + omega_w2s = atan2(tauNL_CG, tauNL_DG) omega_s2w = 0.0-omega_w2s tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG - tau_MAG = MAX( tau_MAG , tauNL_CG ) - tauNL_DG = sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) - tau_u(I,j,k+1) + tau_MAG = max(tau_MAG, tauNL_CG) + tauNL_DG = sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) - tau_u(I,j,k+1) ! back to x,y coordinates - tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) - tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) - tauNLdn = tauNL_X + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) + tauNLdn = tauNL_X ! nonlocal increment and update to uold - du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) + du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) ui(I,j,k) = uold(I,j,k) + du uold(I,j,k) = du - tauNLup = tauNLdn + tauNLup = tauNLdn ! diagnostics - FPdiag_u(I,j,k+1) = tauNL_CG / (tau_MAG + GV%H_subroundoff) - Omega_tau2s_u(I,j,k+1) = atan2( tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG) ) - tau_u(I,j,k+1) = sqrt( (tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2 ) - omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y) , (tauxDG_u(I,j,k+1) + tauNL_X) ) + Omega_tau2s_u(I,j,k+1) = atan2(tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG)) + tau_u(I,j,k+1) = sqrt((tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2) + omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y), (tauxDG_u(I,j,k+1) + tauNL_X)) omega_tau2w = omega_tau2x - omega_w2x_u(I,j) - if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi if (omega_tau2w <= (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi Omega_tau2w_u(I,j,k+1) = omega_tau2w enddo @@ -490,8 +479,8 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US do J = Jsq,Jeq do i = is,ie if( (G%mask2dCv(i,J) > 0.5) ) then - kbld = MIN( (kbl_v(i,J)) , (nz-2) ) - if ( tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1) ) kbld = kbld + 1 + kbld = min((kbl_v(i,J)), (nz-2)) + if (tau_v(i,J,kbld+2) > tau_v(i,J,kbld+1)) kbld = kbld + 1 tauh = tau_v(i,J,kbld+1) !surface boundary conditions @@ -499,27 +488,27 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US tauNLup = 0.0 do k=1, kbld depth = depth + CS%h_v(i,J,k) - sigma = MIN ( 1.0 , (depth ) / hbl_v(I,J) ) + sigma = min(1.0, depth/ hbl_v(I,J)) ! linear stress - tau_MAG = (ustar2_v(i,J) * (1.-sigma) ) + (tauh * sigma ) + tau_MAG = (ustar2_v(i,J) * (1.-sigma)) + (tauh * sigma) cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) ! rotate into wind coordinate Wind_x = ustar2_v(i,J) * cos(omega_w2x_v(i,J)) Wind_y = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) - tauNL_DG = ( Wind_x *cos_tmp + Wind_y *sin_tmp ) - tauNL_CG = ( Wind_y *cos_tmp - Wind_x *sin_tmp ) - omega_w2s = atan2( tauNL_CG , tauNL_DG ) + tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) + tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) + omega_w2s = atan2(tauNL_CG , tauNL_DG) omega_s2w = 0.0 - omega_w2s tauNL_CG = Cemp_CG * G_sig(sigma) * tauNL_CG - tau_MAG = MAX( tau_MAG , tauNL_CG ) - tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt( tau_MAG*tau_MAG - tauNL_CG*tauNL_CG ) + tau_MAG = max( tau_MAG , tauNL_CG ) + tauNL_DG = 0.0 - tau_v(i,J,k+1) + sqrt(tau_MAG*tau_MAG - tauNL_CG*tauNL_CG) ! back to x,y coordinate - tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp ) - tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp ) + tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) + tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) tauNLdn = tauNL_Y dv = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) vi(i,J,k) = vold(i,J,k) + dv @@ -527,12 +516,11 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US tauNLup = tauNLdn ! diagnostics - FPdiag_v(i,j,k+1) = tau_MAG / tau_v(i,J,k+1) - Omega_tau2s_v(i,J,k+1) = atan2( tauNL_CG , tau_v(i,J,k+1) + tauNL_DG ) - tau_v(i,J,k+1) = sqrt( (tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2 ) - omega_tau2x = atan2( (tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X) ) + Omega_tau2s_v(i,J,k+1) = atan2(tauNL_CG, tau_v(i,J,k+1) + tauNL_DG) + tau_v(i,J,k+1) = sqrt((tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2) + omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X)) omega_tau2w = omega_tau2x - omega_w2x_v(i,J) - if (omega_tau2w .gt. pi ) omega_tau2w = omega_tau2w - 2.*pi + if (omega_tau2w > pi) omega_tau2w = omega_tau2w - 2.*pi if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi Omega_tau2w_v(i,J,k+1) = omega_tau2w enddo @@ -549,17 +537,14 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) endif - ! GMM; TODO: can you make the arrays used below allocatable? if(L_diag) then - if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) - if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) + if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) + if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) - if (CS%id_FPdiag_u > 0) call post_data(CS%id_FPdiag_u, FPdiag_u, CS%diag) - if (CS%id_FPdiag_v > 0) call post_data(CS%id_FPdiag_v, FPdiag_v, CS%diag) - if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) + if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) endif end subroutine vertFPmix @@ -576,7 +561,7 @@ real function G_sig(sigma) ! cubic function c2 = 1.74392 c3 = 2.58538 - G_sig = MIN ( p1 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (c2*sigma - c3) ) ) + G_sig = min( p1 * (1.-sigma)*(1.-sigma) , sigma * (1. + sigma * (c2*sigma - c3) ) ) end function G_sig !> Compute coupling coefficient associated with vertical viscosity parameterization as in Greatbatch and Lamb @@ -2875,10 +2860,6 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & CS%id_FPw2x = register_diag_field('ocean_model', 'FPw2x', diag%axesT1, Time, & 'Wind direction from x-axis','radians') - CS%id_FPdiag_u = register_diag_field('ocean_model', 'FPdiag_u', diag%axesCui, Time, & - 'FP diagmostic (u-points)','binary') - CS%id_FPdiag_v = register_diag_field('ocean_model', 'FPdiag_v', diag%axesCvi, Time, & - 'FP diagnostic (v-points)','binary') CS%id_tauFP_u = register_diag_field('ocean_model', 'tauFP_u', diag%axesCui, Time, & 'Stress Mag Profile (u-points)', 'm2 s-2') CS%id_tauFP_v = register_diag_field('ocean_model', 'tauFP_v', diag%axesCvi, Time, & From 1577ae1c516ba72d1b0f287666527b6cfcfbbcda Mon Sep 17 00:00:00 2001 From: alex-huth Date: Wed, 23 Aug 2023 15:59:33 -0400 Subject: [PATCH 407/629] Ice-shelf bugfixes for restarts and halo updates This commit fixes a combination of bugs related to halo update errors, improperly-defined iteration bounds, and an unexpected change in ice-shelf bed_elev after a restart. These issues caused crashes during the ice-shelf velocity (SSA) solution, and ice shelf dynamics restarts were not bitwise identical. The issues were resolved with the following changes: -Added bed_elev to the ice shelf restart file (previously, bed_elev was instead calculated incorrectly after a restart). Also fixed the subsequent bed_elev pass_var call, where the halo update was failing due to an error in how an optional argument (CENTER) was passed. -Added additional pass_var/pass_vector calls upon ice shelf restarts to guarantee that all halos are properly filled. -Disabled the additional ice shelf flow solve (ice_shelf_solve_outer) after a restart, which was unnecessary and prevented bitwise identical restarts. -Fixed incorrect bounds for iterations within ice_shelf_solve_inner and for the basis functions in calc_shelf_visc This commit also sets the mol_wt argument to optional in the dummy function aof_set_coupler_flux (from ice_solo_driver/atmost_ocean_fluxes.F90), as that is how it is called from the FMS coupler. This is required for compilation in ice-shelf-only mode. --- .../ice_solo_driver/atmos_ocean_fluxes.F90 | 3 +- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 63 +++++++++++-------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 15 ++--- 3 files changed, 48 insertions(+), 33 deletions(-) diff --git a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 index 5494954398..4a4ddf6da3 100644 --- a/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 +++ b/config_src/drivers/ice_solo_driver/atmos_ocean_fluxes.F90 @@ -13,7 +13,7 @@ module atmos_ocean_fluxes_mod !> This subroutine duplicates an interface used by the FMS coupler, but only !! returns a value of -1. None of the arguments are used for anything. function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, & - param, flag, ice_restart_file, ocean_restart_file, & + param, flag, mol_wt, ice_restart_file, ocean_restart_file, & units, caller, verbosity) result (coupler_index) character(len=*), intent(in) :: name !< An unused argument @@ -22,6 +22,7 @@ function aof_set_coupler_flux(name, flux_type, implementation, atm_tr_index, integer, optional, intent(in) :: atm_tr_index !< An unused argument real, dimension(:), optional, intent(in) :: param !< An unused argument logical, dimension(:), optional, intent(in) :: flag !< An unused argument + real, optional, intent(in) :: mol_wt !< An unused argument character(len=*), optional, intent(in) :: ice_restart_file !< An unused argument character(len=*), optional, intent(in) :: ocean_restart_file !< An unused argument character(len=*), optional, intent(in) :: units !< An unused argument diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 9b584ae0f9..cefe251edd 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -265,23 +265,23 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", T_shelf_missing, & "An ice shelf temperature to use where there is no ice shelf.",& units="degC", default=-10.0, scale=US%degC_to_C, do_not_log=.true.) - allocate( CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing ) ! [C ~> degC] - allocate( CS%ice_visc(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25 ) ! [Pa-3 s-1] - allocate( CS%basal_traction(isd:ied,jsd:jed), source=0.0 ) ! [R L2 T-2 ~> Pa] - allocate( CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10 ) ! [Pa (m-1 s)^n_sliding] - allocate( CS%OD_av(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%ground_frac(isd:ied,jsd:jed), source=0.0 ) - allocate( CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%bed_elev(isd:ied,jsd:jed) ) ; CS%bed_elev(:,:) = G%bathyT(:,:) + G%Z_ref - allocate( CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0 ) - allocate( CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0 ) - allocate( CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0 ) - allocate( CS%h_bdry_val(isd:ied,jsd:jed), source=0.0 ) + allocate(CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] + allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) + allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] + allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] + allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) + allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) + allocate(CS%taudx_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%taudy_shelf(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%bed_elev(isd:ied,jsd:jed), source=0.0) + allocate(CS%u_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%v_bdry_val(IsdB:IedB,JsdB:JedB), source=0.0) + allocate(CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0) + allocate(CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0) + allocate(CS%h_bdry_val(isd:ied,jsd:jed), source=0.0) ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & "ice sheet/shelf u-velocity", & @@ -310,6 +310,8 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) "ice-stiffness parameter", "Pa-3 s-1") call register_restart_field(CS%h_bdry_val, "h_bdry_val", .false., restart_CS, & "ice thickness at the boundary", "m", conversion=US%Z_to_m) + call register_restart_field(CS%bed_elev, "bed elevation", .true., restart_CS, & + "bed elevation", "m", conversion=US%Z_to_m) endif end subroutine register_ice_shelf_dyn_restarts @@ -509,7 +511,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%ice_visc,G%domain) call pass_var(CS%basal_traction, G%domain) call pass_var(CS%AGlen_visc, G%domain) + call pass_var(CS%bed_elev, G%domain) + call pass_var(CS%C_basal_friction, G%domain) + call pass_var(CS%h_bdry_val, G%domain) + call pass_var(CS%thickness_bdry_val, G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif if (active_shelf_dynamics) then @@ -561,7 +571,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & G, US, param_file) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%bed_elev, G%domain,CENTER) + call pass_var(CS%ground_frac, G%domain) + call pass_var(CS%bed_elev, G%domain) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif ! Register diagnostics. @@ -590,8 +601,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) endif call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") - call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) - call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) + if (new_sim) then + call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + endif end subroutine initialize_ice_shelf_dyn @@ -955,7 +967,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_vector(Au,Av,G%domain,TO_ALL,BGRID_NE) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 @@ -1012,6 +1024,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + err_max = 0 if (CS%nonlin_solve_err_mode == 1) then @@ -1225,7 +1239,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! the computational domain - this is their state in the initial iteration - is = isc - cg_halo ; ie = iecq + cg_halo + is = iscq - cg_halo ; ie = iecq + cg_halo js = jscq - cg_halo ; je = jecq + cg_halo Au(:,:) = 0 ; Av(:,:) = 0 @@ -2595,10 +2609,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) -! do j=jsc,jec ; do i=isc,iec - do j=jscq,jecq ; do i=iscq,iecq + do j=jsc,jec ; do i=isc,iec call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index e49fb03aaf..dce6e53982 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -429,31 +429,32 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& filename = trim(inputdir)//trim(vel_file) call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) call get_param(PF, mdl, "ICE_U_VEL_VARNAME", ushelf_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the u velocity variable in ICE_VELOCITY_FILE.", & default="u_shelf") call get_param(PF, mdl, "ICE_V_VEL_VARNAME", vshelf_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the v velocity variable in ICE_VELOCITY_FILE.", & default="v_shelf") call get_param(PF, mdl, "ICE_VISC_VARNAME", ice_visc_varname, & - "The name of the thickness variable in ICE_VELOCITY_FILE.", & + "The name of the ice viscosity variable in ICE_VELOCITY_FILE.", & default="viscosity") + call get_param(PF, mdl, "ICE_FLOAT_FRAC_VARNAME", floatfr_varname, & + "The name of the ice float fraction (grounding fraction) variable in ICE_VELOCITY_FILE.", & + default="float_frac") call get_param(PF, mdl, "BED_TOPO_FILE", bed_topo_file, & "The file from which the bed elevation is read.", & default="ice_shelf_vel.nc") call get_param(PF, mdl, "BED_TOPO_VARNAME", bed_varname, & - "The name of the thickness variable in ICE_INPUT_FILE.", & + "The name of the bed elevation variable in ICE_INPUT_FILE.", & default="depth") if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_shelf_velocity_from_file: Unable to open "//trim(filename)) - floatfr_varname = "float_frac" - call MOM_read_data(filename, trim(ushelf_varname), u_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(vshelf_varname), v_shelf, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(floatfr_varname), float_cond, G%Domain, scale=1.) filename = trim(inputdir)//trim(bed_topo_file) - call MOM_read_data(filename,trim(bed_varname), bed_elev, G%Domain, scale=1.0) + call MOM_read_data(filename, trim(bed_varname), bed_elev, G%Domain, scale=US%m_to_Z) end subroutine initialize_ice_flow_from_file From 66fd876af9f702a1fc4f956ca07474613956e447 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 6 Sep 2023 15:29:57 -0600 Subject: [PATCH 408/629] Removed L_diag and moved variables in vertFPmix --- src/core/MOM_dynamics_split_RK2.F90 | 7 +--- .../vertical/MOM_vert_friction.F90 | 41 +++++++++---------- 2 files changed, 22 insertions(+), 26 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 84c84efe39..df28dc0338 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -384,7 +384,6 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] - logical :: L_diag ! Controls if diagostics are posted in the vertFPmix logical :: dyn_p_surf logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating @@ -696,12 +695,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) if (CS%fpmix) then - L_diag = .false. hbl(:,:) = 0.0 if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) if (ASSOCIATED(CS%energetic_PBL_CSp)) & call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) - call vertFPmix(L_diag, up, vp, uold, vold, hbl, h, forces, & + call vertFPmix(up, vp, uold, vold, hbl, h, forces, & dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) @@ -947,8 +945,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (CS%fpmix) then - L_diag = .true. - call vertFPmix(L_diag, u, v, uold, vold, hbl, h, forces, dt, & + call vertFPmix(u, v, uold, vold, hbl, h, forces, dt, & G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index aa21f8ab89..1169126c1c 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -191,26 +191,26 @@ module MOM_vert_friction contains !> Add nonlocal stress increments to u^n (uold) and v^n (vold) using ui and vi. -subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type +subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] + intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vi !< Meridional velocity after vertvisc [L T-1 ~> m s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: uold !< Old Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: vold !< Old Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: hbl_h !< boundary layer depth [H ~> m] 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) :: hbl_h ! boundary layer depth - logical, intent(in) :: L_diag !< controls if diagnostics should be posted - type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces - real, intent(in) :: dt !< Time increment [T ~> s] - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, intent(in) :: dt !< Time increment [T ~> s] + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure ! local variables real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth at u-pts [H ~> m] @@ -241,6 +241,7 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles integer :: kblmin, kbld, kp1, k, nz !< vertical indices integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq ! horizontal indices + is = G%isc ; ie = G%iec; js = G%jsc; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB ; nz = GV%ke @@ -321,8 +322,8 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US if (CS%debug) then call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=1, scalar_pair=.true.) - call uvchksum("ustar2 ",ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) - call uvchksum(" hbl ", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum("ustar2", ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) + call uvchksum(" hbl", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) endif ! Compute downgradient stresses @@ -540,15 +541,13 @@ subroutine vertFPmix(L_diag, ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US call uvchksum("FP-tau_[uv] ", tau_u, tau_v, G%HI, haloshift=0, scalar_pair=.true.) endif - if(L_diag) then - if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) - if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) - if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) - if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) - if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) - if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) - if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) - endif + if (CS%id_tauFP_u > 0) call post_data(CS%id_tauFP_u, tau_u, CS%diag) + if (CS%id_tauFP_v > 0) call post_data(CS%id_tauFP_v, tau_v, CS%diag) + if (CS%id_FPtau2s_u > 0) call post_data(CS%id_FPtau2s_u, omega_tau2s_u, CS%diag) + if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) + if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) + if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) + if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) end subroutine vertFPmix From d9aa751a46b67c0d496b9baab28549b2fc679c8f Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Wed, 6 Sep 2023 16:12:36 -0600 Subject: [PATCH 409/629] Revert order of variables in vertFPmix --- src/parameterizations/vertical/MOM_vert_friction.F90 | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 1169126c1c..f513f50158 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -192,7 +192,8 @@ module MOM_vert_friction !> Add nonlocal stress increments to u^n (uold) and v^n (vold) using ui and vi. subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OBC) - + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: ui !< Zonal velocity after vertvisc [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -206,11 +207,9 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces real, intent(in) :: dt !< Time increment [T ~> s] - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure + type(vertvisc_CS), pointer :: CS !< Vertical viscosity control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition structure ! local variables real, dimension(SZIB_(G),SZJ_(G)) :: hbl_u !< boundary layer depth at u-pts [H ~> m] From be40a41360b2eaed31ae86582aa57e1cf41241d5 Mon Sep 17 00:00:00 2001 From: Jun Wang <37633869+junwang-noaa@users.noreply.github.com> Date: Thu, 7 Sep 2023 15:02:27 -0400 Subject: [PATCH 410/629] add run time info (#114) * add optional run time info in nuopc cap. Author: Jun Wang --- config_src/drivers/nuopc_cap/mom_cap.F90 | 43 +++++++++++++++++++++--- 1 file changed, 39 insertions(+), 4 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 9db4f03100..71419ea4bf 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -127,6 +127,7 @@ module MOM_cap_mod character(len=256) :: tmpstr logical :: write_diagnostics = .false. logical :: overwrite_timeslice = .false. +logical :: write_runtimelog = .false. character(len=32) :: runtype !< run type logical :: profile_memory = .true. logical :: grid_attach_area = .false. @@ -147,6 +148,7 @@ module MOM_cap_mod type(ESMF_GeomType_Flag) :: geomtype #endif character(len=8) :: restart_mode = 'alarms' +real(8) :: timere contains @@ -230,6 +232,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) integer :: iostat character(len=64) :: value, logmsg character(len=*),parameter :: subname='(MOM_cap:InitializeP0)' + type(ESMF_VM) :: vm + integer :: mype rc = ESMF_SUCCESS @@ -247,6 +251,14 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) write(logmsg,*) write_diagnostics call ESMF_LogWrite('MOM_cap:DumpFields = '//trim(logmsg), ESMF_LOGMSG_INFO) + write_runtimelog = .false. + call NUOPC_CompAttributeGet(gcomp, name="RunTimeLog", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) write_runtimelog=(trim(value)=="true") + write(logmsg,*) write_runtimelog + call ESMF_LogWrite('MOM_cap:RunTimeLog = '//trim(logmsg), ESMF_LOGMSG_INFO) + overwrite_timeslice = .false. call NUOPC_CompAttributeGet(gcomp, name="OverwriteSlice", value=value, & isPresent=isPresent, isSet=isSet, rc=rc) @@ -422,9 +434,11 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) ! (same as restartfile if single restart file) character(len=*), parameter :: subname='(MOM_cap:InitializeAdvertise)' character(len=32) :: calendar + real(8) :: MPI_Wtime, timeiads !-------------------------------- rc = ESMF_SUCCESS + if(write_runtimelog) timeiads = MPI_Wtime() call ESMF_LogWrite(subname//' enter', ESMF_LOGMSG_INFO) @@ -774,7 +788,8 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call NUOPC_Advertise(exportState, standardName=fldsFrOcn(n)%stdname, name=fldsFrOcn(n)%shortname, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return enddo - if(is_root_pe()) write(stdout,*) 'InitializeAdvertise complete' + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeiads + end subroutine InitializeAdvertise !> Called by NUOPC to realize import and export fields. "Realizing" a field @@ -856,9 +871,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8) :: min_areacor_glob(2) real(ESMF_KIND_R8) :: max_areacor_glob(2) character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' + real(8) :: MPI_Wtime, timeirls !-------------------------------- rc = ESMF_SUCCESS + if(write_runtimelog) timeirls = MPI_Wtime() call shr_log_setLogUnit (stdout) @@ -1350,6 +1367,9 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! timeslice=1, relaxedFlag=.true., rc=rc) !if (ChkErr(rc,__LINE__,u_FILE_u)) return + timere = 0. + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timeirls + end subroutine InitializeRealize !> TODO @@ -1378,8 +1398,11 @@ subroutine DataInitialize(gcomp, rc) type(ESMF_Field) :: field character(len=64),allocatable :: fieldNameList(:) character(len=*),parameter :: subname='(MOM_cap:DataInitialize)' + real(8) :: MPI_Wtime, timedis !-------------------------------- + if(write_runtimelog) timedis = MPI_Wtime() + ! query the Component for its clock, importState and exportState call ESMF_GridCompGet(gcomp, clock=clock, importState=importState, exportState=exportState, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1440,6 +1463,8 @@ subroutine DataInitialize(gcomp, rc) enddo endif + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timedis + end subroutine DataInitialize !> Called by NUOPC to advance the model a single timestep. @@ -1490,9 +1515,14 @@ subroutine ModelAdvance(gcomp, rc) character(len=*),parameter :: subname='(MOM_cap:ModelAdvance)' character(len=8) :: suffix integer :: num_rest_files + real(8) :: MPI_Wtime, timers rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") + if(write_runtimelog) then + timers = MPI_Wtime() + if(timere>0. .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time since last time step ',timers-timere + endif call shr_log_setLogUnit (stdout) @@ -1726,6 +1756,11 @@ subroutine ModelAdvance(gcomp, rc) enddo endif + if(write_runtimelog) then + timere = MPI_Wtime() + if(is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', timere-timers + endif + if(profile_memory) call ESMF_VMLogMemInfo("Leaving MOM Model_ADVANCE: ") end subroutine ModelAdvance @@ -1928,11 +1963,13 @@ subroutine ocean_model_finalize(gcomp, rc) character(len=64) :: timestamp logical :: write_restart character(len=*),parameter :: subname='(MOM_cap:ocean_model_finalize)' + real(8) :: MPI_Wtime, timefs if (is_root_pe()) then write(stdout,*) 'MOM: --- finalize called ---' endif rc = ESMF_SUCCESS + if(write_runtimelog) timefs = MPI_Wtime() call ESMF_GridCompGetInternalState(gcomp, ocean_internalstate, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1961,9 +1998,7 @@ subroutine ocean_model_finalize(gcomp, rc) call io_infra_end() call MOM_infra_end() - if (is_root_pe()) then - write(stdout,*) 'MOM: --- completed ---' - endif + if(write_runtimelog .and. is_root_pe()) write(stdout,*) 'In ',trim(subname),' time ', MPI_Wtime()-timefs end subroutine ocean_model_finalize From 1d35fa1c2f984b94041029f6857e6dfaa410198f Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Fri, 8 Sep 2023 14:02:48 -0400 Subject: [PATCH 411/629] implement restart for internal tides (#463) * implement restart for internal tides * add a call to register restart diabatic in MOM * register restart diabatic call register restart internal tides * internal tides restart uses the extra_axes optional argument * support for extra_axes added to MOM_restart/MOM_io * implement 4d restart/ parallel_restart not working * add proper documentation for extra axes * fix read restart for 4d array * passes global_file optional arg to allow reading in parallel restart files * write one restart variable per vertical mode vertical modes >= 6 do not propagate hence there is no need for dynamic array size on this dimension --------- Co-authored-by: Raphael Dussin --- src/core/MOM.F90 | 11 +- src/framework/MOM_io.F90 | 71 +++-- src/framework/MOM_restart.F90 | 80 +++++- .../lateral/MOM_internal_tides.F90 | 272 ++++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 38 ++- 5 files changed, 371 insertions(+), 101 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ce001483ff..d112de07b7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -62,6 +62,7 @@ module MOM use MOM_coord_initialization, only : MOM_initialize_coord, write_vertgrid_file use MOM_diabatic_driver, only : diabatic, diabatic_driver_init, diabatic_CS, extract_diabatic_member use MOM_diabatic_driver, only : adiabatic, adiabatic_driver_init, diabatic_driver_end +use MOM_diabatic_driver, only : register_diabatic_restarts use MOM_stochastics, only : stochastics_init, update_stochastics, stochastic_CS use MOM_diagnostics, only : calculate_diagnostic_fields, MOM_diagnostics_init use MOM_diagnostics, only : register_transport_diags, post_transport_diagnostics @@ -94,6 +95,7 @@ module MOM use MOM_interface_heights, only : find_eta, calc_derived_thermo, thickness_to_dz use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS +use MOM_internal_tides, only : int_tide_CS use MOM_lateral_mixing_coeffs, only : calc_slope_functions, VarMix_init, VarMix_end use MOM_lateral_mixing_coeffs, only : calc_resoln_function, calc_depth_function, VarMix_CS use MOM_MEKE, only : MEKE_alloc_register_restart, step_forward_MEKE @@ -409,6 +411,8 @@ module MOM type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() !< Pointer to the oda incremental update control structure type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() + !< Pointer to the internal tides control structure + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Pointer to the ALE-mode sponge control structure type(ALE_CS), pointer :: ALE_CSp => NULL() !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure @@ -1964,6 +1968,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & type(ice_shelf_CS), optional, pointer :: ice_shelf_CSp !< A pointer to an ice shelf control structure type(Wave_parameters_CS), & optional, pointer :: Waves_CSp !< An optional pointer to a wave property CS + ! local variables type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the metric grid use for the run type(ocean_grid_type), pointer :: G_in => NULL() ! Pointer to the input grid @@ -2774,6 +2779,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call stoch_EOS_register_restarts(HI, param_file, CS%stoch_eos_CS, restart_CSp) endif + if (.not. CS%adiabatic) then + call register_diabatic_restarts(G, US, param_file, CS%int_tide_CSp, restart_CSp) + endif + call callTree_waypoint("restart registration complete (initialize_MOM)") call restart_registry_lock(restart_CSp) @@ -3139,7 +3148,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & else call diabatic_driver_init(Time, G, GV, US, param_file, CS%use_ALE_algorithm, diag, & CS%ADp, CS%CDp, CS%diabatic_CSp, CS%tracer_flow_CSp, & - CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp) + CS%sponge_CSp, CS%ALE_sponge_CSp, CS%oda_incupd_CSp, CS%int_tide_CSp) endif if (associated(CS%sponge_CSp)) & diff --git a/src/framework/MOM_io.F90 b/src/framework/MOM_io.F90 index 220a7d6bcf..27d244b226 100644 --- a/src/framework/MOM_io.F90 +++ b/src/framework/MOM_io.F90 @@ -148,6 +148,20 @@ module MOM_io module procedure read_attribute_int32, read_attribute_int64 end interface read_attribute +!> Type that stores information that can be used to create a non-decomposed axis. +type :: axis_info + character(len=32) :: name = "" !< The name of this axis for use in files + character(len=256) :: longname = "" !< A longer name describing this axis + character(len=48) :: units = "" !< The units of the axis labels + character(len=8) :: cartesian = "N" !< A variable indicating which direction + !! this axis corresponds with. Valid values + !! include 'X', 'Y', 'Z', 'T', and 'N' for none. + integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 + !! if they increase downward. The default, 0, is ignored. + integer :: ax_size = 0 !< The number of elements in this axis + real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] +end type axis_info + !> Type for describing a 3-d variable for output type, public :: vardesc character(len=64) :: name !< Variable name in a NetCDF file @@ -165,22 +179,9 @@ module MOM_io character(len=32) :: dim_names(5) !< The names in the file of the axes for this variable integer :: position = -1 !< An integer encoding the horizontal position, it may !! CENTER, CORNER, EAST_FACE, NORTH_FACE, or 0. + type(axis_info) :: extra_axes(5) !< dimensions other than space-time end type vardesc -!> Type that stores information that can be used to create a non-decomposed axis. -type :: axis_info ; private - character(len=32) :: name = "" !< The name of this axis for use in files - character(len=256) :: longname = "" !< A longer name describing this axis - character(len=48) :: units = "" !< The units of the axis labels - character(len=8) :: cartesian = "N" !< A variable indicating which direction - !! this axis corresponds with. Valid values - !! include 'X', 'Y', 'Z', 'T', and 'N' for none. - integer :: sense = 0 !< This is 1 for axes whose values increase upward, or -1 - !! if they increase downward. The default, 0, is ignored. - integer :: ax_size = 0 !< The number of elements in this axis - real, allocatable, dimension(:) :: ax_data !< The values of the data on the axis [arbitrary] -end type axis_info - !> Type that stores for a global file attribute type :: attribute_info ; private character(len=:), allocatable :: name !< The name of this attribute @@ -271,7 +272,8 @@ subroutine create_MOM_file(IO_handle, filename, vars, novars, fields, & !! required if the new file uses any !! vertical grid axes. integer(kind=int64), optional, intent(in) :: checksums(:,:) !< checksums of vars - type(axis_info), optional, intent(in) :: extra_axes(:) !< Types with information about + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< Types with information about !! some axes that might be used in this file type(attribute_info), optional, intent(in) :: global_atts(:) !< Global attributes to !! write to this file @@ -1751,7 +1753,8 @@ end subroutine verify_variable_units !! have default values that are empty strings or are appropriate for a 3-d !! tracer field at the tracer cell centers. function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_name, & - cmor_units, cmor_longname, conversion, caller, position, dim_names, fixed) result(vd) + cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes, fixed) result(vd) character(len=*), intent(in) :: name !< variable name character(len=*), optional, intent(in) :: units !< variable units character(len=*), optional, intent(in) :: longname !< variable long name @@ -1772,6 +1775,8 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na !! NORTH_FACE, and 0 for no horizontal dimensions. character(len=*), dimension(:), & optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time logical, optional, intent(in) :: fixed !< If true, this does not evolve with time type(vardesc) :: vd !< vardesc type that is created @@ -1795,7 +1800,8 @@ function var_desc(name, units, longname, hor_grid, z_grid, t_grid, cmor_field_na call modify_vardesc(vd, units=units, longname=longname, hor_grid=hor_grid, & z_grid=z_grid, t_grid=t_grid, position=position, dim_names=dim_names, & cmor_field_name=cmor_field_name, cmor_units=cmor_units, & - cmor_longname=cmor_longname, conversion=conversion, caller=cllr) + cmor_longname=cmor_longname, conversion=conversion, caller=cllr, & + extra_axes=extra_axes) end function var_desc @@ -1803,7 +1809,8 @@ end function var_desc !> This routine modifies the named elements of a vardesc type. !! All arguments are optional, except the vardesc type to be modified. subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & - cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names) + cmor_field_name, cmor_units, cmor_longname, conversion, caller, position, dim_names, & + extra_axes) type(vardesc), intent(inout) :: vd !< vardesc type that is modified character(len=*), optional, intent(in) :: name !< name of variable character(len=*), optional, intent(in) :: units !< units of variable @@ -1825,6 +1832,8 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & !! NORTH_FACE, and 0 for no horizontal dimensions. character(len=*), dimension(:), & optional, intent(in) :: dim_names !< The names of the dimensions of this variable + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time character(len=120) :: cllr integer :: n @@ -1877,6 +1886,12 @@ subroutine modify_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & endif ; enddo endif + if (present(extra_axes)) then + do n=1,size(extra_axes) ; if (len_trim(extra_axes(n)%name) > 0) then + vd%extra_axes(n) = extra_axes(n) + endif ; enddo + endif + end subroutine modify_vardesc integer function position_from_horgrid(hor_grid) @@ -2020,7 +2035,7 @@ end function cmor_long_std !> This routine queries vardesc subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & cmor_field_name, cmor_units, cmor_longname, conversion, caller, & - position, dim_names) + extra_axes, position, dim_names) type(vardesc), intent(in) :: vd !< vardesc type that is queried character(len=*), optional, intent(out) :: name !< name of variable character(len=*), optional, intent(out) :: units !< units of variable @@ -2035,6 +2050,8 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & !! convert from intensive to extensive !! [various] or [a A-1 ~> 1] character(len=*), optional, intent(in) :: caller !< calling routine? + type(axis_info), dimension(5), & + optional, intent(out) :: extra_axes !< dimensions other than space-time integer, optional, intent(out) :: position !< A coded integer indicating the horizontal position !! of this variable if it has such dimensions. !! Valid values include CORNER, CENTER, EAST_FACE @@ -2043,7 +2060,8 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & optional, intent(out) :: dim_names !< The names of the dimensions of this variable integer :: n - character(len=120) :: cllr + integer, parameter :: nmax_extraaxes = 5 + character(len=120) :: cllr, varname cllr = "mod_vardesc" if (present(caller)) cllr = trim(caller) @@ -2076,6 +2094,19 @@ subroutine query_vardesc(vd, name, units, longname, hor_grid, z_grid, t_grid, & enddo endif + if (present(extra_axes)) then + ! save_restart expects 5 extra axes (can be empty) + do n=1, nmax_extraaxes + if (vd%extra_axes(n)%ax_size>=1) then + extra_axes(n) = vd%extra_axes(n) + else + ! return an empty axis + write(varname,"('dummy',i1.1)") n + call set_axis_info(extra_axes(n), name=trim(varname), ax_size=1) + endif + enddo + endif + end subroutine query_vardesc diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 75051c32ba..252f14bfac 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -14,6 +14,7 @@ module MOM_restart use MOM_io, only : vardesc, var_desc, query_vardesc, modify_vardesc, get_filename_appendix use MOM_io, only : MULTIPLE, READONLY_FILE, SINGLE_FILE use MOM_io, only : CENTER, CORNER, NORTH_FACE, EAST_FACE +use MOM_io, only : axis_info, get_axis_info use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type, time_type_to_real, real_to_time use MOM_time_manager, only : days_in_month, get_date, set_date @@ -26,6 +27,7 @@ module MOM_restart public restart_registry_lock, restart_init_end, vardesc public restart_files_exist, determine_is_new_run, is_new_run public register_restart_field_as_obsolete, register_restart_pair +public lock_check ! 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 @@ -445,7 +447,7 @@ end subroutine register_restart_pair_ptr4d !> Register a 4-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units, conversion, & - hor_grid, z_grid, t_grid) + hor_grid, z_grid, t_grid, extra_axes) real, dimension(:,:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written !! in arbitrary rescaled units [A ~> a] @@ -460,8 +462,26 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_4d: Module must be initialized before "//& @@ -469,8 +489,13 @@ subroutine register_restart_field_4d(f_ptr, name, mandatory, CS, longname, units call lock_check(CS, name=name) - vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid) + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif call register_restart_field_ptr4d(f_ptr, vd, mandatory, CS, conversion) @@ -478,7 +503,7 @@ end subroutine register_restart_field_4d !> Register a 3-d field for restarts, providing the metadata as individual arguments subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units, conversion, & - hor_grid, z_grid, t_grid) + hor_grid, z_grid, t_grid, extra_axes) real, dimension(:,:,:), & target, intent(in) :: f_ptr !< A pointer to the field to be read or written !! in arbitrary rescaled units [A ~> a] @@ -493,8 +518,26 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units character(len=*), optional, intent(in) :: hor_grid !< variable horizontal staggering, 'h' if absent character(len=*), optional, intent(in) :: z_grid !< variable vertical staggering, 'L' if absent character(len=*), optional, intent(in) :: t_grid !< time description: s, p, or 1, 's' if absent + type(axis_info), dimension(:), & + optional, intent(in) :: extra_axes !< dimensions other than space-time type(vardesc) :: vd + character(len=32), dimension(:), allocatable :: dim_names + integer :: n, n_extradims + + ! first 2 dimensions in dim_names are reserved for i,j + ! so extra_dimensions are shifted to index 3. + ! this is designed not to break the behavior in SIS2 + ! (see register_restart_field_4d in SIS_restart.F90) + if (present(extra_axes)) then + n_extradims = size(extra_axes) + allocate(dim_names(n_extradims+2)) + dim_names(1) = "" + dim_names(2) = "" + do n=3,n_extradims+2 + dim_names(n) = extra_axes(n-2)%name + enddo + endif if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart: " // & "register_restart_field_3d: Module must be initialized before "//& @@ -502,8 +545,13 @@ subroutine register_restart_field_3d(f_ptr, name, mandatory, CS, longname, units call lock_check(CS, name=name) - vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid) + if (present(extra_axes)) then + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid, dim_names=dim_names, extra_axes=extra_axes) + else + vd = var_desc(name, units=units, longname=longname, hor_grid=hor_grid, & + z_grid=z_grid, t_grid=t_grid) + endif call register_restart_field_ptr3d(f_ptr, vd, mandatory, CS, conversion) @@ -1309,7 +1357,7 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer :: start_var, next_var ! The starting variables of the ! current and next files. type(MOM_infra_file) :: IO_handle ! The I/O handle of the open fileset - integer :: m, nz + integer :: m, nz, na integer :: num_files ! The number of restart files that will be used. integer :: seconds, days, year, month, hour, minute character(len=8) :: hor_grid, z_grid, t_grid ! Variable grid info. @@ -1320,9 +1368,13 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ integer(kind=8) :: check_val(CS%max_fields,1) integer :: isL, ieL, jsL, jeL, pos integer :: turns + integer, parameter :: nmax_extradims = 5 + type(axis_info), dimension(:), allocatable :: extra_axes turns = CS%turns + allocate (extra_axes(nmax_extradims)) + if (.not.CS%initialized) call MOM_error(FATAL, "MOM_restart " // & "save_restart: Module must be initialized before it is used.") @@ -1361,8 +1413,14 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ do m=start_var,CS%novars call query_vardesc(CS%restart_field(m)%vars, hor_grid=hor_grid, & - z_grid=z_grid, t_grid=t_grid, caller="save_restart") + z_grid=z_grid, t_grid=t_grid, caller="save_restart", & + extra_axes=extra_axes) + var_sz = get_variable_byte_size(hor_grid, z_grid, t_grid, G, nz) + ! factor in size of extra axes, or multiply by 1 + do na=1,nmax_extradims + var_sz = var_sz*extra_axes(na)%ax_size + enddo if ((m==start_var) .OR. (size_in_file < max_file_size-var_sz)) then size_in_file = size_in_file + var_sz @@ -1445,10 +1503,10 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ if (CS%parallel_restartfiles) then call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & - fields, MULTIPLE, G=G, GV=GV, checksums=check_val) + fields, MULTIPLE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) else call create_MOM_file(IO_handle, trim(restartpath), vars, next_var-start_var, & - fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val) + fields, SINGLE_FILE, G=G, GV=GV, checksums=check_val, extra_axes=extra_axes) endif do m=start_var,next_var-1 @@ -1650,7 +1708,7 @@ subroutine restore_state(filename, directory, day, G, CS) elseif (associated(CS%var_ptr4d(m)%p)) then ! Read a 4d array. if (pos /= 0) then call MOM_read_data(unit_path(n), varname, CS%var_ptr4d(m)%p, & - G%Domain, timelevel=1, position=pos, scale=scale) + G%Domain, timelevel=1, position=pos, scale=scale, global_file=unit_is_global(n)) else ! This array is not domain-decomposed. This variant may be under-tested. call MOM_error(FATAL, & "MOM_restart does not support 4-d arrays without domain decomposition.") diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 788e922ff2..83910e6690 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,8 +16,10 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_io, only : slasher, MOM_read_data, file_exists +use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info +use MOM_io, only : set_axis_info, get_axis_info use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart +use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type @@ -29,12 +31,13 @@ module MOM_internal_tides #include -public propagate_int_tide !, register_int_tide_restarts +public propagate_int_tide, register_int_tide_restarts public internal_tides_init, internal_tides_end public get_lowmode_loss !> This control structure has parameters for the MOM_internal_tides module type, public :: int_tide_CS ; private + logical :: initialized = .false. !< True if this control structure has been initialized. 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 @@ -137,8 +140,17 @@ module MOM_internal_tides real, allocatable :: En(:,:,:,:,:) !< The internal wave energy density as a function of (i,j,angle,frequency,mode) !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] - real, allocatable :: En_restart(:,:,:) - !< The internal wave energy density as a function of (i,j,angle); temporary for restart + real, allocatable :: En_restart_mode1(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 1 + real, allocatable :: En_restart_mode2(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 2 + real, allocatable :: En_restart_mode3(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 3 + real, allocatable :: En_restart_mode4(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 4 + real, allocatable :: En_restart_mode5(:,:,:,:) + !< The internal wave energy density as a function of (i,j,angle,freq) for mode 5 + real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. type(wave_speed_CS) :: wave_speed !< Wave speed control structure @@ -266,6 +278,35 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, cn(:,:,:) = 0. + ! Rebuild energy density array from multiple restarts + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + endif + ! 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 @@ -323,7 +364,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -344,7 +385,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call correct_halo_rotation(CS%En, test, G, CS%nAngle) ! Propagate the waves. - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq CS%TKE_residual_loss(:,:,:,fr,m) = 0. @@ -353,7 +394,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset @@ -369,13 +410,13 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ; enddo ! Apply the other half of the refraction. - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -394,7 +435,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, .or. (CS%id_tot_En > 0)) then tot_En(:,:) = 0.0 tot_En_mode(:,:,:,:) = 0.0 - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq do j=jsd,jed ; do i=isd,ied ; do a=1,CS%nAngle tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) tot_En_mode(i,j,fr,m) = tot_En_mode(i,j,fr,m) + CS%En(i,j,a,fr,m) @@ -412,7 +453,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -453,7 +494,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -471,7 +512,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! still need to allow a portion of the extracted energy to go to higher modes. ! 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 + do m=1,CS%nMode ; do fr=1,CS%Nfreq ! compute near-bottom and max horizontal baroclinic velocity values at each point do j=jsd,jed ; do i=isd,ied @@ -519,7 +560,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, CS%TKE_itidal_loss, dt, full_halos=.false.) endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -535,7 +576,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to wave breaking----------------------------- if (CS%apply_Froude_drag) then ! Pick out maximum baroclinic velocity values; calculate Fr=max(u)/cg - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq freq2 = CS%frequency(fr)**2 do j=js,je ; do i=is,ie id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging @@ -586,7 +627,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, enddo ; enddo endif ! Check for En<0 - for debugging, delete later - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle do j=js,je ; do i=is,ie if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset @@ -618,7 +659,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Check for energy conservation on computational domain.************************* - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq call sum_En(G, US, CS, CS%En(:,:,:,fr,m), 'prop_int_tide') enddo ; enddo @@ -638,7 +679,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, TKE_itidal_input, CS%diag) ! Output 2-D energy density (summed over angles) for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then tot_En(:,:) = 0.0 do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) @@ -646,8 +687,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call post_data(CS%id_En_mode(fr,m), tot_En, CS%diag) endif ; enddo ; enddo + ! split energy array into multiple restarts + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode1(i,j,a,fr) = CS%En(i,j,a,fr,1) + enddo ; enddo ; enddo ; enddo + + if (CS%nMode >= 2) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode2(i,j,a,fr) = CS%En(i,j,a,fr,2) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 3) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode3(i,j,a,fr) = CS%En(i,j,a,fr,3) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 4) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode4(i,j,a,fr) = CS%En(i,j,a,fr,4) + enddo ; enddo ; enddo ; enddo + endif + + if (CS%nMode >= 5) then + do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + CS%En_restart_mode5(i,j,a,fr) = CS%En(i,j,a,fr,5) + enddo ; enddo ; enddo ; enddo + endif + ! Output 3-D (i,j,a) energy density for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_ang_mode(fr,m) > 0) then call post_data(CS%id_En_ang_mode(fr,m), CS%En(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo @@ -658,7 +728,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, tot_Froude_loss(:,:) = 0.0 tot_residual_loss(:,:) = 0.0 tot_allprocesses_loss(:,:) = 0.0 - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie tot_leak_loss(i,j) = tot_leak_loss(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) tot_quad_loss(i,j) = tot_quad_loss(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) tot_itidal_loss(i,j) = tot_itidal_loss(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) @@ -696,7 +766,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, endif ! Output 2-D energy loss (summed over angles) for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq + do m=1,CS%nMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together @@ -712,37 +782,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, endif ; enddo ; enddo ! Output 3-D (i,j,a) energy loss for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_itidal_loss_ang_mode(fr,m) > 0) then call post_data(CS%id_itidal_loss_ang_mode(fr,m), CS%TKE_itidal_loss(:,:,:,fr,m) , CS%diag) endif ; enddo ; enddo ! Output 2-D period-averaged horizontal near-bottom mode velocity for each frequency and mode - do m=1,CS%NMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then + do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_Ub_mode(fr,m) > 0) then 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 + 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 + 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 + 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 + 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 + 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 + 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) endif ; enddo ; enddo @@ -2276,43 +2346,120 @@ subroutine PPM_limit_pos(h_in, h_L, h_R, h_min, G, iis, iie, jis, jie) enddo ; enddo end subroutine PPM_limit_pos -! subroutine register_int_tide_restarts(G, param_file, CS, restart_CS) -! type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure -! type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters -! type(int_tide_CS), intent(in) :: CS !< Internal tide control structure -! type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure +subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(int_tide_CS), pointer :: CS !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CS !< MOM restart control structure + + ! This subroutine is used to allocate and register any fields in this module + ! that should be written to or read from the restart file. + logical :: use_int_tides + integer :: num_freq, num_angle , num_mode, period_1 + integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, i, j, a, fr + character(64) :: var_name, cfr + + type(axis_info) :: axes_inttides(2) + real, dimension(:), allocatable :: angles, freqs + + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + + if (associated(CS)) then + call MOM_error(WARNING, "register_int_tide_restarts called "//& + "with an associated control structure.") + return + endif + + allocate(CS) + + ! write extra axes + call get_param(param_file, "MOM", "INTERNAL_TIDE_ANGLES", num_angle, default=24) + call get_param(param_file, "MOM", "INTERNAL_TIDE_FREQS", num_freq, default=1) + call get_param(param_file, "MOM", "INTERNAL_TIDE_MODES", num_mode, default=1) + + allocate (angles(num_angle)) + allocate (freqs(num_freq)) + + do a=1,num_angle ; angles(a)= a ; enddo + do fr=1,num_freq ; freqs(fr)= fr ; enddo + + call set_axis_info(axes_inttides(1), "angle", "", "angle direction", num_angle, angles, "N", 1) + call set_axis_info(axes_inttides(2), "freq", "", "wave frequency", num_freq, freqs, "N", 1) + + ! full energy array + allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) + + ! restart strategy: support for 5d restart is not yet available so we split into + ! 4d restarts. Vertical modes >= 6 are dissipated locally and do not propagate + ! so we only allow for 5 vertical modes and each has its own variable + + ! allocate restart arrays + allocate(CS%En_restart_mode1(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 2) allocate(CS%En_restart_mode2(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 3) allocate(CS%En_restart_mode3(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 4) allocate(CS%En_restart_mode4(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + if (num_mode >= 5) allocate(CS%En_restart_mode5(isd:ied, jsd:jed, num_angle, num_freq), source=0.0) + + ! register all 4d restarts and copy into full Energy array when restarting from previous state + call register_restart_field(CS%En_restart_mode1(:,:,:,:), "IW_energy_mode1", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 1", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,1) = CS%En_restart_mode1(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + if (num_mode >= 2) then + call register_restart_field(CS%En_restart_mode2(:,:,:,:), "IW_energy_mode2", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 2", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) + + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,2) = CS%En_restart_mode2(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif + + if (num_mode >= 3) then + call register_restart_field(CS%En_restart_mode3(:,:,:,:), "IW_energy_mode3", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 3", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! ! This subroutine is not currently in use!! + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,3) = CS%En_restart_mode3(i,j,a,fr) + enddo ; enddo ; enddo ; enddo + + endif -! ! This subroutine is used to allocate and register any fields in this module -! ! that should be written to or read from the restart file. -! logical :: use_int_tides -! integer :: num_freq, num_angle , num_mode, period_1 -! integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB, a -! isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed -! IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + if (num_mode >= 4) then + call register_restart_field(CS%En_restart_mode4(:,:,:,:), "IW_energy_mode4", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 4", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! if (associated(CS)) then -! call MOM_error(WARNING, "register_int_tide_restarts called "//& -! "with an associated control structure.") -! return -! endif + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,4) = CS%En_restart_mode4(i,j,a,fr) + enddo ; enddo ; enddo ; enddo -! use_int_tides = .false. -! call read_param(param_file, "INTERNAL_TIDES", use_int_tides) -! if (.not.use_int_tides) return + endif -! allocate(CS) + if (num_mode >= 5) then + call register_restart_field(CS%En_restart_mode5(:,:,:,:), "IW_energy_mode5", .false., restart_CS, & + longname="The internal wave energy density f(i,j,angle,freq) for mode 5", & + units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1', t_grid="s", & + extra_axes=axes_inttides) -! num_angle = 24 -! call read_param(param_file, "INTERNAL_TIDE_ANGLES", num_angle) -! allocate(CS%En_restart(isd:ied, jsd:jed, num_angle), source=0.0) + do fr=1,num_freq ; do a=1,num_angle ; do j=jsd,jed ; do i=isd,ied + CS%En(i,j,a,fr,5) = CS%En_restart_mode5(i,j,a,fr) + enddo ; enddo ; enddo ; enddo -! call register_restart_field(CS%En_restart, "En_restart", .false., restart_CS, & -! longname="The internal wave energy density as a function of (i,j,angle,frequency,mode)", & -! units="J m-2", conversion=US%RZ3_T3_to_W_m2*US%T_to_s, z_grid='1') + endif -! end subroutine register_int_tide_restarts +end subroutine register_int_tide_restarts !> This subroutine initializes the internal tides module. subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) @@ -2324,7 +2471,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) !! parameters. type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate !! diagnostic output. - type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure + type(int_tide_CS), pointer :: CS !< Internal tide control structure ! Local variables real :: Angle_size ! size of wedges [rad] @@ -2358,6 +2505,8 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke + CS%initialized = .true. + use_int_tides = .false. call read_param(param_file, "INTERNAL_TIDES", use_int_tides) CS%do_int_tides = use_int_tides @@ -2376,9 +2525,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode - ! Allocate energy density array - allocate(CS%En(isd:ied, jsd:jed, num_angle, num_freq, num_mode), source=0.0) - ! Allocate phase speed array allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) @@ -2430,7 +2576,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "Inconsistent number of frequencies.") if (CS%NAngle /= num_angle) call MOM_error(FATAL, "Internal_tides_init: "//& "Inconsistent number of angles.") - if (CS%NMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& + if (CS%nMode /= num_mode) call MOM_error(FATAL, "Internal_tides_init: "//& "Inconsistent number of modes.") if (4*(num_angle/4) /= num_angle) call MOM_error(FATAL, & "Internal_tides_init: INTERNAL_TIDE_ANGLES must be a multiple of 4.") diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b2b8527819..1ccd6a7fb2 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -45,7 +45,7 @@ module MOM_diabatic_driver 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, calc_derived_thermo, thickness_to_dz -use MOM_internal_tides, only : propagate_int_tide +use MOM_internal_tides, only : propagate_int_tide, register_int_tide_restarts use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used use MOM_CVMix_KPP, only : KPP_CS, KPP_init, KPP_compute_BLD, KPP_calculate @@ -56,6 +56,7 @@ module MOM_diabatic_driver use MOM_opacity, only : absorbRemainingSW, optics_type, optics_nbands use MOM_open_boundary, only : ocean_OBC_type use MOM_regularize_layers, only : regularize_layers, regularize_layers_init, regularize_layers_CS +use MOM_restart, only : MOM_restart_CS use MOM_set_diffusivity, only : set_diffusivity, set_BBL_TKE use MOM_set_diffusivity, only : set_diffusivity_init, set_diffusivity_end use MOM_set_diffusivity, only : set_diffusivity_CS @@ -81,6 +82,7 @@ module MOM_diabatic_driver public extract_diabatic_member public adiabatic public adiabatic_driver_init +public register_diabatic_restarts ! 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 @@ -226,12 +228,13 @@ module MOM_diabatic_driver type(KPP_CS), pointer :: KPP_CSp => NULL() !< Control structure for a child module type(diapyc_energy_req_CS), pointer :: diapyc_en_rec_CSp => NULL() !< Control structure for a child module type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() !< Control structure for a child module + type(int_tide_CS), pointer :: int_tide_CSp => NULL() !< Control structure for a child module + type(bulkmixedlayer_CS) :: bulkmixedlayer !< Bulk mixed layer control structure type(CVMix_conv_CS) :: CVMix_conv !< CVMix convection control structure type(energetic_PBL_CS) :: ePBL !< Energetic PBL control structure type(entrain_diffusive_CS) :: entrain_diffusive !< Diffusive entrainment control structure type(geothermal_CS) :: geothermal !< Geothermal control structure - 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 @@ -386,7 +389,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & CS%int_tide_input_CSp) call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide) + CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide_CSp) if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides @@ -2980,7 +2983,7 @@ end subroutine adiabatic_driver_init !> This routine initializes the diabatic driver module. subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, diag, & ADp, CDp, CS, tracer_flow_CSp, sponge_CSp, & - ALE_sponge_CSp, oda_incupd_CSp) + ALE_sponge_CSp, oda_incupd_CSp, int_tide_CSp) type(time_type), target :: Time !< model time type(ocean_grid_type), intent(inout) :: G !< model grid structure type(verticalGrid_type), intent(in) :: GV !< model vertical grid structure @@ -2998,6 +3001,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di type(ALE_sponge_CS), pointer :: ALE_sponge_CSp !< pointer to the ALE sponge module control structure type(oda_incupd_CS), pointer :: oda_incupd_CSp !< pointer to the ocean data assimilation incremental !! update module control structure + type(int_tide_CS), pointer :: int_tide_CSp !< pointer to the internal tide structure ! Local variables real :: Kd ! A diffusivity used in the default for other tracer diffusivities [Z2 T-1 ~> m2 s-1] @@ -3032,6 +3036,7 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (associated(sponge_CSp)) CS%sponge_CSp => sponge_CSp if (associated(ALE_sponge_CSp)) CS%ALE_sponge_CSp => ALE_sponge_CSp if (associated(oda_incupd_CSp)) CS%oda_incupd_CSp => oda_incupd_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp CS%useALEalgorithm = useALEalgorithm CS%use_bulkmixedlayer = (GV%nkml > 0) @@ -3497,12 +3502,14 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di if (CS%use_int_tides) then 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 internal_tides_init(Time, G, GV, US, param_file, diag, int_tide_CSp) endif + !if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp + physical_OBL_scheme = (CS%use_bulkmixedlayer .or. CS%use_KPP .or. CS%use_energetic_PBL) ! initialize module for setting diffusivities - call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide, & + call set_diffusivity_init(Time, G, GV, US, param_file, diag, CS%set_diff_CSp, CS%int_tide_CSp, & halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse, & physical_OBL_scheme=physical_OBL_scheme) @@ -3558,6 +3565,25 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di end subroutine diabatic_driver_init +!> Routine to register restarts, pass-through to children modules +subroutine register_diabatic_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + 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(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure + type(MOM_restart_CS), pointer :: restart_CSp !< MOM restart control structure + + logical :: use_int_tides + + use_int_tides=.false. + + call read_param(param_file, "INTERNAL_TIDES", use_int_tides) + + if (use_int_tides) then + call register_int_tide_restarts(G, US, param_file, int_tide_CSp, restart_CSp) + endif + +end subroutine register_diabatic_restarts !> Routine to close the diabatic driver module subroutine diabatic_driver_end(CS) From 5bc0c5e077a4e64a66102f33d5eb256bf794c670 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 8 Sep 2023 16:23:39 -0600 Subject: [PATCH 412/629] Pass wavebands from coupler to wave_parameters_CS (#255) * Makes set_u_at_v and set_v_at_u public * First draft for fpmix * Change name of logical Replaces LU_pred to L_diag, since now this logical only controls if diagnostics should be posted. * Updates to vertFPmix This commit adds the latest updates to the vertFPmix subroutine after Bill Large did some cleaning. We have highlight places in the code where work must be done. * Add missing use for vertFPmix * Add omega_w2x to fluxes and forces omega_w2x is the counter-clockwise angle of the wind stress with respect to the horizontal abscissa (x-coordinate) at tracer points [rad]. This variable is needed in the vertPFmix subroutine. * Add mssing call to get_param for FPMIX This line of code was lost during the last merge. * Pass wavebands from coupler to wave_parameters_CS This commit passes the waveband information recieved from the coupler to wave_parameters_CS. This information is set to public so that it can be used elsewhere. To exercise this code the following must be set: SURFBAND = COUPLER WAVE_METHOD = SURFACE_BANDS No answer changes. * Describe local variables and make code consistent * Removed L_diag and moved variables in vertFPmix * Revert order of variables in vertFPmix --- src/user/MOM_wave_interface.F90 | 37 +++++++++++++++++++++++++++------ 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index a548436329..02da5a0007 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -98,6 +98,21 @@ module MOM_wave_interface !! Vertical -> Mid-points real, allocatable, dimension(:,:,:), public :: & KvS !< Viscosity for Stokes Drift shear [Z2 T-1 ~> m2 s-1] + real, allocatable, dimension(:), public :: & + WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] + real, allocatable, dimension(:,:,:), public :: & + UStk_Hb !< Surface Stokes Drift spectrum (zonal) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:,:), public :: & + VStk_Hb !< Surface Stokes Drift spectrum (meridional) [L T-1 ~> m s-1] + !! Horizontal -> H-points + !! 3rd dimension -> Freq/Wavenumber + real, allocatable, dimension(:,:), public :: & + Omega_w2x !< wind direction ccw from model x- axis [nondim radians] + integer, public :: NumBands = 0 !< Number of wavenumber/frequency partitions + !! Must match the number of bands provided + !! via either coupling or file. ! The remainder of this control structure is private integer :: WaveMethod = -99 !< Options for including wave information @@ -149,18 +164,12 @@ module MOM_wave_interface real :: LA_FracHBL !< Fraction of OSBL for averaging Langmuir number [nondim] real :: LA_HBL_min !< Minimum boundary layer depth for averaging Langmuir number [Z ~> m] logical :: LA_Misalignment = .false. !< Flag to use misalignment in Langmuir number - - integer :: NumBands = 0 !< Number of wavenumber/frequency partitions to receive - !! This needs to match the number of bands provided - !! via either coupling or file. real :: g_Earth !< The gravitational acceleration, equivalent to GV%g_Earth but with !! different dimensional rescaling appropriate for deep-water gravity !! waves [Z T-2 ~> m s-2] real :: I_g_Earth !< The inverse of the gravitational acceleration, with dimensional rescaling !! appropriate for deep-water gravity waves [T2 Z-1 ~> s2 m-1] ! Surface Wave Dependent 1d/2d/3d vars - real, allocatable, dimension(:) :: & - WaveNum_Cen !< Wavenumber bands for read/coupled [Z-1 ~> m-1] real, allocatable, dimension(:) :: & Freq_Cen !< Central frequency for wave bands, including a factor of 2*pi [T-1 ~> s-1] real, allocatable, dimension(:) :: & @@ -448,6 +457,9 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar allocate( CS%WaveNum_Cen(CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,CS%NumBands), source=0.0 ) allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,CS%NumBands), source=0.0 ) + allocate( CS%UStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%VStk_Hb(G%isc:G%iec,G%jsc:G%jec,CS%NumBands), source=0.0 ) + allocate( CS%Omega_w2x(G%isc:G%iec,G%jsc:G%jec) , source=0.0 ) CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & @@ -463,6 +475,7 @@ subroutine MOM_wave_interface_init(time, G, GV, US, param_file, CS, diag, restar allocate( CS%PrescribedSurfStkY(1:CS%NumBands), source=0.0 ) allocate( CS%STKx0(G%isdB:G%iedB,G%jsd:G%jed,1:CS%NumBands), source=0.0 ) allocate( CS%STKy0(G%isd:G%ied,G%jsdB:G%jedB,1:CS%NumBands), source=0.0 ) + CS%PartitionMode = 0 call get_param(param_file, mdl, "SURFBAND_WAVENUMBERS", CS%WaveNum_Cen, & "Central wavenumbers for surface Stokes drift bands.", & @@ -692,6 +705,15 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) enddo + do jj=G%jsc,G%jec + do ii=G%isc,G%iec + CS%Omega_w2x(ii,jj) = forces%omega_w2x(ii,jj) + do b=1,CS%NumBands + CS%UStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%UStkb(ii,jj,b) + CS%VStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%VStkb(ii,jj,b) + enddo + enddo + enddo elseif (CS%DataSource == INPUT) then do b=1,CS%NumBands do jj=G%jsd,G%jed @@ -2009,6 +2031,9 @@ subroutine Waves_end(CS) if (allocated(CS%La_turb)) deallocate( CS%La_turb ) if (allocated(CS%STKx0)) deallocate( CS%STKx0 ) if (allocated(CS%STKy0)) deallocate( CS%STKy0 ) + if (allocated(CS%UStk_Hb)) deallocate( CS%UStk_Hb ) + if (allocated(CS%VStk_Hb)) deallocate( CS%VStk_Hb ) + if (allocated(CS%Omega_w2x)) deallocate( CS%Omega_w2x ) if (allocated(CS%KvS)) deallocate( CS%KvS ) if (allocated(CS%Us0_y)) deallocate( CS%Us0_y ) if (allocated(CS%Us0_x)) deallocate( CS%Us0_x ) From 1bb8852186e7cc6972077ff2557310ca46cf4c82 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 9 Aug 2023 13:31:39 -0400 Subject: [PATCH 413/629] *+Non-Boussinesq MEKE and add MEKE_TOTAL_DEPTH_RHO This commit revises MOM_MEKE to work in with total depths in thickness units to avoid any dependence on the Boussinesq reference density in non-Boussinesq mode, while retaining the previous answers in Boussinesq mode. It also adds the new runtime parameter MEKE_TOTAL_DEPTH_RHO to specify the density that is used to convert the bathymetric depth into a nominal ocean mass in non-Boussinesq mode when MEKE is enabled and MEKE_FIXED_TOTAL_DEPTH is true. There is a new element in the MEKE_CS type, and the scaled units of two other elements (cdrag and MEKE_min_depth_tot) are altered. The units of a total of 5 arguments to the private routines MEKE_equilibrium, MEKE_equilibrium_restoring, MEKE_lengthScales and MEKE_lengthScales_0d where changed consistently with the broader changes here. There is also a new vertical_grid type argument to MEKE_equilibrium_restoring. The units of 6 internal variables are changed, 2 new internal variable were added and 5 internal variables were eliminated. There are 4 places where multiplication by a GV%H_to_Z thickness rescaling factor was eliminated, while 4 instances that use GV%Rho0 directly were effectively replaced by the use of GV%H_to_RZ. All Boussinesq answers are bitwise identical, but answers will change in non-Boussinesq mode and there is a new runtime parameter the MOM_parameter_doc files for some non-Boussinesq simulations. --- src/parameterizations/lateral/MOM_MEKE.F90 | 125 +++++++++++---------- 1 file changed, 67 insertions(+), 58 deletions(-) diff --git a/src/parameterizations/lateral/MOM_MEKE.F90 b/src/parameterizations/lateral/MOM_MEKE.F90 index 3059ca1637..a44eec7727 100644 --- a/src/parameterizations/lateral/MOM_MEKE.F90 +++ b/src/parameterizations/lateral/MOM_MEKE.F90 @@ -75,15 +75,15 @@ module MOM_MEKE !! which is calculated at each time step. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather !! than the streamfunction for the MEKE GM source term. - real :: MEKE_min_depth_tot !< The minimum total depth over which to distribute MEKE energy - !! sources from GM energy conversion [Z ~> m]. When the total - !! depth is less than this, the sources are scaled away. + real :: MEKE_min_depth_tot !< The minimum total thickness over which to distribute MEKE energy + !! sources from GM energy conversion [H ~> m or kg m-2]. When the total + !! thickness is less than this, the sources are scaled away. logical :: Rd_as_max_scale !< If true the length scale can not exceed the !! first baroclinic deformation radius. logical :: use_old_lscale !< Use the old formula for mixing length scale. logical :: use_min_lscale !< Use simple minimum for mixing length scale. real :: lscale_maxval !< The ceiling on the MEKE mixing length scale when use_min_lscale is true [L ~> m]. - real :: cdrag !< The bottom drag coefficient for MEKE [nondim]. + real :: cdrag !< The bottom drag coefficient for MEKE, times rescaling factors [H L-1 ~> nondim or kg m-3] real :: MEKE_BGsrc !< Background energy source for MEKE [L2 T-3 ~> W kg-1] (= m2 s-3). real :: MEKE_dtScale !< Scale factor to accelerate time-stepping [nondim] real :: MEKE_KhCoeff !< Scaling factor to convert MEKE into Kh [nondim] @@ -115,6 +115,9 @@ module MOM_MEKE logical :: fixed_total_depth !< If true, use the nominal bathymetric depth as the estimate of !! the time-varying ocean depth. Otherwise base the depth on the total !! ocean mass per unit area. + real :: rho_fixed_total_depth !< A density used to translate the nominal bathymetric depth into an + !! estimate of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH + !! is true [R ~> kg m-3] logical :: kh_flux_enabled !< If true, lateral diffusive MEKE flux is enabled. logical :: initialize !< If True, invokes a steady state solver to calculate MEKE. logical :: debug !< If true, write out checksums of data for debugging @@ -186,10 +189,10 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h data_eke, & ! EKE from file [L2 T-2 ~> m2 s-2] mass, & ! The total mass of the water column [R Z ~> kg m-2]. I_mass, & ! The inverse of mass [R-1 Z-1 ~> m2 kg-1]. - depth_tot, & ! The depth of the water column [Z ~> m]. + depth_tot, & ! The depth of the water column [H ~> m or kg m-2]. src, & ! The sum of all MEKE sources [L2 T-3 ~> W kg-1] (= m2 s-3). MEKE_decay, & ! A diagnostic of the MEKE decay timescale [T-1 ~> s-1]. - drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [L T-1 ~> m s-1] + drag_rate_visc, & ! Near-bottom velocity contribution to bottom drag [H T-1 ~> m s-1 or kg m-2 s-1] drag_rate, & ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. del2MEKE, & ! Laplacian of MEKE, used for bi-harmonic diffusion [T-2 ~> s-2]. del4MEKE, & ! Time-integrated MEKE tendency arising from the biharmonic of MEKE [L2 T-2 ~> m2 s-2]. @@ -205,23 +208,21 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! In one place, MEKE_uflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_u, & ! The zonal diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHu, & ! Depth integrated accumulated zonal mass flux [R Z L2 ~> kg]. - drag_vel_u ! A (vertical) viscosity associated with bottom drag at u-points [Z T-1 ~> m s-1]. + drag_vel_u ! A piston velocity associated with bottom drag at u-points [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G),SZJB_(G)) :: & MEKE_vflux, & ! The meridional advective and diffusive flux of MEKE with units of [R Z L4 T-3 ~> kg m2 s-3]. ! In one place, MEKE_vflux is used as temporary work space with units of [L2 T-2 ~> m2 s-2]. Kh_v, & ! The meridional diffusivity that is actually used [L2 T-1 ~> m2 s-1]. baroHv, & ! Depth integrated accumulated meridional mass flux [R Z L2 ~> kg]. - drag_vel_v ! A (vertical) viscosity associated with bottom drag at v-points [Z T-1 ~> m s-1]. + drag_vel_v ! A piston velocity associated with bottom drag at v-points [H T-1 ~> m s-1 or kg m-2 s-1] real :: Kh_here ! The local horizontal viscosity [L2 T-1 ~> m2 s-1] real :: Inv_Kh_max ! The inverse of the local horizontal viscosity [T L-2 ~> s m-2] real :: K4_here ! The local horizontal biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: Inv_K4_max ! The inverse of the local horizontal biharmonic viscosity [T L-4 ~> s m-4] - real :: cdrag2 ! The square of the drag coefficient [nondim] + real :: cdrag2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: advFac ! The product of the advection scaling factor and 1/dt [T-1 ~> s-1] real :: mass_neglect ! A negligible mass [R Z ~> kg m-2]. real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. - real :: Rho0 ! A density used to convert mass to distance [R ~> kg m-3] - real :: I_Rho0 ! The inverse of the density used to convert mass to distance [R-1 ~> m3 kg-1] real :: sdt ! dt to use locally [T ~> s] (could be scaled to accelerate) real :: sdt_damp ! dt for damping [T ~> s] (sdt could be split). logical :: use_drag_rate ! Flag to indicate drag_rate is finite @@ -266,8 +267,6 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif sdt = dt*CS%MEKE_dtScale ! Scaled dt to use for time-stepping - Rho0 = GV%Rho0 - I_Rho0 = 1.0 / GV%Rho0 mass_neglect = GV%H_to_RZ * GV%H_subroundoff cdrag2 = CS%cdrag**2 @@ -311,18 +310,18 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h do j=js,je ; do I=is-1,ie drag_vel_u(I,j) = 0.0 if ((G%mask2dCu(I,j) > 0.0) .and. (visc%bbl_thick_u(I,j) > 0.0)) & - drag_vel_u(I,j) = GV%H_to_Z*visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) + drag_vel_u(I,j) = visc%Kv_bbl_u(I,j) / visc%bbl_thick_u(I,j) enddo ; enddo !$OMP parallel do default(shared) do J=js-1,je ; do i=is,ie drag_vel_v(i,J) = 0.0 if ((G%mask2dCv(i,J) > 0.0) .and. (visc%bbl_thick_v(i,J) > 0.0)) & - drag_vel_v(i,J) = GV%H_to_Z*visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) + drag_vel_v(i,J) = visc%Kv_bbl_v(i,J) / visc%bbl_thick_v(i,J) enddo ; enddo !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * US%Z_to_L * & + drag_rate_visc(i,j) = (0.25*G%IareaT(i,j) * & ((G%areaCu(I-1,j)*drag_vel_u(I-1,j) + & G%areaCu(I,j)*drag_vel_u(I,j)) + & (G%areaCv(i,J-1)*drag_vel_v(i,J-1) + & @@ -348,14 +347,21 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h enddo if (CS%fixed_total_depth) then - !$OMP parallel do default(shared) - do j=js-1,je+1 ; do i=is-1,ie+1 - depth_tot(i,j) = G%bathyT(i,j) + G%Z_ref - enddo ; enddo + if (GV%Boussinesq) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * GV%Z_to_H + enddo ; enddo + else + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + depth_tot(i,j) = (G%bathyT(i,j) + G%Z_ref) * CS%rho_fixed_total_depth * GV%RZ_to_H + enddo ; enddo + endif else !$OMP parallel do default(shared) do j=js-1,je+1 ; do i=is-1,ie+1 - depth_tot(i,j) = mass(i,j) * I_Rho0 + depth_tot(i,j) = mass(i,j) * GV%RZ_to_H enddo ; enddo endif @@ -369,9 +375,9 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (CS%debug) then if (CS%visc_drag) & call uvchksum("MEKE drag_vel_[uv]", drag_vel_u, drag_vel_v, G%HI, & - scale=US%Z_to_m*US%s_to_T, scalar_pair=.true.) + scale=GV%H_to_mks*US%s_to_T, scalar_pair=.true.) call hchksum(mass, 'MEKE mass',G%HI,haloshift=1, scale=US%RZ_to_kg_m2) - call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=US%L_T_to_m_s) + call hchksum(drag_rate_visc, 'MEKE drag_rate_visc', G%HI, scale=GV%H_to_mks*US%s_to_T) call hchksum(bottomFac2, 'MEKE bottomFac2', G%HI) call hchksum(barotrFac2, 'MEKE barotrFac2', G%HI) call hchksum(LmixScale, 'MEKE LmixScale', G%HI,scale=US%L_to_m) @@ -402,7 +408,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h !$OMP parallel do default(shared) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_GMcoeff*MEKE%GM_src(i,j) / & - (GV%Rho0 * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) + (GV%H_to_RZ * MAX(CS%MEKE_min_depth_tot, depth_tot(i,j))) enddo ; enddo else !$OMP parallel do default(shared) @@ -413,7 +419,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h endif if (CS%MEKE_equilibrium_restoring) then - call MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & + call MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & equilibrium_value) do j=js,je ; do i=is,ie src(i,j) = src(i,j) - CS%MEKE_restoring_rate*(MEKE%MEKE(i,j) - equilibrium_value(i,j)) @@ -434,7 +440,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h ! Calculate a viscous drag rate (includes BBL contributions from mean flow and eddies) !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo else @@ -607,7 +613,7 @@ subroutine step_forward_MEKE(MEKE, h, SN_u, SN_v, visc, dt, G, GV, US, CS, hu, h if (use_drag_rate) then !$OMP parallel do default(shared) do j=js,je ; do i=is,ie - drag_rate(i,j) = (US%L_to_Z*Rho0 * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & + drag_rate(i,j) = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + & cdrag2 * ( max(0.0, 2.0*bottomFac2(i,j)*MEKE%MEKE(i,j)) + CS%MEKE_Uscale**2 ) ) enddo ; enddo endif @@ -753,20 +759,19 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: drag_rate_visc !< Mean flow velocity contribution - !! to the MEKE drag rate [L T-1 ~> m s-1] + !! to the MEKE drag rate [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)), intent(in) :: I_mass !< Inverse of column mass [R-1 Z-1 ~> m2 kg-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. ! Local variables real :: beta ! Combined topographic and planetary vorticity gradient [T-1 L-1 ~> s-1 m-1] real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: bottomFac2, barotrFac2 ! Vertical structure factors [nondim] real :: LmixScale, LRhines, LEady ! Various mixing length scales [L ~> m] - real :: I_H ! The inverse of the total column mass, converted to an inverse horizontal length [L-1 ~> m-1] real :: KhCoeff ! A copy of MEKE_KhCoeff from the control structure [nondim] real :: Kh ! A lateral diffusivity [L2 T-1 ~> m2 s-1] real :: Ubg2 ! Background (tidal?) velocity squared [L2 T-2 ~> m2 s-2] - real :: cd2 ! The square of the drag coefficient [nondim] + real :: cd2 ! The square of the drag coefficient times unit conversion factors [H2 L-2 ~> nondim or kg2 m-6] real :: drag_rate ! The MEKE spindown timescale due to bottom drag [T-1 ~> s-1]. real :: src ! The sum of MEKE sources [L2 T-3 ~> W kg-1] real :: ldamping ! The MEKE damping rate [T-1 ~> s-1]. @@ -774,7 +779,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m real :: resid, ResMin, ResMax ! Residuals [L2 T-3 ~> W kg-1] real :: FatH ! Coriolis parameter at h points; to compute topographic beta [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] - real :: dZ_neglect ! A negligible change in height [Z ~> m] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je, n1, n2 real :: tolerance ! Width of EKE bracket [L2 T-2 ~> m2 s-2]. logical :: useSecant, debugIteration @@ -786,7 +791,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m Ubg2 = CS%MEKE_Uscale**2 cd2 = CS%cdrag**2 tolerance = 1.0e-12*US%m_s_to_L_T**2 - dZ_neglect = GV%H_to_Z*GV%H_subroundoff + h_neglect = GV%H_subroundoff !$OMP do do j=js,je ; do i=is,ie @@ -795,7 +800,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) if (CS%MEKE_equilibrium_alt) then - MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_L*depth_tot(i,j))**2 / cd2 + MEKE%MEKE(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 else FatH = 0.25*((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) + & (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) ! Coriolis parameter at h points @@ -807,21 +812,19 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m !### Consider different combinations of these estimates of topographic beta. beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & - / max(depth_tot(i+1,j), depth_tot(i,j), dZ_neglect) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & - / max(depth_tot(i,j), depth_tot(i-1,j), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & - / max(depth_tot(i,j+1), depth_tot(i,j), dZ_neglect) + & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & - / max(depth_tot(i,j), depth_tot(i,j-1), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) endif beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & (G%dF_dy(i,j) + beta_topo_y)**2 ) - I_H = US%L_to_Z*GV%Rho0 * I_mass(i,j) - - if (KhCoeff*SN*I_H>0.) then + if (KhCoeff*SN*I_mass(i,j)>0.) then ! Solve resid(E) = 0, where resid = Kh(E) * (SN)^2 - damp_rate(E) E EKEmin = 0. ! Use the trivial root as the left bracket ResMin = 0. ! Need to detect direction of left residual @@ -839,7 +842,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! TODO: Should include resolution function in Kh Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) src = Kh * (SN * SN) - drag_rate = I_H * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt(drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) ldamping = CS%MEKE_damping + drag_rate * bottomFac2 resid = src - ldamping * EKE ! if (debugIteration) then @@ -879,7 +882,7 @@ subroutine MEKE_equilibrium(CS, MEKE, G, GV, US, SN_u, SN_v, drag_rate_visc, I_m ! TODO: Should include resolution function in Kh Kh = (KhCoeff * sqrt(2.*barotrFac2*EKE) * LmixScale) src = Kh * (SN * SN) - drag_rate = I_H * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) + drag_rate = (GV%H_to_RZ * I_mass(i,j)) * sqrt( drag_rate_visc(i,j)**2 + cd2 * ( 2.0*bottomFac2*EKE + Ubg2 ) ) ldamping = CS%MEKE_damping + drag_rate * bottomFac2 resid = src - ldamping * EKE if (useSecant .and. resid>ResMin) useSecant = .false. @@ -908,14 +911,15 @@ end subroutine MEKE_equilibrium !< This subroutine calculates a new equilibrium value for MEKE at each time step. This is not copied into !! MEKE%MEKE; rather, it is used as a restoring term to nudge MEKE%MEKE back to an equilibrium value -subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & +subroutine MEKE_equilibrium_restoring(CS, G, GV, US, SN_u, SN_v, depth_tot, & equilibrium_value) type(ocean_grid_type), intent(inout) :: G !< Ocean grid. + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type. type(MEKE_CS), intent(in) :: CS !< MEKE control structure. real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: equilibrium_value !< Equilbrium value of MEKE to be calculated at each time step [L2 T-2 ~> m2 s-2] @@ -933,7 +937,7 @@ subroutine MEKE_equilibrium_restoring(CS, G, US, SN_u, SN_v, depth_tot, & ! SN = 0.25*max( (SN_u(I,j) + SN_u(I-1,j)) + (SN_v(i,J) + SN_v(i,J-1)), 0.) ! This avoids extremes values in equilibrium solution due to bad values in SN_u, SN_v SN = min(SN_u(I,j), SN_u(I-1,j), SN_v(i,J), SN_v(i,J-1)) - equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * US%Z_to_L*depth_tot(i,j))**2 / cd2 + equilibrium_value(i,j) = (CS%MEKE_GEOMETRIC_alpha * SN * depth_tot(i,j))**2 / cd2 enddo ; enddo if (CS%id_MEKE_equilibrium>0) call post_data(CS%id_MEKE_equilibrium, equilibrium_value, CS%diag) @@ -952,7 +956,7 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: SN_u !< Eady growth rate at u-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJB_(G)), intent(in) :: SN_v !< Eady growth rate at v-points [T-1 ~> s-1]. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The depth of the water column [Z ~> m]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: depth_tot !< The thickness of the water column [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: bottomFac2 !< gamma_b^2 [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: barotrFac2 !< gamma_t^2 [nondim] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: LmixScale !< Eddy mixing length [L ~> m]. @@ -962,11 +966,11 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & real :: SN ! The local Eady growth rate [T-1 ~> s-1] real :: FatH ! Coriolis parameter at h points [T-1 ~> s-1] real :: beta_topo_x, beta_topo_y ! Topographic PV gradients in x and y [T-1 L-1 ~> s-1 m-1] - real :: dZ_neglect ! A negligible change in height [Z ~> m] + real :: h_neglect ! A negligible thickness [H ~> m or kg m-2] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - dZ_neglect = GV%H_to_Z*GV%H_subroundoff + h_neglect = GV%H_subroundoff !$OMP do do j=js,je ; do i=is,ie @@ -988,14 +992,14 @@ subroutine MEKE_lengthScales(CS, MEKE, G, GV, US, SN_u, SN_v, EKE, depth_tot, & !### Consider different combinations of these estimates of topographic beta. beta_topo_x = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i+1,j)-depth_tot(i,j)) * G%IdxCu(I,j) & - / max(depth_tot(i+1,j), depth_tot(i,j), dZ_neglect) & + / max(depth_tot(i+1,j), depth_tot(i,j), h_neglect) & + (depth_tot(i,j)-depth_tot(i-1,j)) * G%IdxCu(I-1,j) & - / max(depth_tot(i,j), depth_tot(i-1,j), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i-1,j), h_neglect) ) beta_topo_y = -CS%MEKE_topographic_beta * FatH * 0.5 * ( & (depth_tot(i,j+1)-depth_tot(i,j)) * G%IdyCv(i,J) & - / max(depth_tot(i,j+1), depth_tot(i,j), dZ_neglect) + & + / max(depth_tot(i,j+1), depth_tot(i,j), h_neglect) + & (depth_tot(i,j)-depth_tot(i,j-1)) * G%IdyCv(i,J-1) & - / max(depth_tot(i,j), depth_tot(i,j-1), dZ_neglect) ) + / max(depth_tot(i,j), depth_tot(i,j-1), h_neglect) ) endif beta = sqrt((G%dF_dx(i,j) + beta_topo_x)**2 + & (G%dF_dy(i,j) + beta_topo_y)**2 ) @@ -1017,13 +1021,13 @@ end subroutine MEKE_lengthScales !> Calculates the eddy mixing length scale and \f$\gamma_b\f$ and \f$\gamma_t\f$ !! functions that are ratios of either bottom or barotropic eddy energy to the !! column eddy energy, respectively. See \ref section_MEKE_equations. -subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & +subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth_tot, Rd_dx, SN, EKE, & bottomFac2, barotrFac2, LmixScale, Lrhines, Leady) type(MEKE_CS), intent(in) :: CS !< MEKE control structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, intent(in) :: area !< Grid cell area [L2 ~> m2] real, intent(in) :: beta !< Planetary beta = \f$ \nabla f\f$ [T-1 L-1 ~> s-1 m-1] - real, intent(in) :: depth !< Ocean depth [Z ~> m] + real, intent(in) :: depth_tot !< The total thickness of the water column [H ~> m or kg m-2] real, intent(in) :: Rd_dx !< Resolution Ld/dx [nondim]. real, intent(in) :: SN !< Eady growth rate [T-1 ~> s-1]. real, intent(in) :: EKE !< Eddy kinetic energy [L2 T-2 ~> m2 s-2]. @@ -1039,7 +1043,7 @@ subroutine MEKE_lengthScales_0d(CS, US, area, beta, depth, Rd_dx, SN, EKE, & ! Length scale for MEKE derived diffusivity Lgrid = sqrt(area) ! Grid scale Ldeform = Lgrid * Rd_dx ! Deformation scale - Lfrict = (US%Z_to_L * depth) / CS%cdrag ! Frictional arrest scale + Lfrict = depth_tot / CS%cdrag ! Frictional arrest scale ! gamma_b^2 is the ratio of bottom eddy energy to mean column eddy energy ! used in calculating bottom drag bottomFac2 = CS%MEKE_CD_SCALE**2 @@ -1248,7 +1252,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME call get_param(param_file, mdl, "MEKE_MIN_DEPTH_TOT", CS%MEKE_min_depth_tot, & "The minimum total depth over which to distribute MEKE energy sources. "//& "When the total depth is less than this, the sources are scaled away.", & - units="m", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%GM_src_alt) + units="m", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%GM_src_alt) call get_param(param_file, mdl, "MEKE_VISC_DRAG", CS%visc_drag, & "If true, use the vertvisc_type to calculate the bottom "//& "drag acting on MEKE.", default=.true.) @@ -1296,6 +1300,11 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "If true, use the nominal bathymetric depth as the estimate of the "//& "time-varying ocean depth. Otherwise base the depth on the total ocean mass"//& "per unit area.", default=.true.) + call get_param(param_file, mdl, "MEKE_TOTAL_DEPTH_RHO", CS%rho_fixed_total_depth, & + "A density used to translate the nominal bathymetric depth into an estimate "//& + "of the total ocean mass per unit area when MEKE_FIXED_TOTAL_DEPTH is true.", & + units="kg m-3", default=GV%Rho0*US%R_to_kg_m3, scale=US%kg_m3_to_R, & + do_not_log=(GV%Boussinesq.or.(.not.CS%fixed_total_depth))) call get_param(param_file, mdl, "MEKE_ALPHA_DEFORM", CS%aDeform, & "If positive, is a coefficient weighting the deformation scale "//& @@ -1348,7 +1357,7 @@ logical function MEKE_init(Time, G, GV, US, param_file, diag, dbcomms_CS, CS, ME "field to the bottom stress.", units="nondim", default=0.003) call get_param(param_file, mdl, "MEKE_CDRAG", CS%cdrag, & "Drag coefficient relating the magnitude of the velocity "//& - "field to the bottom stress in MEKE.", units="nondim", default=cdrag) + "field to the bottom stress in MEKE.", units="nondim", default=cdrag, scale=US%L_to_m*GV%m_to_H) call get_param(param_file, mdl, "LAPLACIAN", laplacian, default=.false., do_not_log=.true.) call get_param(param_file, mdl, "BIHARMONIC", biharmonic, default=.false., do_not_log=.true.) From d342b296fbaa94776cbbe3df1db131b3e10edb54 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 17 Aug 2023 16:12:00 -0400 Subject: [PATCH 414/629] CI: Run test (and test.summary) locally The test.summary rule was causing errors in our Gitlab testing due to multiple runs (concurrent or otherwise) in the same workspace directory. This patch removes the WORKSPACE directory variable, and each .testing run happens in its own directory. Other minor changes: - The script to generate the summary was moved out of the Makefile and into a separate script. - Unrelated to these changes, error output was extended from 20 to 40 lines, to provide more readable backtrace output. --- .gitlab-ci.yml | 13 ++++----- .testing/Makefile | 33 +++++---------------- .testing/tools/report_test_results.sh | 42 +++++++++++++++++++++++++++ 3 files changed, 55 insertions(+), 33 deletions(-) create mode 100755 .testing/tools/report_test_results.sh diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 6be281c8cd..5bc90daca4 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -10,7 +10,6 @@ stages: # We use the "fetch" strategy to speed up the startup of stages variables: JOB_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" - WORKSPACE: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/$CI_RUNNER_ID" GIT_STRATEGY: fetch # Always eport value of $JOB_DIR @@ -185,9 +184,9 @@ actions:gnu: - 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=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 + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh + - 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 test -s + - make test.summary actions:intel: stage: tests @@ -205,9 +204,9 @@ actions:intel: - 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=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 + - (echo '#!/bin/bash';echo 'make MPIRUN="srun -mblock --exclusive" test -s -j') > job.sh + - 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 test -s + - make test.summary # Tests # diff --git a/.testing/Makefile b/.testing/Makefile index b877ecb5f2..d6b06893fe 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -554,8 +554,8 @@ $(WORKSPACE)/work/%/$(1)/ocean.stats $(WORKSPACE)/work/%/$(1)/chksum_diag: build && $(TIME) $(5) $(MPIRUN) -n $(6) $(abspath $$<) 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ - cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 20 ; \ - cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 20 ; \ + cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 40 ; \ + cat std.err | tee ../../../results/$$*/std.$(1).err | tail -n 40 ; \ rm ocean.stats chksum_diag ; \ echo -e "$(FAIL): $$*.$(1) failed at runtime." \ ) @@ -630,8 +630,8 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Run the first half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ || !( \ - cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 20 ; \ - cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 20 ; \ + cat std1.out | tee ../../../results/$*/std.restart1.out | tail -n 40 ; \ + cat std1.err | tee ../../../results/$*/std.restart1.err | tail -n 40 ; \ echo -e "$(FAIL): $*.restart failed at runtime." \ ) # Setup the next inputs @@ -641,8 +641,8 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Run the second half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std2.err > std2.out \ || !( \ - cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 20 ; \ - cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 20 ; \ + cat std2.out | tee ../../../results/$*/std.restart2.out | tail -n 40 ; \ + cat std2.err | tee ../../../results/$*/std.restart2.err | tail -n 40 ; \ echo -e "$(FAIL): $*.restart failed at runtime." \ ) @@ -652,26 +652,7 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @if ls $(WORKSPACE)/results/*/* &> /dev/null; then \ - if ls $(WORKSPACE)/results/*/std.*.err &> /dev/null; then \ - echo "The following tests failed to complete:" ; \ - ls $(WORKSPACE)/results/*/std.*.out \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ - fi; \ - if ls $(WORKSPACE)/results/*/ocean.stats.*.diff &> /dev/null; then \ - echo "The following tests report solution regressions:" ; \ - ls $(WORKSPACE)/results/*/ocean.stats.*.diff \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[3]; if(length(t)>4) v=v"."t[4]; print a[2],":",v}'; \ - fi; \ - if ls $(WORKSPACE)/results/*/chksum_diag.*.diff &> /dev/null; then \ - echo "The following tests report diagnostic regressions:" ; \ - ls $(WORKSPACE)/results/*/chksum_diag.*.diff \ - | awk '{split($$0,a,"/"); split(a[3],t,"."); v=t[2]; if(length(t)>3) v=v"."t[3]; print a[2],":",v}'; \ - fi; \ - false ; \ - else \ - echo -e "$(PASS): All tests passed!"; \ - fi + @./tools/report_test_results.sh $(WORKSPACE)/results #--- diff --git a/.testing/tools/report_test_results.sh b/.testing/tools/report_test_results.sh new file mode 100755 index 0000000000..24bab45507 --- /dev/null +++ b/.testing/tools/report_test_results.sh @@ -0,0 +1,42 @@ +#!/bin/sh +RESULTS=${1:-${PWD}/results} + +GREEN="\033[0;32m" +RESET="\033[0m" +PASS="${GREEN}PASS${RESET}" + +if [ -d ${RESULTS} ]; then + if ls ${RESULTS}/*/std.*.err &> /dev/null; then + echo "The following tests failed to complete:" + ls ${RESULTS}/*/std.*.out \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/ocean.stats.*.diff &> /dev/null; then + echo "The following tests report solution regressions:" + ls ${RESULTS}/*/ocean.stats.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[3]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + if ls ${RESULTS}/*/chksum_diag.*.diff &> /dev/null; then + echo "The following tests report diagnostic regressions:" + ls ${RESULTS}/*/chksum_diag.*.diff \ + | awk '{ \ + split($$0,a,"/"); \ + split(a[length(a)],t,"."); \ + v=t[2]; \ + if(length(t)>4) v=v"."t[4]; print a[length(a)-1],":",v}' + fi + + exit 1 +else + printf "${PASS}: All tests passed!\n" +fi From 9de6ce74d3d52882dcf1cfa69d5f2834d5610ed4 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 13 Jul 2023 11:03:15 -0400 Subject: [PATCH 415/629] New TIDAL_SAL_FLATHER option - This option is defaulted to False to retain previous answers, but should be set to True for new experiments in order to make the Flather OBC routine consistent with the barotropic solver - This option only applies for regional OBC cases with Tides and scalar self-attraction and loading + Try at fixing issue #476 - Will change answers for problems with OBCs. - Get Matt's patch to compile again Co-authored-by: Kate Hedstrom --- docs/zotero.bib | 13 +++++++++++++ src/core/MOM.F90 | 1 + src/core/MOM_barotropic.F90 | 33 +++++++++++++++++++++++++++------ 3 files changed, 41 insertions(+), 6 deletions(-) diff --git a/docs/zotero.bib b/docs/zotero.bib index 5acaee968a..c0f1ddccbb 100644 --- a/docs/zotero.bib +++ b/docs/zotero.bib @@ -2747,3 +2747,16 @@ @article{Nguyen2009 title = {Improved modeling of the Arctic halocline with a subgrid-scale brine rejection parameterization}, pages = {C11014} } + +@article{Adcroft2019, + doi = {10.1029/2019ms001726}, + year = 2019, + publisher = {American Geophysical Union ({AGU})}, + volume = {11}, + number = {10}, + pages = {3167--3211}, + author = {A. Adcroft and W. Anderson and V. Balaji and C. Blanton and M. Bushuk and C. O. Dufour and J. P. Dunne and S. M. Griffies and R. Hallberg and M. J. Harrison and I. M. Held and M. F. Jansen and J. G. John and J. P. Krasting and A. R. Langenhorst and S. Legg and Z. Liang and C. McHugh and A. Radhakrishnan and B. G. Reichl and T. Rosati and B. L. Samuels and A. Shao and R. Stouffer and M. Winton and A. T. Wittenberg and B. Xiang and N. Zadeh and R. Zhang}, + title = {The {GFDL} Global Ocean and Sea Ice Model {OM}4.0: Model Description and Simulation Features}, + journal = {J. Adv. Mod. Earth Sys.} +} + diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d112de07b7..3013729109 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1619,6 +1619,7 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) if (associated(CS%OBC)) & + call pass_var(h_new, G%Domain) call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index e6f243a11c..4c600d37d2 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -279,6 +279,9 @@ module MOM_barotropic logical :: use_old_coriolis_bracket_bug !< If True, use an order of operations !! that is not bitwise rotationally symmetric in the !! meridional Coriolis term of the barotropic solver. + logical :: tidal_sal_flather !< Apply adjustment to external gravity wave speed + !! consistent with tidal self-attraction and loading + !! used within the barotropic solver type(time_type), pointer :: Time => NULL() !< A pointer to the ocean models clock. type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate !! the timing of diagnostic output. @@ -1122,8 +1125,13 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set up fields related to the open boundary conditions. if (apply_OBCs) then - call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + if (CS%TIDAL_SAL_FLATHER) then + call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + else + call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & + integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + endif endif ! Determine the difference between the sum of the layer fluxes and the @@ -3101,7 +3109,7 @@ end subroutine apply_velocity_OBCs !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & - integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v) + integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. @@ -3132,9 +3140,11 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - + real, intent(in), optional :: dgeo_de !< The constant of proportionality between + !! geopotential and sea surface height [nondim]. ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. + real :: dgeo_de_in !< The constant of proportionality between geopotential and sea surface height [nondim]. integer :: i, j, k, is, ie, js, je, n, nz integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB integer :: isdw, iedw, jsdw, jedw @@ -3152,6 +3162,9 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B "yet fully implemented with wide barotropic halos.") endif + dgeo_de_in = 1.0 + if (PRESENT(dgeo_de)) dgeo_de_in = dgeo_de + if (.not. BT_OBC%is_alloced) then allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%H_u(isdw-1:iedw,jsdw:jedw), source=0.0) @@ -3210,7 +3223,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B BT_OBC%H_u(I,j) = eta(i+1,j) endif endif - BT_OBC%Cg_u(I,j) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) endif endif ; enddo ; enddo if (OBC%Flather_u_BCs_exist_globally) then @@ -3264,7 +3277,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B BT_OBC%H_v(i,J) = eta(i,j+1) endif endif - BT_OBC%Cg_v(i,J) = SQRT(GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -4520,6 +4533,14 @@ subroutine barotropic_init(u, v, h, eta, Time, G, GV, US, param_file, diag, CS, "solver has the wrong sign, replicating a long-standing bug with a scalar "//& "self-attraction and loading term or the SAL term from a previous simulation.", & default=.false., do_not_log=(det_de==0.0)) + call get_param(param_file, mdl, "TIDAL_SAL_FLATHER", CS%tidal_sal_flather, & + "If true, then apply adjustments to the external gravity "//& + "wave speed used with the Flather OBC routine consistent "//& + "with the barotropic solver. This applies to cases with "//& + "tidal forcing using the scalar self-attraction approximation. "//& + "The default is currently False in order to retain previous answers "//& + "but should be set to True for new experiments", default=.false.) + call get_param(param_file, mdl, "SADOURNY", CS%Sadourny, & "If true, the Coriolis terms are discretized with the "//& "Sadourny (1975) energy conserving scheme, otherwise "//& From 25b57f475adc648e2f69abb59a6ff875b59063e3 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 5 Sep 2023 22:53:17 -0400 Subject: [PATCH 416/629] makedep: Support externals alongside program units The current version of makedep uses the existence of program units (module or program) to determine whether a file contains globally accessible external functions. It incorrectly ignores files with externals it happens to contain both externals and a program unit. We resolve this by tracking whether we are inside or outside of a program unit while parsing each line. We ignore keywords which may appear in comments, as well as tokens which may contain `function` or `subroutine` as substrings. This method is not perfect; there are cases which will incorrectly report entering a block, but this method appears sufficient for all of our known codebases. This issue was detected when attempting to parse the AM2 source. While still far from a general solution, it is sufficient to handle a few of the more challenging cases encountered in AM2. --- ac/makedep | 45 +++++++++++++++++++++++++++++++++++++++------ 1 file changed, 39 insertions(+), 6 deletions(-) diff --git a/ac/makedep b/ac/makedep index 225a241b93..502250020b 100755 --- a/ac/makedep +++ b/ac/makedep @@ -16,6 +16,13 @@ re_use = re.compile(r"^ *use +([a-z_0-9]+)") re_cpp_include = re.compile(r"^ *# *include *[<\"']([a-zA-Z_0-9\.]+)[>\"']") re_f90_include = re.compile(r"^ *include +[\"']([a-zA-Z_0-9\.]+)[\"']") re_program = re.compile(r"^ *[pP][rR][oO][gG][rR][aA][mM] +([a-zA-Z_0-9]+)") +re_end = re.compile(r"^ *end *(module|procedure) ", re.IGNORECASE) +# NOTE: This excludes comments and tokens with substrings containing `function` +# or `subroutine`, but will fail if the keywords appear in other contexts. +re_procedure = re.compile( + r"^[^!]*(? 0: for h in cpp+inc: if h not in hlst and h in f2F.keys(): @@ -258,25 +266,49 @@ def scan_fortran_file(src_file): module_decl, used_modules, cpp_includes, f90_includes, programs = [], [], [], [], [] with io.open(src_file, 'r', errors='replace') as file: lines = file.readlines() + + external_namespace = True + + file_has_externals = False + for line in lines: match = re_module.match(line.lower()) if match: if match.group(1) not in 'procedure': # avoid "module procedure" statements module_decl.append(match.group(1)) + external_namespace = False + match = re_use.match(line.lower()) if match: used_modules.append(match.group(1)) + match = re_cpp_include.match(line) if match: cpp_includes.append(match.group(1)) + match = re_f90_include.match(line) if match: f90_includes.append(match.group(1)) + match = re_program.match(line) if match: programs.append(match.group(1)) + external_namespace = False + + match = re_end.match(line) + if match: + external_namespace = True + + # Check for any external procedures; if present, flag the file + # as a potential source of + # NOTE: This a very weak test that needs further modification + if external_namespace and not file_has_externals: + match = re_procedure.match(line) + if match: + file_has_externals = True + used_modules = [m for m in sorted(set(used_modules)) if m not in module_decl] - return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs + return add_suff(module_decl, '.mod'), add_suff(used_modules, '.mod'), cpp_includes, f90_includes, programs, file_has_externals # return add_suff(module_decl, '.mod'), add_suff(sorted(set(used_modules)), '.mod'), cpp_includes, f90_includes, programs @@ -297,8 +329,9 @@ def find_files(src_dirs): for file in f: # TODO: use any() if (file.endswith('.F90') or file.endswith('.f90') + or file.endswith('.f') or file.endswith('.F') or file.endswith('.h') or file.endswith('.inc') - or file.endswith('.c')): + or file.endswith('.c') or file.endswith('.H')): files.append(p+'/'+file) return sorted(set(files)) From d363034fcc99eef960889b613b4144df8d8eea5a Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Tue, 12 Sep 2023 10:37:27 -0600 Subject: [PATCH 417/629] Deprecate mct cap (#257) * Move mct_cap/ to STALE_mct_cap/. mct cap is no longer supported and will soon be removed for good. * remove mct from CI testing * Remove mct test from github workflows --- .github/workflows/coupled-api.yml | 4 ---- .testing/Makefile | 7 ------- .../{mct_cap => STALE_mct_cap}/mom_ocean_model_mct.F90 | 0 .../{mct_cap => STALE_mct_cap}/mom_surface_forcing_mct.F90 | 0 .../drivers/{mct_cap => STALE_mct_cap}/ocn_cap_methods.F90 | 0 .../drivers/{mct_cap => STALE_mct_cap}/ocn_comp_mct.F90 | 0 .../drivers/{mct_cap => STALE_mct_cap}/ocn_cpl_indices.F90 | 0 7 files changed, 11 deletions(-) rename config_src/drivers/{mct_cap => STALE_mct_cap}/mom_ocean_model_mct.F90 (100%) rename config_src/drivers/{mct_cap => STALE_mct_cap}/mom_surface_forcing_mct.F90 (100%) rename config_src/drivers/{mct_cap => STALE_mct_cap}/ocn_cap_methods.F90 (100%) rename config_src/drivers/{mct_cap => STALE_mct_cap}/ocn_comp_mct.F90 (100%) rename config_src/drivers/{mct_cap => STALE_mct_cap}/ocn_cpl_indices.F90 (100%) diff --git a/.github/workflows/coupled-api.yml b/.github/workflows/coupled-api.yml index 4a07c0b639..2d99b45967 100644 --- a/.github/workflows/coupled-api.yml +++ b/.github/workflows/coupled-api.yml @@ -28,7 +28,3 @@ jobs: - name: Compile MOM6 for the NUOPC driver shell: bash run: make check_mom6_api_nuopc -j - - - name: Compile MOM6 for the MCT driver - shell: bash - run: make check_mom6_api_mct -j diff --git a/.testing/Makefile b/.testing/Makefile index b877ecb5f2..942f44d4c3 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -255,7 +255,6 @@ build/opt/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) build/opt_target/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) build/coupled/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/nuopc/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/mct/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/cov/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) build/unit/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) @@ -269,7 +268,6 @@ build/opt/Makefile: MOM_ACFLAGS= build/opt_target/Makefile: MOM_ACFLAGS= build/coupled/Makefile: MOM_ACFLAGS=--with-driver=FMS_cap build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_cap -build/mct/Makefile: MOM_ACFLAGS=--with-driver=mct_cap build/cov/Makefile: MOM_ACFLAGS= build/unit/Makefile: MOM_ACFLAGS=--with-driver=unit_tests @@ -370,11 +368,6 @@ build/coupled/ocean_model_MOM.o: build/coupled/Makefile cd $(@D) && make $(@F) check_mom6_api_coupled: build/coupled/ocean_model_MOM.o -# MCT driver -build/mct/mom_ocean_model_mct.o: build/mct/Makefile - cd $(@D) && make $(@F) -check_mom6_api_mct: build/mct/mom_ocean_model_mct.o - #--- # Testing diff --git a/config_src/drivers/mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 similarity index 100% rename from config_src/drivers/mct_cap/mom_ocean_model_mct.F90 rename to config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 diff --git a/config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 similarity index 100% rename from config_src/drivers/mct_cap/mom_surface_forcing_mct.F90 rename to config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 diff --git a/config_src/drivers/mct_cap/ocn_cap_methods.F90 b/config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 similarity index 100% rename from config_src/drivers/mct_cap/ocn_cap_methods.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cap_methods.F90 diff --git a/config_src/drivers/mct_cap/ocn_comp_mct.F90 b/config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 similarity index 100% rename from config_src/drivers/mct_cap/ocn_comp_mct.F90 rename to config_src/drivers/STALE_mct_cap/ocn_comp_mct.F90 diff --git a/config_src/drivers/mct_cap/ocn_cpl_indices.F90 b/config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 similarity index 100% rename from config_src/drivers/mct_cap/ocn_cpl_indices.F90 rename to config_src/drivers/STALE_mct_cap/ocn_cpl_indices.F90 From a2c3ec76e87645c9cf6ac9e8fe361385321e022b Mon Sep 17 00:00:00 2001 From: bzhao Date: Mon, 11 Sep 2023 14:24:07 -0400 Subject: [PATCH 418/629] add extracting c grid currents --- config_src/drivers/FMS_cap/ocean_model_MOM.F90 | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 index 005e3a6723..ca2305ea71 100644 --- a/config_src/drivers/FMS_cap/ocean_model_MOM.F90 +++ b/config_src/drivers/FMS_cap/ocean_model_MOM.F90 @@ -1201,6 +1201,14 @@ subroutine ocean_model_get_UV_surf(OS, Ocean, name, array2D, isc, jsc) array2D(i,j) = G%mask2dBu(I+i0,J+j0) * & 0.5*(sfc_state%v(i+i0,J+j0)+sfc_state%v(i+i0+1,J+j0)) enddo ; enddo + case('uc') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dCu(I+i0,J+j0) * sfc_state%u(I+i0,j+j0) + enddo ; enddo + case('vc') + do j=jsc_bnd,jec_bnd ; do i=isc_bnd,iec_bnd + array2D(i,j) = G%mask2dCv(I+i0,J+j0) * sfc_state%v(i+i0,J+j0) + enddo ; enddo case default call MOM_error(FATAL,'ocean_model_get_UV_surf: unknown argument name='//name) end select From abb0ad24f6c873c06899ed166b291090638911f3 Mon Sep 17 00:00:00 2001 From: Denise Worthen Date: Thu, 14 Sep 2023 11:03:48 -0400 Subject: [PATCH 419/629] switch to cesm-style field names * two fields remain unresolved, sea_level and mass_overlying_ice --- config_src/drivers/nuopc_cap/mom_cap.F90 | 158 ++++++++-------- .../drivers/nuopc_cap/mom_cap_methods.F90 | 179 +++++++++--------- 2 files changed, 171 insertions(+), 166 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 71419ea4bf..135e7bab6b 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -724,40 +724,37 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) call fld_list_add(fldsFrOcn_num, fldsFrOcn, trim(scalar_field_name), "will_provide") endif - !--------- import fields ------------- - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_salt_rate" , "will provide") ! from ice - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_zonal_moment_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_merid_moment_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_sensi_heat_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_evap_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_lw_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_vis_dir_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_vis_dif_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_ir_dir_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_net_sw_ir_dif_flx" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_prec_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fprec_rate" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "inst_pres_height_surface" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff - call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff - call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac" , "will provide") !-> ice fraction - call fld_list_add(fldsToOcn_num, fldsToOcn, "So_duu10n" , "will provide") !-> wind^2 at 10m - call fld_list_add(fldsToOcn_num, fldsToOcn, "mean_fresh_water_to_ocean_rate", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "net_heat_flx_to_ocn" , "will provide") - - if (cesm_coupled) then - call fld_list_add(fldsToOcn_num, fldsToOcn, "heat_content_lprec", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "heat_content_fprec", "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "heat_content_evap" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "heat_content_cond" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "heat_content_rofl" , "will provide") - call fld_list_add(fldsToOcn_num, fldsToOcn, "heat_content_rofi" , "will provide") - endif + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_salt" , "will provide") ! from ice + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_taux" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_tauy" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_sen" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_evap" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_lwnet" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_vdr" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_vdf" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_idr" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_swnet_idf" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_rain" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Faxa_snow" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sa_pslv" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofl" , "will provide") !-> liquid runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_rofi" , "will provide") !-> ice runoff + call fld_list_add(fldsToOcn_num, fldsToOcn, "Si_ifrac" , "will provide") !-> ice fraction + call fld_list_add(fldsToOcn_num, fldsToOcn, "So_duu10n" , "will provide") !-> wind^2 at 10m + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_meltw" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Fioi_melth" , "will provide") + + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrain" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hsnow" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hevap" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hcond" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofl" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Foxx_hrofi" , "will provide") if (use_waves) then if (wave_method == "EFACTOR") then - call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") + call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_lamult" , "will provide") else if (wave_method == "SURFACE_BANDS") then call fld_list_add(fldsToOcn_num, fldsToOcn, "Sw_pstokes_x", "will provide", & ungridded_lbound=1, ungridded_ubound=Ice_ocean_boundary%num_stk_bands) @@ -769,15 +766,15 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) endif !--------- export fields ------------- - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocean_mask" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_temperature" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "s_surf" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocn_current_zonal" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "ocn_current_merid" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_slope_zonal" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "sea_surface_slope_merid" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "freezing_melting_potential" , "will provide") - call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_omask" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_t" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_s" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_u" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_v" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdx" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_dhdy" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "Fioo_q" , "will provide") + call fld_list_add(fldsFrOcn_num, fldsFrOcn, "So_bldepth" , "will provide") do n = 1,fldsToOcn_num call NUOPC_Advertise(importState, standardName=fldsToOcn(n)%stdname, name=fldsToOcn(n)%shortname, rc=rc) @@ -1627,7 +1624,7 @@ subroutine ModelAdvance(gcomp, rc) ! Import data !--------------- - call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, cesm_coupled, rc=rc) + call mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !--------------- @@ -2433,7 +2430,7 @@ end subroutine shr_log_setLogUnit !! Description !! Notes !! -!! inst_pres_height_surface +!! Sa_pslv !! Pa !! p !! pressure of overlying sea ice and atmosphere @@ -2447,14 +2444,14 @@ end subroutine shr_log_setLogUnit !! !! !! -!! seaice_melt_heat +!! Fioi_melth !! W m-2 !! seaice_melt_heat !! sea ice and snow melt heat flux !! !! !! -!! seaice_melt +!! Fioi_meltw !! kg m-2 s-1 !! seaice_melt !! water flux due to sea ice and snow melting @@ -2468,138 +2465,145 @@ end subroutine shr_log_setLogUnit !! !! !! -!! mean_evap_rate +!! Foxx_evap !! kg m-2 s-1 !! q_flux !! specific humidity flux !! !! !! -!! mean_fprec_rate +!! Faxa_snow !! kg m-2 s-1 !! fprec !! mass flux of frozen precip !! !! !! -!! mean_merid_moment_flx -!! Pa -!! v_flux -!! j-directed wind stress into ocean -!! [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar -!! -!! -!! mean_net_lw_flx +!! Foxx_lwnet !! W m-2 !! lw_flux !! long wave radiation !! !! !! -!! mean_net_sw_ir_dif_flx +!! Foxx_swnet_idf !! W m-2 !! sw_flux_nir_dif !! diffuse near IR shortwave radiation !! !! !! -!! mean_net_sw_ir_dir_flx +!! Foxx_swnet_idr !! W m-2 !! sw_flux_nir_dir !! direct near IR shortwave radiation !! !! !! -!! mean_net_sw_vis_dif_flx +!! Foxx_swnet_vdf !! W m-2 !! sw_flux_vis_dif !! diffuse visible shortware radiation !! !! !! -!! mean_net_sw_vis_dir_flx +!! Foxx_swnet_idr !! W m-2 !! sw_flux_vis_dir !! direct visible shortware radiation !! !! !! -!! mean_prec_rate +!! Faxa_rain !! kg m-2 s-1 !! lprec !! mass flux of liquid precip !! !! !! -!! heat_content_lprec +!! Foxx_hrain !! W m-2 !! hrain !! heat content (enthalpy) of liquid water entering the ocean !! !! !! -!! heat_content_fprec +!! Foxx_hsnow !! W m-2 !! hsnow !! heat content (enthalpy) of frozen water entering the ocean !! !! !! -!! heat_content_evap +!! Foxx_hevap !! W m-2 !! hevap !! heat content (enthalpy) of water leaving the ocean !! !! !! -!! heat_content_cond +!! Foxx_hcond !! W m-2 !! hcond !! heat content (enthalpy) of liquid water entering the ocean due to condensation !! !! !! -!! heat_content_rofl +!! Foxx_hrofl !! W m-2 !! hrofl !! heat content (enthalpy) of liquid runoff !! !! !! -!! heat_content_rofi +!! Foxx_hrofi !! W m-2 !! hrofi !! heat content (enthalpy) of frozen runoff !! !! !! -!! mean_runoff_rate +!! Foxx_rofl !! kg m-2 s-1 !! runoff !! mass flux of liquid runoff !! !! !! -!! mean_salt_rate +!! Foxx_rofi +!! kg m-2 s-1 +!! runoff +!! mass flux of frozen runoff +!! +!! +!! +!! Fioi_salt !! kg m-2 s-1 !! salt_flux !! salt flux !! !! !! -!! mean_sensi_heat_flx +!! Foxx_sen !! W m-2 !! t_flux !! sensible heat flux into ocean !! !! !! -!! mean_zonal_moment_flx +!! Foxx_taux !! Pa !! u_flux !! i-directed wind stress into ocean !! [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar !! +!! +!! Foxx_tauy +!! Pa +!! v_flux +!! j-directed wind stress into ocean +!! [vector rotation] (@ref VectorRotations) applied - lat-lon to tripolar +!! !! !! !! @subsection ExportField Export Fields @@ -2616,63 +2620,63 @@ end subroutine shr_log_setLogUnit !! Notes !! !! -!! freezing_melting_potential +!! Fioo_q !! W m-2 !! combination of frazil and melt_potential !! cap converts model units (J m-2) to (W m-2) for export !! !! !! -!! ocean_mask +!! So_omask !! !! !! ocean mask !! !! !! -!! ocn_current_merid +!! So_v !! m s-1 !! v_surf !! j-directed surface velocity on u-cell !! [vector rotation] (@ref VectorRotations) applied - tripolar to lat-lon !! !! -!! ocn_current_zonal +!! So_u !! m s-1 !! u_surf !! i-directed surface velocity on u-cell !! [vector rotation] (@ref VectorRotations) applied - tripolar to lat-lon !! !! -!! s_surf +!! So_s !! psu !! s_surf !! sea surface salinity on t-cell !! !! !! -!! sea_surface_temperature +!! So_t !! K !! t_surf !! sea surface temperature on t-cell !! !! !! -!! sea_surface_slope_zonal +!! So_dhdx !! unitless !! created from ssh !! sea surface zonal slope !! !! !! -!! sea_surface_slope_merid +!! So_dhy !! unitless !! created from ssh !! sea surface meridional slope !! !! !! -!! so_bldepth +!! So_bldepth !! m !! obld !! ocean surface boundary layer depth diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index db8bc33c90..f41c98b112 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -72,12 +72,11 @@ end subroutine mom_set_geomtype !> This function has a few purposes: !! (1) it imports surface fluxes using data from the mediator; and !! (2) it can apply restoring in SST and SSS. -subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, cesm_coupled, rc) +subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, rc) type(ocean_public_type) , intent(in) :: ocean_public !< Ocean surface state type(ocean_grid_type) , intent(in) :: ocean_grid !< Ocean model grid type(ESMF_State) , intent(inout) :: importState !< incoming data from mediator type(ice_ocean_boundary_type) , intent(inout) :: ice_ocean_boundary !< Ocean boundary forcing - logical , intent(in) :: cesm_coupled !< Flag to check if coupled with cesm integer , intent(inout) :: rc !< Return code ! Local Variables @@ -103,43 +102,42 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- ! surface height pressure !---- - call state_getimport(importState, 'inst_pres_height_surface', & - isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) + call state_getimport(importState, 'Sa_pslv', isc, iec, jsc, jec, ice_ocean_boundary%p, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! near-IR, direct shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_ir_dir_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_nir_dir, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_idr', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_nir_dir, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! near-IR, diffuse shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_ir_dif_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_nir_dif, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_idf', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_nir_dif, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! visible, direct shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_vis_dir_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_vis_dir, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_vdr', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_vis_dir, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! visible, diffuse shortwave (W/m2) !---- - call state_getimport(importState, 'mean_net_sw_vis_dif_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%sw_flux_vis_dif, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_swnet_vdf', isc, iec, jsc, jec, & + ice_ocean_boundary%sw_flux_vis_dif, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- ! Net longwave radiation (W/m2) ! ------- - call state_getimport(importState, 'mean_net_lw_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%lw_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_lwnet', isc, iec, jsc, jec, & + ice_ocean_boundary%lw_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -148,10 +146,10 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, allocate (taux(isc:iec,jsc:jec)) allocate (tauy(isc:iec,jsc:jec)) - call state_getimport(importState, 'mean_zonal_moment_flx', isc, iec, jsc, jec, taux, & + call state_getimport(importState, 'Foxx_taux', isc, iec, jsc, jec, taux, & areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call state_getimport(importState, 'mean_merid_moment_flx', isc, iec, jsc, jec, tauy, & + call state_getimport(importState, 'Foxx_tauy', isc, iec, jsc, jec, tauy, & areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -172,29 +170,29 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- ! sensible heat flux (W/m2) !---- - call state_getimport(importState, 'mean_sensi_heat_flx', & - isc, iec, jsc, jec, ice_ocean_boundary%t_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_sen', isc, iec, jsc, jec, & + ice_ocean_boundary%t_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! evaporation flux (W/m2) !---- - call state_getimport(importState, 'mean_evap_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%q_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Foxx_evap', isc, iec, jsc, jec, & + ice_ocean_boundary%q_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! liquid precipitation (rain) !---- - call state_getimport(importState, 'mean_prec_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%lprec, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Faxa_rain', isc, iec, jsc, jec, & + ice_ocean_boundary%lprec, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! frozen precipitation (snow) !---- - call state_getimport(importState, 'mean_fprec_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%fprec, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Faxa_snow', isc, iec, jsc, jec, & + ice_ocean_boundary%fprec, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -216,75 +214,85 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- - ! Enthalpy terms (only in CESM) + ! Enthalpy terms !---- - if (cesm_coupled) then - !---- - ! enthalpy from liquid precipitation (hrain) - !---- - call state_getimport(importState, 'heat_content_lprec', & - isc, iec, jsc, jec, ice_ocean_boundary%hrain, areacor=med2mod_areacor, rc=rc) - if (ChkErr(rc,__LINE__,u_FILE_u)) return - !---- - ! enthalpy from frozen precipitation (hsnow) - !---- - call state_getimport(importState, 'heat_content_fprec', & - isc, iec, jsc, jec, ice_ocean_boundary%hsnow, areacor=med2mod_areacor, rc=rc) + !---- + ! enthalpy from liquid precipitation (hrain) + !---- + if ( associated(ice_ocean_boundary%hrain) ) then + call state_getimport(importState, 'Foxx_hrain', isc, iec, jsc, jec, & + ice_ocean_boundary%hrain, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - !---- - ! enthalpy from liquid runoff (hrofl) - !---- - call state_getimport(importState, 'heat_content_rofl', & - isc, iec, jsc, jec, ice_ocean_boundary%hrofl, areacor=med2mod_areacor, rc=rc) + !---- + ! enthalpy from frozen precipitation (hsnow) + !---- + if ( associated(ice_ocean_boundary%hsnow) ) then + call state_getimport(importState, 'Foxx_hsnow', isc, iec, jsc, jec, & + ice_ocean_boundary%hsnow, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - !---- - ! enthalpy from frozen runoff (hrofi) - !---- - call state_getimport(importState, 'heat_content_rofi', & - isc, iec, jsc, jec, ice_ocean_boundary%hrofi, areacor=med2mod_areacor, rc=rc) + !---- + ! enthalpy from liquid runoff (hrofl) + !---- + if ( associated(ice_ocean_boundary%hrofl) ) then + call state_getimport(importState, 'Foxx_hrofl', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofl, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - !---- - ! enthalpy from evaporation (hevap) - !---- - call state_getimport(importState, 'heat_content_evap', & - isc, iec, jsc, jec, ice_ocean_boundary%hevap, areacor=med2mod_areacor, rc=rc) + !---- + ! enthalpy from frozen runoff (hrofi) + !---- + if ( associated(ice_ocean_boundary%hrofi) ) then + call state_getimport(importState, 'Foxx_hrofi', isc, iec, jsc, jec, & + ice_ocean_boundary%hrofi, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if - !---- - ! enthalpy from condensation (hcond) - !---- - call state_getimport(importState, 'heat_content_cond', & - isc, iec, jsc, jec, ice_ocean_boundary%hcond, areacor=med2mod_areacor, rc=rc) + !---- + ! enthalpy from evaporation (hevap) + !---- + if ( associated(ice_ocean_boundary%hevap) ) then + call state_getimport(importState, 'Foxx_hevap', isc, iec, jsc, jec, & + ice_ocean_boundary%hevap, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + !---- + ! enthalpy from condensation (hcond) + !---- + if ( associated(ice_ocean_boundary%hcond) ) then + call state_getimport(importState, 'Foxx_hcond', isc, iec, jsc, jec, & + ice_ocean_boundary%hcond, areacor=med2mod_areacor, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return endif !---- ! salt flux from ice !---- ice_ocean_boundary%salt_flux(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_salt_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%salt_flux, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Fioi_salt', isc, iec, jsc, jec, & + ice_ocean_boundary%salt_flux, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! snow&ice melt heat flux (W/m^2) !---- ice_ocean_boundary%seaice_melt_heat(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'net_heat_flx_to_ocn', & - isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt_heat, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Fioi_melth', isc, iec, jsc, jec, & + ice_ocean_boundary%seaice_melt_heat, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! snow&ice melt water flux (W/m^2) !---- ice_ocean_boundary%seaice_melt(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mean_fresh_water_to_ocean_rate', & - isc, iec, jsc, jec, ice_ocean_boundary%seaice_melt, areacor=med2mod_areacor, rc=rc) + call state_getimport(importState, 'Fioi_meltw', isc, iec, jsc, jec, & + ice_ocean_boundary%seaice_melt, areacor=med2mod_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -293,24 +301,24 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, ! Note - preset values to 0, if field does not exist in importState, then will simply return ! and preset value will be used ice_ocean_boundary%mi(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'mass_of_overlying_ice', & - isc, iec, jsc, jec, ice_ocean_boundary%mi,rc=rc) + call state_getimport(importState, 'mass_of_overlying_ice', isc, iec, jsc, jec, & + ice_ocean_boundary%mi,rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! sea-ice fraction !---- ice_ocean_boundary%ice_fraction(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Si_ifrac', & - isc, iec, jsc, jec, ice_ocean_boundary%ice_fraction, rc=rc) + call state_getimport(importState, 'Si_ifrac', isc, iec, jsc, jec, & + ice_ocean_boundary%ice_fraction, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- ! 10m wind squared !---- ice_ocean_boundary%u10_sqr(:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'So_duu10n', & - isc, iec, jsc, jec, ice_ocean_boundary%u10_sqr, rc=rc) + call state_getimport(importState, 'So_duu10n', isc, iec, jsc, jec, & + ice_ocean_boundary%u10_sqr, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return !---- @@ -318,8 +326,8 @@ subroutine mom_import(ocean_public, ocean_grid, importState, ice_ocean_boundary, !---- if ( associated(ice_ocean_boundary%lamult) ) then ice_ocean_boundary%lamult (:,:) = 0._ESMF_KIND_R8 - call state_getimport(importState, 'Sw_lamult', & - isc, iec, jsc, jec, ice_ocean_boundary%lamult, rc=rc) + call state_getimport(importState, 'Sw_lamult', isc, iec, jsc, jec, & + ice_ocean_boundary%lamult, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif @@ -424,8 +432,7 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, enddo enddo - call State_SetExport(exportState, 'ocean_mask', & - isc, iec, jsc, jec, omask, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_omask', isc, iec, jsc, jec, omask, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(omask) @@ -433,15 +440,13 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- ! Sea surface temperature ! ------- - call State_SetExport(exportState, 'sea_surface_temperature', & - isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_t', isc, iec, jsc, jec, ocean_public%t_surf, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- ! Sea surface salinity ! ------- - call State_SetExport(exportState, 's_surf', & - isc, iec, jsc, jec, ocean_public%s_surf, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_s', isc, iec, jsc, jec, ocean_public%s_surf, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return ! ------- @@ -467,12 +472,10 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, enddo enddo - call State_SetExport(exportState, 'ocn_current_zonal', & - isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_u', isc, iec, jsc, jec, ocz_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetExport(exportState, 'ocn_current_merid', & - isc, iec, jsc, jec, ocm_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_v', isc, iec, jsc, jec, ocm_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(ocz, ocm, ocz_rot, ocm_rot) @@ -482,8 +485,8 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, ! ------- call ESMF_StateGet(exportState, 'So_bldepth', itemFlag, rc=rc) if (itemFlag /= ESMF_STATEITEM_NOTFOUND) then - call State_SetExport(exportState, 'So_bldepth', & - isc, iec, jsc, jec, ocean_public%obld, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_bldepth', isc, iec, jsc, jec, & + ocean_public%obld, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return endif @@ -506,8 +509,8 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, enddo enddo - call State_SetExport(exportState, 'freezing_melting_potential', & - isc, iec, jsc, jec, melt_potential, ocean_grid, areacor=mod2med_areacor, rc=rc) + call State_SetExport(exportState, 'Fioo_q', isc, iec, jsc, jec, & + melt_potential, ocean_grid, areacor=mod2med_areacor, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(melt_potential) @@ -620,12 +623,10 @@ subroutine mom_export(ocean_public, ocean_grid, ocean_state, exportState, clock, enddo enddo - call State_SetExport(exportState, 'sea_surface_slope_zonal', & - isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_dhdx', isc, iec, jsc, jec, dhdx_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return - call State_SetExport(exportState, 'sea_surface_slope_merid', & - isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) + call State_SetExport(exportState, 'So_dhdy', isc, iec, jsc, jec, dhdy_rot, ocean_grid, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return deallocate(ssh, dhdx, dhdy, dhdx_rot, dhdy_rot) From de55fd6d2a5e59e0d2b7fc99123b97815d78daf0 Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Fri, 15 Sep 2023 13:38:17 -0600 Subject: [PATCH 420/629] fix multiinstance log filename correction and remove FMS1 io api calls. --- config_src/drivers/nuopc_cap/mom_cap.F90 | 5 +++-- config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 | 1 - 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 120078b11e..b160dc7ab7 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -479,8 +479,9 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) if (cesm_coupled) then ! Multiinstance logfile name needs a correction - if(logfile(4:4) == '_') then - logfile = logfile(1:3)//trim(inst_suffix)//logfile(9:) + if(len_trim(inst_suffix) > 0) then + n = index(logfile, '.') + logfile = logfile(1:n-1)//trim(inst_suffix)//logfile(n:) endif endif diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 index c9eb067e54..c1bb792e45 100644 --- a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -28,7 +28,6 @@ subroutine ensemble_manager_init(ensemble_suffix) if (present(ensemble_suffix)) then call fms2_io_set_filename_appendix(trim(ensemble_suffix)) - call fms_io_set_filename_appendix(trim(ensemble_suffix)) else call FMS_ensemble_manager_init() endif From 5e6e6576f2f32478b977f5ace7729f4251e4fc1a Mon Sep 17 00:00:00 2001 From: alperaltuntas Date: Tue, 19 Sep 2023 09:15:05 -0600 Subject: [PATCH 421/629] remove fms_io_mod import --- config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 | 1 - 1 file changed, 1 deletion(-) diff --git a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 index c1bb792e45..f4028f7af7 100644 --- a/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_ensemble_manager_infra.F90 @@ -10,7 +10,6 @@ module MOM_ensemble_manager_infra use ensemble_manager_mod, only : FMS_get_ensemble_pelist => get_ensemble_pelist use ensemble_manager_mod, only : FMS_get_ensemble_filter_pelist => get_ensemble_filter_pelist use fms2_io_mod, only : fms2_io_set_filename_appendix=>set_filename_appendix -use fms_io_mod, only : fms_io_set_filename_appendix=>set_filename_appendix implicit none ; private From a7444b3d4dd42a6116206ae78949aab2d43ecd1b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 11 Jul 2023 16:03:24 -0400 Subject: [PATCH 422/629] *Test for convergence in dz_to_thickness_EOS Add tests to stop iterating when converged to roundoff in dz_to_thickness_EOS when in fully non-Boussinesq mode. Also modified the code to keep track of the layer thickness directly in non-Boussinesq mode rather than setting the layer thickness based on a difference between interface pressures. Boussinesq answers are bitwise identical, but non-Boussinesq answers change. --- src/core/MOM_interface_heights.F90 | 45 ++++++++++++++++++++++-------- 1 file changed, 33 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 0a579db299..194c39c76d 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -519,10 +519,15 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s ! 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 :: dp(SZI_(G),SZJ_(G)) ! Pressure change across 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 :: dp_adj ! The amount by which to change the bottom pressure in an + ! iteration [R L2 T-2 ~> Pa] 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] + logical :: do_more(SZI_(G),SZJ_(G)) ! If true, additional iterations would be beneficial. + logical :: do_any ! True if there are points in this layer that need more itertions. 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 @@ -561,38 +566,54 @@ subroutine dz_to_thickness_EOS(dz, Temp, Saln, EoS, h, G, GV, US, halo_size, p_s if (GV%semi_Boussinesq) then do i=is,ie 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)) + dp(i,j) = (GV%g_Earth*GV%H_to_Z) * ((GV%Z_to_H*dz(i,j,k)) * rho(i)) enddo else do i=is,ie p_bot(i,j) = p_top(i,j) + rho(i) * (GV%g_Earth * dz(i,j,k)) + dp(i,j) = rho(i) * (GV%g_Earth * dz(i,j,k)) enddo endif enddo + do_more(:,:) = .true. 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) + do_any = .false. + 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) + 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. if (GV%semi_Boussinesq) then 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)) + dp_adj = rho(i) * ((GV%g_Earth*GV%H_to_Z)*(GV%Z_to_H*dz(i,j,k)) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj enddo + do_any = .true. ! To avoid changing answers, always use the maximum number of itertions. else - do i=is,ie - p_bot(i,j) = p_bot(i,j) + rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) - enddo + do i=is,ie ; if (do_more(i,j)) then + dp_adj = rho(i) * (GV%g_Earth*dz(i,j,k) - dz_geo(i,j)) + p_bot(i,j) = p_bot(i,j) + dp_adj + dp(i,j) = dp(i,j) + dp_adj + ! Check for convergence to roundoff. + do_more(i,j) = (abs(dp_adj) > 1.0e-15*dp(i,j)) + if (do_more(i,j)) do_any = .true. + endif ; enddo endif enddo ; endif + if (.not.do_any) exit 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 + if (GV%semi_Boussinesq) then + do j=js,je ; do i=is,ie + h(i,j,k) = (p_bot(i,j) - p_top(i,j)) * I_gEarth + enddo ; enddo + else + do j=js,je ; do i=is,ie + h(i,j,k) = dp(i,j) * I_gEarth + enddo ; enddo + endif enddo endif From dd5c47d031ee0c7dbba3e7f7770d81175a943032 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 14 Aug 2023 09:57:13 -0400 Subject: [PATCH 423/629] *Non-Boussinesq revision of energetic_PBL This commit revises the internal routines called by energetic_PBL to work in fully non-Boussinesq mode, eliminating all dependencies on the Boussinesq reference density when in non-Boussinesq mode. The publicly visible interfaces to this module and the external routines it calls have already been revised, so only this file needs to be updated. The specific changes include: - Work with both thickness (h) and height change (dz) variables in energetic_PBL using thickness_to_dz to translate between the two. In Boussinesq mode, these are a simple rescaling by a constant factor, but in non-Boussinesq mode they vary by a factor of the specific volume. Some calculations are unnecessarily duplicated in Boussinesq mode, so this might slow the model slightly, but they are not duplicative in non-Boussinesq mode. - When in non-Boussinesq mode, use forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 to determine the friction velocity and mechanical TKE input used in energetic_PBL, and to convert the local TKE to a turbulent velocity. This includes the addition of a new energy input argument and an interface specific volume argument to ePBL_column and the removal of an unused argument to find_mstar. - Use tau_mag_gustless times the in situ specfic volume instead of ustar_gustless to calculate the Langmuir number used by ePBL when it is run in non-Boussinesq mode. - The unused Ustar_mean argument to find_mstar was removed. This change involves the addition of 2 new arguments to ePBL_column and changes to the units of another argument. There are changes to the units of 2 elements of the energetic_PBL_CS type and 14 internal variables. This change includes the addition of 13 new internal variables, the removal of 8 internal variable (most of which were renamed to reflect their new units). With this change, 9 thickness to height conversion factors have been eliminated, and GV%Rho0 is only used in Boussinesq mode. All answers in Boussinesq mode are bitwise identical, but they change in non-Boussinesq mode cases that use ePBL, which no longer depend on the value of the Boussinesq reference density. --- .../vertical/MOM_energetic_PBL.F90 | 302 +++++++++++------- 1 file changed, 186 insertions(+), 116 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 17da7aceb3..380725b744 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -3,20 +3,20 @@ module MOM_energetic_PBL ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE -use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs -use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc -use MOM_diag_mediator, only : time_type, diag_ctrl -use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg -use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_forcing_type, only : forcing -use MOM_grid, only : ocean_grid_type +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_coms, only : EFP_type, real_to_EFP, EFP_to_real, operator(+), assignment(=), EFP_sum_across_PEs +use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc +use MOM_diag_mediator, only : time_type, diag_ctrl +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_forcing_type, only : forcing +use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : thickness_to_dz use MOM_string_functions, only : uppercase -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type use MOM_wave_interface, only : wave_parameters_CS, Get_Langmuir_Number use MOM_stochastics, only : stochastic_CS @@ -76,7 +76,7 @@ module MOM_energetic_PBL !! boundary layer thickness [nondim]. The default is 0, but a !! value of 0.1 might be better justified by observations. real :: MLD_tol !< A tolerance for determining the boundary layer thickness when - !! Use_MLD_iteration is true [H ~> m or kg m-2]. + !! Use_MLD_iteration is true [Z ~> m]. real :: min_mix_len !< The minimum mixing length scale that will be used by ePBL [Z ~> m]. !! The default (0) does not set a minimum. @@ -170,7 +170,7 @@ module MOM_energetic_PBL !! timing of diagnostic output. real, allocatable, dimension(:,:) :: & - ML_depth !< The mixed layer depth determined by active mixing in ePBL [Z ~> m]. + ML_depth !< The mixed layer depth determined by active mixing in ePBL [H ~> m or kg m-2] ! These are terms in the mixed layer TKE budget, all in [R Z3 T-3 ~> W m-2 = kg s-3]. real, allocatable, dimension(:,:) :: & diag_TKE_wind, & !< The wind source of TKE [R Z3 T-3 ~> W m-2]. @@ -319,7 +319,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS u_2d, & ! A 2-d slice of the zonal velocity [L T-1 ~> m s-1]. v_2d ! A 2-d slice of the meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK_(GV)+1) :: & - Kd_2d ! A 2-d version of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + Kd_2d ! A 2-d version of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZK_(GV)) :: & h, & ! The layer thickness [H ~> m or kg m-2]. dz, & ! The vertical distance across layers [Z ~> m]. @@ -331,17 +331,25 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS u, & ! The zonal velocity [L T-1 ~> m s-1]. v ! The meridional velocity [L T-1 ~> m s-1]. real, dimension(SZK_(GV)+1) :: & - Kd, & ! The diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + Kd, & ! The diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. - mixlen ! A turbulent mixing length [Z ~> m]. + mixlen, & ! A turbulent mixing length [Z ~> m]. + SpV_dt ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) + ! times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1], + ! used to convert local TKE into a turbulence velocity cubed. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: absf ! The absolute value of f [T-1 ~> s-1]. real :: U_star ! The surface friction velocity [Z T-1 ~> m s-1]. real :: U_Star_Mean ! The surface friction without gustiness [Z T-1 ~> m s-1]. + real :: mech_TKE ! The mechanically generated turbulent kinetic energy available for mixing over a + ! timestep before the application of the efficiency in mstar [R Z3 T-2 ~> J m-2] + real :: I_rho ! The inverse of the Boussinesq reference density times a ratio of scaling + ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: I_dt ! The Adcroft reciprocal of the timestep [T-1 ~> s-1] real :: B_Flux ! The surface buoyancy flux [Z2 T-3 ~> m2 s-3] - real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m]. + real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m] type(ePBL_column_diags) :: eCD ! A container for passing around diagnostics. @@ -354,14 +362,18 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "energetic_PBL: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & - "energetic_PBL: No surface TKE fluxes (ustar) defined in fluxes type!") + if (.not.(associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface friction velocity (ustar or tau_mag) defined in fluxes type.") + if ((.not.GV%Boussinesq) .and. (.not.associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "energetic_PBL: No surface wind stress magnitude defined in fluxes type in non-Boussinesq mode.") if (CS%use_LT .and. .not.associated(Waves)) call MOM_error(FATAL, & "energetic_PBL: The Waves control structure must be associated if CS%use_LT "//& "(i.e., USE_LA_LI2016 or EPBL_LT) is True.") h_neglect = GV%H_subroundoff + I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. + I_dt = 0.0 ; if (dt > 0.0) I_dt = 1.0 / dt ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then @@ -376,7 +388,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! if (CS%id_Mixing_Length>0) CS%Mixing_Length(:,:,:) = 0.0 ! if (CS%id_Velocity_Scale>0) CS%Velocity_Scale(:,:,:) = 0.0 - !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt, & + !!OMP parallel do default(private) shared(js,je,nz,is,ie,h_3d,u_3d,v_3d,tv,dt,I_dt, & !!OMP CS,G,GV,US,fluxes,TKE_forced,dSV_dT,dSV_dS,Kd_int) do j=js,je ! Copy the thicknesses and other fields to 2-d arrays. @@ -388,6 +400,14 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS enddo ; enddo call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + ! Set the inverse density used to translating local TKE into a turbulence velocity + SpV_dt(:) = 0.0 + if ((dt > 0.0) .and. GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do K=1,nz+1 + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + enddo + endif + ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing ! surface cooling & brine rejection down through the topmost cell, and @@ -406,8 +426,29 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS do K=1,nz+1 ; Kd(K) = 0.0 ; enddo ! Make local copies of surface forcing and process them. - u_star = fluxes%ustar(i,j) - u_star_Mean = fluxes%ustar_gustless(i,j) + if (associated(fluxes%ustar) .and. (GV%Boussinesq .or. .not.associated(fluxes%tau_mag))) then + u_star = fluxes%ustar(i,j) + u_star_Mean = fluxes%ustar_gustless(i,j) + mech_TKE = dt * GV%Rho0 * u_star**3 + elseif (allocated(tv%SpV_avg)) then + u_star = sqrt(US%L_to_Z*fluxes%tau_mag(i,j) * tv%SpV_avg(i,j,1)) + u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * tv%SpV_avg(i,j,1)) + mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + else + u_star = sqrt(fluxes%tau_mag(i,j) * I_rho) + u_star_Mean = sqrt(US%L_to_Z*fluxes%tau_mag_gustless(i,j) * I_rho) + mech_TKE = dt * GV%Rho0 * u_star**3 + ! The line above is equivalent to: mech_TKE = dt * u_star * US%L_to_Z*fluxes%tau_mag(i,j) + endif + + if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then + SpV_dt(1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) * 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,nz) * I_dt + endif + B_flux = buoy_flux(i,j) if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & @@ -429,13 +470,13 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS if (CS%MLD_iteration_guess .and. (CS%ML_depth(i,j) > 0.0)) MLD_io = CS%ML_depth(i,j) if (stoch_CS%pert_epbl) then ! stochastics are active - call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j, & TKE_gen_stoch=stoch_CS%epbl1_wts(i,j), TKE_diss_stoch=stoch_CS%epbl2_wts(i,j)) else - call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, & + call ePBL_column(h, dz, u, v, T0, S0, dSV_dT_1d, dSV_dS_1d, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE, dt, MLD_io, Kd, mixvel, mixlen, GV, & US, CS, eCD, Waves, G, i, j) endif @@ -472,7 +513,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS CS%ML_depth(i,j) = 0.0 endif ; enddo ! Close of i-loop - Note unusual loop order! - do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = GV%Z_to_H*Kd_2d(i,K) ; enddo ; enddo + do K=1,nz+1 ; do i=is,ie ; Kd_int(i,j,K) = Kd_2d(i,K) ; enddo ; enddo enddo ! j-loop @@ -504,8 +545,8 @@ end subroutine energetic_PBL !> This subroutine determines the diffusivities from the integrated energetics !! mixed layer model for a single column of water. -subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, absf, & - u_star, u_star_mean, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & +subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, B_flux, absf, & + u_star, u_star_mean, mech_TKE_in, dt, MLD_io, Kd, mixvel, mixlen, GV, US, CS, eCD, & Waves, G, i, j, TKE_gen_stoch, TKE_diss_stoch) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -523,6 +564,10 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, !! [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. + real, dimension(SZK_(GV)+1), intent(in) :: SpV_dt !< Specific volume interpolated to interfaces + !! divided by dt or 1.0 / (dt * Rho0) times conversion + !! factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1], + !! used to convert local TKE into a turbulence velocity. real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. @@ -531,12 +576,16 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, real, intent(in) :: u_star !< The surface friction velocity [Z T-1 ~> m s-1]. real, intent(in) :: u_star_mean !< The surface friction velocity without any !! contribution from unresolved gustiness [Z T-1 ~> m s-1]. + real, intent(in) :: mech_TKE_in !< The mechanically generated turbulent + !! kinetic energy available for mixing over a time + !! step before the application of the efficiency + !! in mstar. [R Z3 T-2 ~> J m-2]. real, intent(inout) :: MLD_io !< A first guess at the mixed layer depth on input, and - !! the calculated mixed layer depth on output [Z ~> m]. + !! the calculated mixed layer depth on output [Z ~> m] real, intent(in) :: dt !< Time increment [T ~> s]. real, dimension(SZK_(GV)+1), & intent(out) :: Kd !< The diagnosed diffusivities at interfaces - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZK_(GV)+1), & intent(out) :: mixvel !< The mixing velocity scale used in Kd !! [Z T-1 ~> m s-1]. @@ -575,11 +624,12 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, real :: conv_PErel ! The potential energy that has been convectively released ! during this timestep [R Z3 T-2 ~> J m-2]. A portion nstar_FC ! of conv_PErel is available to drive mixing. - real :: htot ! The total depth of the layers above an interface [H ~> m or kg m-2]. + real :: htot ! The total thickness of the layers above an interface [H ~> m or kg m-2]. + real :: dztot ! The total depth of the layers above an interface [Z ~> m]. real :: uhtot ! The depth integrated zonal velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] real :: vhtot ! The depth integrated meridional velocities in the layers above [H L T-1 ~> m2 s-1 or kg m-1 s-1] real :: Idecay_len_TKE ! The inverse of a turbulence decay length scale [H-1 ~> m-1 or m2 kg-1]. - real :: h_sum ! The total thickness of the water column [H ~> m or kg m-2]. + real :: dz_sum ! The total thickness of the water column [Z ~> m]. real, dimension(SZK_(GV)) :: & dT_to_dColHt, & ! Partial derivative of the total column height with the temperature changes @@ -619,6 +669,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, MixLen_shape, & ! A nondimensional shape factor for the mixing length that ! gives it an appropriate asymptotic value at the bottom of ! the boundary layer [nondim]. + h_dz_int, & ! The ratio of the layer thicknesses over the vertical distances + ! across the layers surrounding an interface [H Z-1 ~> nondim or kg m-3] Kddt_h ! The diapycnal diffusivity times a timestep divided by the ! average thicknesses around a layer [H ~> m or kg m-2]. real :: b1 ! b1 is inverse of the pivot used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. @@ -627,6 +679,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! in the denominator of b1 in a downward-oriented tridiagonal solver. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. real :: dMass ! The mass per unit area within a layer [Z R ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R Z2 T-2 ~> Pa = J m-3]. real :: dMKE_max ! The maximum amount of mean kinetic energy that could be @@ -637,28 +691,25 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! of a layer and the thickness of the water above, used in ! the MKE conversion equation [H-1 ~> m-1 or m2 kg-1]. - real :: dt_h ! The timestep divided by the averages of the thicknesses around - ! a layer, times a thickness conversion factor [H T Z-2 ~> s m-1 or kg s m-4]. - real :: h_bot ! The distance from the bottom [H ~> m or kg m-2]. - real :: h_rsum ! The running sum of h from the top [H ~> m or kg m-2]. - real :: I_hs ! The inverse of h_sum [H-1 ~> m-1 or m2 kg-1]. - real :: I_MLD ! The inverse of the current value of MLD [H-1 ~> m-1 or m2 kg-1]. - real :: h_tt ! The distance from the surface or up to the next interface + real :: dt_h ! The timestep divided by the averages of the vertical distances around + ! a layer [T Z-1 ~> s m-1]. + real :: dz_bot ! The distance from the bottom [Z ~> m]. + real :: dz_rsum ! The running sum of dz from the top [Z ~> m]. + real :: I_dzsum ! The inverse of dz_sum [Z-1 ~> m-1]. + real :: I_MLD ! The inverse of the current value of MLD [Z-1 ~> m-1]. + real :: dz_tt ! The distance from the surface or up to the next interface ! that did not exhibit turbulent mixing from this scheme plus - ! a surface mixing roughness length given by h_tt_min [H ~> m or kg m-2]. - real :: h_tt_min ! A surface roughness length [H ~> m or kg m-2]. + ! a surface mixing roughness length given by dz_tt_min [Z ~> m]. + real :: dz_tt_min ! A surface roughness length [Z ~> m]. real :: C1_3 ! = 1/3 [nondim] - real :: I_dtrho ! 1.0 / (dt * Rho0) times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1]. - ! This is used convert TKE back into ustar^3 for use in a cube root. real :: vstar ! An in-situ turbulent velocity [Z T-1 ~> m s-1]. real :: mstar_total ! The value of mstar used in ePBL [nondim] real :: mstar_LT ! An addition to mstar due to Langmuir turbulence [nondim] (output for diagnostic) - real :: MLD_output ! The mixed layer depth output from this routine [H ~> m or kg m-2]. + real :: MLD_output ! The mixed layer depth output from this routine [Z ~> m] real :: LA ! The value of the Langmuir number [nondim] real :: LAmod ! The modified Langmuir number by convection [nondim] - real :: hbs_here ! The local minimum of hb_hs and MixLen_shape, times a - ! conversion factor from H to Z [Z H-1 ~> nondim or m3 kg-1]. + real :: hbs_here ! The local minimum of hb_hs and MixLen_shape [nondim] real :: nstar_FC ! The fraction of conv_PErel that can be converted to mixing [nondim]. real :: TKE_reduc ! The fraction by which TKE and other energy fields are ! reduced to support mixing [nondim]. between 0 and 1. @@ -677,7 +728,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, real :: dPE_conv ! The convective change in column potential energy [R Z3 T-2 ~> J m-2]. real :: MKE_src ! The mean kinetic energy source of TKE due to Kddt_h(K) [R Z3 T-2 ~> J m-2]. real :: dMKE_src_dK ! The partial derivative of MKE_src with Kddt_h(K) [R Z3 T-2 H-1 ~> J m-3 or J kg-1]. - real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [Z2 T-1 ~> m2 s-1]. + real :: Kd_guess0 ! A first guess of the diapycnal diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real :: PE_chg_g0 ! The potential energy change when Kd is Kd_guess0 [R Z3 T-2 ~> J m-2] real :: Kddt_h_g0 ! The first guess diapycnal diffusivity times a timestep divided ! by the average thicknesses around a layer [H ~> m or kg m-2]. @@ -706,15 +757,14 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, logical :: sfc_disconnect ! If true, any turbulence has become disconnected ! from the surface. -! The following are only used for diagnostics. + ! The following is only used for diagnostics. real :: I_dtdiag ! = 1.0 / dt [T-1 ~> s-1]. !---------------------------------------------------------------------- !/BGR added Aug24,2016 for adding iteration to get boundary layer depth ! - needed to compute new mixing length. - real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [H ~> m or kg m-2]. - real :: MLD_guess_Z ! A guessed mixed layer depth, converted to height units [Z ~> m] - real :: min_MLD, max_MLD ! Iteration bounds on MLD [H ~> m or kg m-2], which are adjusted at each step + real :: MLD_guess, MLD_found ! Mixing Layer depth guessed/found for iteration [Z ~> m] + real :: min_MLD, max_MLD ! Iteration bounds on MLD [Z ~> m], which are adjusted at each step ! - These are initialized based on surface/bottom ! 1. The iteration guesses a value (possibly from prev step or neighbor). ! 2. The iteration checks if value is converged, too shallow, or too deep. @@ -727,8 +777,8 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! manner giving a usable guess. When it does fail, it is due to convection ! within the boundary layer. Likely, a new method e.g. surface_disconnect, ! can improve this. - real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [H ~> m or kg m-2] - real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [H ~> m or kg m-2] + real :: dMLD_min ! The change in diagnosed mixed layer depth when the guess is min_MLD [Z ~> m] + real :: dMLD_max ! The change in diagnosed mixed layer depth when the guess is max_MLD [Z ~> m] logical :: OBL_converged ! Flag for convergence of MLD integer :: OBL_it ! Iteration counter @@ -762,16 +812,16 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, calc_Te = (debug .or. (.not.CS%orig_PE_calc)) h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff C1_3 = 1.0 / 3.0 I_dtdiag = 1.0 / dt max_itt = 20 - h_tt_min = 0.0 - I_dtrho = 0.0 ; if (dt*GV%Rho0 > 0.0) I_dtrho = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + dz_tt_min = 0.0 vstar_unit_scale = US%m_to_Z * US%T_to_s - MLD_guess = MLD_io*GV%Z_to_H + MLD_guess = MLD_io ! Determine the initial mech_TKE and conv_PErel, including the energy required ! to mix surface heating through the topmost cell, the energy released by mixing @@ -794,29 +844,39 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, pres_Z(K+1) = pres_Z(K) + dPres enddo - ! Determine the total thickness (h_sum) and the fractional distance from the bottom (hb_hs). - h_sum = H_neglect ; do k=1,nz ; h_sum = h_sum + h(k) ; enddo - I_hs = 0.0 ; if (h_sum > 0.0) I_hs = 1.0 / h_sum - h_bot = 0.0 + ! Determine the total thickness (dz_sum) and the fractional distance from the bottom (hb_hs). + dz_sum = dz_neglect ; do k=1,nz ; dz_sum = dz_sum + dz(k) ; enddo + I_dzsum = 0.0 ; if (dz_sum > 0.0) I_dzsum = 1.0 / dz_sum + dz_bot = 0.0 hb_hs(nz+1) = 0.0 do k=nz,1,-1 - h_bot = h_bot + h(k) - hb_hs(K) = h_bot * I_hs + dz_bot = dz_bot + dz(k) + hb_hs(K) = dz_bot * I_dzsum enddo - MLD_output = h(1) + MLD_output = dz(1) !/The following lines are for the iteration over MLD ! max_MLD will initialized as ocean bottom depth - max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + h(k) ; enddo + max_MLD = 0.0 ; do k=1,nz ; max_MLD = max_MLD + dz(k) ; enddo ! min_MLD will be initialized to 0. min_MLD = 0.0 ! Set values of the wrong signs to indicate that these changes are not based on valid estimates - dMLD_min = -1.0*GV%m_to_H ; dMLD_max = 1.0*GV%m_to_H + dMLD_min = -1.0*US%m_to_Z ; dMLD_max = 1.0*US%m_to_Z ! If no first guess is provided for MLD, try the middle of the water column if (MLD_guess <= min_MLD) MLD_guess = 0.5 * (min_MLD + max_MLD) + if (GV%Boussinesq) then + do K=1,nz+1 ; h_dz_int(K) = GV%Z_to_H ; enddo + else + h_dz_int(1) = (h(1) + h_neglect) / (dz(1) + dz_neglect) + do K=2,nz + h_dz_int(K) = (h(k-1) + h(k) + h_neglect) / (dz(k-1) + dz(k) + dz_neglect) + enddo + h_dz_int(nz+1) = (h(nz) + h_neglect) / (dz(nz) + dz_neglect) + endif + ! Iterate to determine a converged EPBL depth. OBL_converged = .false. do OBL_it=1,CS%Max_MLD_Its @@ -828,26 +888,26 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, if (debug) then ; mech_TKE_k(:) = 0.0 ; conv_PErel_k(:) = 0.0 ; endif ! Reset ML_depth - MLD_output = h(1) + MLD_output = dz(1) sfc_connected = .true. !/ Here we get MStar, which is the ratio of convective TKE driven mixing to UStar**3 - MLD_guess_z = GV%H_to_Z*MLD_guess ! Convert MLD from thickness to height coordinates for these calls if (CS%Use_LT) then - call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess_z), u_star_mean, i, j, dz, Waves, & + call get_Langmuir_Number(LA, G, GV, US, abs(MLD_guess), u_star_mean, i, j, dz, Waves, & U_H=u, V_H=v) - call find_mstar(CS, US, B_flux, u_star, u_star_Mean, MLD_guess_z, absf, & + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, & MStar_total, Langmuir_Number=La, Convect_Langmuir_Number=LAmod,& mstar_LT=mstar_LT) else - call find_mstar(CS, US, B_flux, u_star, u_star_mean, MLD_guess_z, absf, mstar_total) + call find_mstar(CS, US, B_flux, u_star, MLD_guess, absf, mstar_total) endif !/ Apply MStar to get mech_TKE if ((CS%answer_date < 20190101) .and. (CS%mstar_scheme==Use_Fixed_MStar)) then mech_TKE = (dt*MSTAR_total*GV%Rho0) * u_star**3 else - mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) + mech_TKE = MSTAR_total * mech_TKE_in + ! mech_TKE = MSTAR_total * (dt*GV%Rho0* u_star**3) endif ! stochastically perturb mech_TKE in the UFS if (present(TKE_gen_stoch)) mech_TKE = mech_TKE*TKE_gen_stoch @@ -894,16 +954,16 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! Reduce the mixing length based on MLD, with a quadratic ! expression that follows KPP. I_MLD = 1.0 / MLD_guess - h_rsum = 0.0 + dz_rsum = 0.0 MixLen_shape(1) = 1.0 do K=2,nz+1 - h_rsum = h_rsum + h(k-1) + dz_rsum = dz_rsum + dz(k-1) if (CS%MixLenExponent==2.0) then MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & - (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**2 ! CS%MixLenExponent + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**2 ! CS%MixLenExponent else MixLen_shape(K) = CS%transLay_scale + (1.0 - CS%transLay_scale) * & - (max(0.0, (MLD_guess - h_rsum)*I_MLD) )**CS%MixLenExponent + (max(0.0, (MLD_guess - dz_rsum)*I_MLD) )**CS%MixLenExponent endif enddo endif @@ -913,7 +973,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, dT_to_dPE_a(1) = dT_to_dPE(1) ; dT_to_dColHt_a(1) = dT_to_dColHt(1) dS_to_dPE_a(1) = dS_to_dPE(1) ; dS_to_dColHt_a(1) = dS_to_dColHt(1) - htot = h(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) + htot = h(1) ; dztot = dz(1) ; uhtot = u(1)*h(1) ; vhtot = v(1)*h(1) if (debug) then mech_TKE_k(1) = mech_TKE ; conv_PErel_k(1) = conv_PErel @@ -928,7 +988,11 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! different rates. The following form is often used for mechanical ! stirring from the surface, perhaps due to breaking surface gravity ! waves and wind-driven turbulence. - Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + if (GV%Boussinesq) then + Idecay_len_TKE = (CS%TKE_decay * absf / u_star) * GV%H_to_Z + else + Idecay_len_TKE = (CS%TKE_decay * absf) / (h_dz_int(K) * u_star) + endif exp_kh = 1.0 if (Idecay_len_TKE > 0.0) exp_kh = exp(-h(k-1)*Idecay_len_TKE) if (CS%TKE_diagnostics) & @@ -956,9 +1020,14 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, if (CS%nstar * conv_PErel > 0.0) then ! Here nstar is a function of the natural Rossby number 0.2/(1+0.2/Ro), based ! on a curve fit from the data of Wang (GRL, 2003). - ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*htot)**3 / conv_PErel) - nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & - sqrt(0.5 * dt * GV%Rho0 * (absf*(htot*GV%H_to_Z))**3 * conv_PErel)) + ! Note: Ro = 1.0 / sqrt(0.5 * dt * Rho0 * (absf*dztot)**3 / conv_PErel) + if (GV%Boussinesq) then + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%Rho0 * (absf*dztot)**3 * conv_PErel)) + else + nstar_FC = CS%nstar * conv_PErel / (conv_PErel + 0.2 * & + sqrt(0.5 * dt * GV%H_to_RZ * (absf**3 * (dztot**2 * htot)) * conv_PErel)) + endif endif if (debug) nstar_k(K) = nstar_FC @@ -1001,7 +1070,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) endif endif - dt_h = (GV%Z_to_H**2*dt) / max(0.5*(h(k-1)+h(k)), 1e-15*h_sum) + dt_h = dt / max(0.5*(dz(k-1)+dz(k)), 1e-15*dz_sum) ! This tests whether the layers above and below this interface are in ! a convectively stable configuration, without considering any effects of @@ -1088,26 +1157,26 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! At this point, Kddt_h(K) will be unknown because its value may depend ! on how much energy is available. mech_TKE might be negative due to ! contributions from TKE_forced. - h_tt = htot + h_tt_min + dz_tt = dztot + dz_tt_min TKE_here = mech_TKE + CS%wstar_ustar_coef*conv_PErel if (TKE_here > 0.0) then if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1.0 - htot / MLD_guess) + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) endif - hbs_here = GV%H_to_Z * min(hb_hs(K), MixLen_shape(K)) - mixlen(K) = MAX(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar)) + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = MAX(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) !Note setting Kd_guess0 to vstar * CS%vonKar * mixlen(K) here will ! change the answers. Therefore, skipping that. if (.not.CS%Use_MLD_iteration) then - Kd_guess0 = vstar * CS%vonKar * ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar) + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) else - Kd_guess0 = vstar * CS%vonKar * mixlen(K) + Kd_guess0 = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) endif else vstar = 0.0 ; Kd_guess0 = 0.0 @@ -1141,22 +1210,22 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, TKE_here = mech_TKE + CS%wstar_ustar_coef*(conv_PErel-PE_chg_max) if (TKE_here > 0.0) then if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (I_dtrho*TKE_here)**C1_3 + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1. - htot / MLD_guess) + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*I_dtrho)**C1_3) + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) endif - hbs_here = GV%H_to_Z * min(hb_hs(K), MixLen_shape(K)) - mixlen(K) = max(CS%min_mix_len, ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar)) + hbs_here = min(hb_hs(K), MixLen_shape(K)) + mixlen(K) = max(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar)) if (.not.CS%Use_MLD_iteration) then ! Note again (as prev) that using mixlen here ! instead of redoing the computation will change answers... - Kd(K) = vstar * CS%vonKar * ((h_tt*hbs_here)*vstar) / & - ((CS%Ekman_scale_coef * absf) * (h_tt*hbs_here) + vstar) + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * ((dz_tt*hbs_here)*vstar) / & + ((CS%Ekman_scale_coef * absf) * (dz_tt*hbs_here) + vstar) else - Kd(K) = vstar * CS%vonKar * mixlen(K) + Kd(K) = (h_dz_int(K)*vstar) * CS%vonKar * mixlen(K) endif else vstar = 0.0 ; Kd(K) = 0.0 @@ -1196,7 +1265,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, eCD%dTKE_MKE = eCD%dTKE_MKE + MKE_src * I_dtdiag endif if (sfc_connected) then - MLD_output = MLD_output + h(k) + MLD_output = MLD_output + dz(k) endif Kddt_h(K) = Kd(K) * dt_h @@ -1220,7 +1289,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, mech_TKE = TKE_reduc*(mech_TKE + MKE_src) conv_PErel = TKE_reduc*conv_PErel if (sfc_connected) then - MLD_output = MLD_output + h(k) + MLD_output = MLD_output + dz(k) endif elseif (tot_TKE == 0.0) then @@ -1320,8 +1389,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, (CS%nstar-nstar_FC) * conv_PErel * I_dtdiag endif - if (sfc_connected) MLD_output = MLD_output + & - (PE_chg / (PE_chg_g0)) * h(k) + if (sfc_connected) MLD_output = MLD_output + (PE_chg / (PE_chg_g0)) * dz(k) tot_TKE = 0.0 ; mech_TKE = 0.0 ; conv_PErel = 0.0 sfc_disconnect = .true. @@ -1351,11 +1419,13 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, uhtot = u(k)*h(k) vhtot = v(k)*h(k) htot = h(k) + dztot = dz(k) sfc_connected = .false. else uhtot = uhtot + u(k)*h(k) vhtot = vhtot + v(k)*h(k) htot = htot + h(k) + dztot = dztot + dz(k) endif if (calc_Te) then @@ -1416,7 +1486,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, ! Taking the occasional step with MLD_output empirically helps to converge faster. if ((dMLD_min > 0.0) .and. (dMLD_max < 0.0) .and. (OBL_it > 2) .and. (mod(OBL_it-1,4) > 0)) then ! Both bounds have valid change estimates and are probably in the range of possible outputs. - MLD_Guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) + MLD_guess = (dMLD_min*max_MLD - dMLD_max*min_MLD) / (dMLD_min - dMLD_max) elseif ((MLD_found > min_MLD) .and. (MLD_found < max_MLD)) then ! The output MLD_found is an interesting guess, as it likely to bracket the true solution ! along with the previous value of MLD_guess and to be close to the solution. @@ -1440,7 +1510,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, TKE_forcing, B_flux, eCD%LA = 0.0 ; eCD%LAmod = 0.0 ; eCD%mstar = mstar_total ; eCD%mstar_LT = 0.0 endif - MLD_io = GV%H_to_Z*MLD_output + MLD_io = MLD_output end subroutine ePBL_column @@ -1746,13 +1816,12 @@ subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & end subroutine find_PE_chg_orig !> This subroutine finds the Mstar value for ePBL -subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, UStar_Mean,& +subroutine find_mstar(CS, US, Buoyancy_Flux, UStar, & BLD, Abs_Coriolis, MStar, Langmuir_Number,& MStar_LT, Convect_Langmuir_Number) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, intent(in) :: UStar !< ustar w/ gustiness [Z T-1 ~> m s-1] - real, intent(in) :: UStar_Mean !< ustar w/o gustiness [Z T-1 ~> m s-1] + real, intent(in) :: UStar !< ustar including gustiness [Z T-1 ~> m s-1] real, intent(in) :: Abs_Coriolis !< absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: Buoyancy_Flux !< Buoyancy flux [Z2 T-3 ~> m2 s-3] real, intent(in) :: BLD !< boundary layer depth [Z ~> m] @@ -1927,12 +1996,13 @@ subroutine energetic_PBL_get_MLD(CS, MLD, G, US, m_to_MLD_units) type(energetic_PBL_CS), intent(in) :: CS !< Energetic PBL control structure type(ocean_grid_type), intent(in) :: G !< Grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] or other units + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: MLD !< Depth of ePBL active mixing layer [Z ~> m] + !! or other units real, optional, intent(in) :: m_to_MLD_units !< A conversion factor from meters - !! to the desired units for MLD, sometimes [m Z-1 ~> 1] + !! to the desired units for MLD, sometimes [Z m-1 ~> 1] ! Local variables real :: scale ! A dimensional rescaling factor, often [nondim] or [m Z-1 ~> 1] - integer :: i,j + integer :: i, j scale = 1.0 ; if (present(m_to_MLD_units)) scale = US%Z_to_m * m_to_MLD_units @@ -2151,7 +2221,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "EPBL_MLD_TOLERANCE", CS%MLD_tol, & "The tolerance for the iteratively determined mixed "//& "layer depth. This is only used with USE_MLD_ITERATION.", & - units="meter", default=1.0, scale=GV%m_to_H, do_not_log=.not.CS%Use_MLD_iteration) + units="meter", default=1.0, scale=US%m_to_Z, do_not_log=.not.CS%Use_MLD_iteration) call get_param(param_file, mdl, "EPBL_MLD_BISECTION", CS%MLD_bisection, & "If true, use bisection with the iterative determination of the self-consistent "//& "mixed layer depth. Otherwise use the false position after a maximum and minimum "//& @@ -2312,7 +2382,7 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) !/ Logging parameters ! This gives a minimum decay scale that is typically much less than Angstrom. - CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + CS%ustar_min = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) call log_param(param_file, mdl, "!EPBL_USTAR_MIN", CS%ustar_min, & "The (tiny) minimum friction velocity used within the "//& "ePBL code, derived from OMEGA and ANGSTROM.", & From 2337404b8fde641d9e6e8f8d030f57572551bd4e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 17:13:09 -0400 Subject: [PATCH 424/629] +SpV_avg optional argument to extract_optics_slice Added the optional argument SpV_avg to extract_optics_slice for use along with an appropriate value for opacity_scale to convert the units of opacity from [Z-1] to [H-1] in non-Boussinesq mode without making use of the Boussinesq reference density. All Boussinesq answers are bitwise identical, but non-Boussinesq answers will change and become less dependent on the Boussinesq reference density when this new argument is used. There is a new optional argument to a publicly visible subroutine. --- .../vertical/MOM_opacity.F90 | 40 +++++++++++++------ 1 file changed, 27 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index c48308a912..bd1b804cba 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -451,7 +451,7 @@ function opacity_manizza(chl_data) !> This subroutine returns a 2-d slice at constant j of fields from an optics_type, with the potential !! for rescaling these fields. -subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale) +subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_top, penSW_scale, SpV_avg) type(optics_type), intent(in) :: optics !< An optics structure that has values of opacities !! and shortwave fluxes. integer, intent(in) :: j !< j-index to extract @@ -459,33 +459,47 @@ subroutine extract_optics_slice(optics, j, G, GV, opacity, opacity_scale, penSW_ type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(max(optics%nbands,1),SZI_(G),SZK_(GV)), & optional, intent(out) :: opacity !< The opacity in each band, i-point, and layer [Z-1 ~> m-1], - !! but with units that can be altered by opacity_scale. + !! but with units that can be altered by opacity_scale + !! and the presence of SpV_avg to change this to other + !! units like [H-1 ~> m-1 or m2 kg-1] real, optional, intent(in) :: opacity_scale !< A factor by which to rescale the opacity [nondim] or !! [Z H-1 ~> 1 or m3 kg-1] real, dimension(max(optics%nbands,1),SZI_(G)), & optional, intent(out) :: penSW_top !< The shortwave radiation [Q R Z T-1 ~> W m-2] !! at the surface in each of the nbands bands !! that penetrates beyond the surface skin layer. - real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim]? + real, optional, intent(in) :: penSW_scale !< A factor by which to rescale the shortwave flux [nondim] + !! or other units. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: SpV_avg !< The layer-averaged specific volume [R-1 ~> m3 kg-1] + !! that is used along with opacity_scale in non-Boussinesq + !! cases to change the opacity from distance based units to + !! mass-based units ! Local variables - real :: scale_opacity, scale_penSW ! Rescaling factors [nondim]? + real :: scale_opacity ! A rescaling factor for opacity [nondim], or the same units as opacity_scale. + real :: scale_penSW ! A rescaling factor for the penetrating shortwave radiation [nondim] or the + ! same units as penSW_scale integer :: i, is, ie, k, nz, n is = G%isc ; ie = G%iec ; nz = GV%ke scale_opacity = 1.0 ; if (present(opacity_scale)) scale_opacity = opacity_scale scale_penSW = 1.0 ; if (present(penSW_scale)) scale_penSW = penSW_scale - if (present(opacity)) then ; do k=1,nz ; do i=is,ie - do n=1,optics%nbands - opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) - enddo - enddo ; enddo ; endif + if (present(opacity)) then + if (present(SpV_avg)) then + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = (scale_opacity * SpV_avg(i,j,k)) * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; do n=1,optics%nbands + opacity(n,i,k) = scale_opacity * optics%opacity_band(n,i,j,k) + enddo ; enddo ; enddo + endif + endif - if (present(penSW_top)) then ; do k=1,nz ; do i=is,ie - do n=1,optics%nbands - penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) - enddo + if (present(penSW_top)) then ; do i=is,ie ; do n=1,optics%nbands + penSW_top(n,i) = scale_penSW * optics%sw_pen_band(n,i,j) enddo ; enddo ; endif end subroutine extract_optics_slice From 2f1bdc06d41e35582759c678de2a48ba1fd66fd9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 17:17:46 -0400 Subject: [PATCH 425/629] +*Non-Boussinesq bulk mixed layer calculations This commit includes a series of distinct changes that enable the use of the bulk mixed layer code in non-Boussinesq mode, including an option to do the non-Boussinesq energetic calculations even when the model itself is in Boussinesq or semi-Boussinesq mode. When in fully non-Boussinesq mode, there is no longer any dependence on the Boussinesq reference density. Rescaled the units of turbulent kinetic energy in the bulk mixed layer code to [H L2 T-2 ~> m3 s-2 or J m-2] to reduce the influence of the Boussinesq reference density in non-Boussinesq configurations, with similar changes to the internal units of diagnostics and energy sources. Also revised how Hmix_min is set in bulkmixedlayer_init to avoid any dependency on the Boussinesq reference density. Add a U_star argument to find_starting_TKE and use find_ustar to set it. In some places a thickness-based definition of U_star is used. Also added logic to the code setting the starting TKE and k_Ustar so that they supports a greater range of valid combinations of available input variables. Added the option of using non-Boussinesq energetic calculations in the bulk mixed layer code, which avoids any dependence on the Boussinesq reference density, but do the calculations with the approximation that specific volume is conserved during mixing, thereby ignoring certain weak thermobaric effects. The use of this new option is controlled by the new runtime parameter BML_NONBOUSSINESQ, which is false by default except in fully non-Boussinesq mode. All of the new code is wrapped in logical branches that are selected by the new logical variable CS%nonBous_energetics in the bulk mixed layer control structure. This option changes which equation of state routines are called by the bulk mixed layer module. When in non-Boussinesq mode, use forces%tau_mag and tv%SpV_avg instead of forces%ustar and GV%Rho0 to determine the surface TKE flux. Use SpV_avg to rescale opacity in non-Boussinesq mode via the use of an optional argument to extract_optics_slice Use a call to average_specific_vol to translate the mass of the mixed layer into the mixed layer thickness. As a part of these changes, there is extensive but systematic revision to the code. Within the bulkmixedlayer_CS type the units of 10 elements (mostly diagnostics) are changed, and there is one new logical element. There are 17 new arguments to internal subroutines in the bulk mixed layer module, while the units of another 11 are changed. There are 35 new or renamed internal variables, while the units of another 28 internal variables are changed. A total of 23 thickness conversion factors were eliminated, and the remaining references to the Boussinesq reference density are only used in Boussinesq mode. Apart from the new runtime parameter, the external interfaces are unchanged. By default, answers are bitwise identical for Boussinesq or semi-Boussinesq configurations, but there is a new entry (BML_NONBOUSINESQ) in some MOM_parameter_doc files, and answers do change in non-Boussinesq mode and become independent of the value of RHO_0. --- .../vertical/MOM_bulk_mixed_layer.F90 | 1339 ++++++++++++----- 1 file changed, 958 insertions(+), 381 deletions(-) diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index ceba8dad1a..c7e522eddc 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -3,10 +3,13 @@ module MOM_bulk_mixed_layer ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : post_data, register_diag_field, safe_alloc_alloc use MOM_diag_mediator, only : time_type, diag_ctrl, diag_update_remap_grids use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain +use MOM_EOS, only : average_specific_vol, calculate_density_derivs +use MOM_EOS, only : calculate_spec_vol, calculate_specific_vol_derivs use MOM_error_handler, only : MOM_error, FATAL, WARNING use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : extractFluxes1d, forcing, find_ustar @@ -15,7 +18,6 @@ module MOM_bulk_mixed_layer use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_density, calculate_density_derivs, EOS_domain implicit none ; private @@ -53,7 +55,7 @@ module MOM_bulk_mixed_layer real :: Hmix_min !< The minimum mixed layer thickness [H ~> m or kg m-2]. real :: mech_TKE_floor !< A tiny floor on the amount of turbulent kinetic energy that is !! used when the mixed layer does not yet contain HMIX_MIN fluid - !! [Z L2 T-2 ~> m3 s-2]. The default is so small that its actual + !! [H L2 T-2 ~> m3 s-2 or J m-2]. The default is so small that its actual !! value is irrelevant, but it is detectably greater than 0. real :: H_limit_fluxes !< When the total ocean depth is less than this !! value [H ~> m or kg m-2], scale away all surface forcing to @@ -95,6 +97,8 @@ module MOM_bulk_mixed_layer !! shortwave radiation is absorbed is corrected by !! moving some of the heating upward in the water !! column. The default is false. + logical :: nonBous_energetics !< If true, use non-Boussinesq expressions for the energetic + !! calculations used in the bulk mixed layer calculations. logical :: Resolve_Ekman !< If true, the nkml layers in the mixed layer are !! chosen to optimally represent the impact of the !! Ekman transport on the mixed layer TKE budget. @@ -102,7 +106,7 @@ module MOM_bulk_mixed_layer logical :: TKE_diagnostics = .false. !< If true, calculate extensive diagnostics of the TKE budget logical :: do_rivermix = .false. !< Provide additional TKE to mix river runoff !! at the river mouths to rivermix_depth - real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [Z ~> m]. + real :: rivermix_depth = 0.0 !< The depth of mixing if do_rivermix is true [H ~> m or kg m-2]. logical :: limit_det !< If true, limit the extent of buffer layer !! detrainment to be consistent with neighbors. real :: lim_det_dH_sfc !< The fractional limit in the change between grid @@ -125,17 +129,17 @@ module MOM_bulk_mixed_layer real :: Allowed_S_chg !< The amount by which salinity is allowed !! to exceed previous values during detrainment [S ~> ppt] - ! These are terms in the mixed layer TKE budget, all in [Z L2 T-3 ~> m3 s-3] except as noted. + ! These are terms in the mixed layer TKE budget, all in [H L2 T-3 ~> m3 s-3 or W m-2] except as noted. real, allocatable, dimension(:,:) :: & ML_depth, & !< The mixed layer depth [H ~> m or kg m-2]. - diag_TKE_wind, & !< The wind source of TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_RiBulk, & !< The resolved KE source of TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_conv, & !< The convective source of TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [Z L2 T-3 ~> m3 s-3]. - diag_TKE_mech_decay, & !< The decay of mechanical TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_conv_decay, & !< The decay of convective TKE [Z L2 T-3 ~> m3 s-3]. - diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [Z L2 T-3 ~> m3 s-3]. - diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [Z L2 T-3 ~> m3 s-3]. + diag_TKE_wind, & !< The wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_RiBulk, & !< The resolved KE source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv, & !< The convective source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_pen_SW, & !< The TKE sink required to mix penetrating shortwave heating [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mech_decay, & !< The decay of mechanical TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_decay, & !< The decay of convective TKE [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_mixing, & !< The work done by TKE to deepen the mixed layer [H L2 T-3 ~> m3 s-3 or W m-2]. + diag_TKE_conv_s2, & !< The convective source of TKE due to to mixing in sigma2 [H L2 T-3 ~> m3 s-3 or W m-2]. diag_PE_detrain, & !< The spurious source of potential energy due to mixed layer !! detrainment [R Z L2 T-3 ~> W m-2]. diag_PE_detrain2 !< The spurious source of potential energy due to mixed layer only @@ -191,7 +195,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C type(optics_type), pointer :: optics !< The structure that can be queried for the !! inverse of the vertical absorption decay !! scale for penetrating shortwave radiation. - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m]. + real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of @@ -219,6 +223,7 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C T, & ! The layer temperatures [C ~> degC]. S, & ! The layer salinities [S ~> ppt]. R0, & ! The potential density referenced to the surface [R ~> kg m-3]. + SpV0, & ! The specific volume referenced to the surface [R-1 ~> m3 kg-1]. Rcv ! The coordinate variable potential density [R ~> kg m-3]. real, dimension(SZI_(G),SZK_(GV)) :: & u, & ! The zonal velocity [L T-1 ~> m s-1]. @@ -236,17 +241,22 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real, dimension(SZI_(G),SZJ_(G)) :: & h_miss ! The summed absolute mismatch [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & - U_star_2d ! The wind friction velocity, calculated using the Boussinesq reference density or + U_star_2d, &! The wind friction velocity, calculated using the Boussinesq reference density or ! the time-evolving surface density in non-Boussinesq mode [Z T-1 ~> m s-1] + U_star_H_2d ! The wind friction velocity in thickness-based units, calculated + ! using the Boussinesq reference density or the time-evolving + ! surface density in non-Boussinesq mode [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZI_(G)) :: & TKE, & ! The turbulent kinetic energy available for mixing over a - ! time step [Z L2 T-2 ~> m3 s-2]. + ! time step [H L2 T-2 ~> m3 s-2 or J m-2]. Conv_En, & ! The turbulent kinetic energy source due to mixing down to - ! the depth of free convection [Z L2 T-2 ~> m3 s-2]. + ! the depth of free convection [H L2 T-2 ~> m3 s-2 or J m-2]. htot, & ! The total depth of the layers being considered for ! entrainment [H ~> m or kg m-2]. R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. Rcv_tot, & ! The integrated coordinate value potential density of the ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully @@ -271,14 +281,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! the coordinate variable, set to P_Ref [R L2 T-2 ~> Pa]. dR0_dT, & ! Partial derivative of the mixed layer potential density with ! temperature [R C-1 ~> kg m-3 degC-1]. + dSpV0_dT, & ! Partial derivative of the mixed layer specific volume with + ! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. dRcv_dT, & ! Partial derivative of the coordinate variable potential ! density in the mixed layer with temperature [R C-1 ~> kg m-3 degC-1]. dR0_dS, & ! Partial derivative of the mixed layer potential density with ! salinity [R S-1 ~> kg m-3 ppt-1]. + dSpV0_dS, & ! Partial derivative of the mixed layer specific volume with + ! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. dRcv_dS, & ! Partial derivative of the coordinate variable potential ! density in the mixed layer with salinity [R S-1 ~> kg m-3 ppt-1]. + p_sfc, & ! The sea surface pressure [R L2 T-2 ~> Pa] + dp_ml, & ! The pressure change across the mixed layer [R L2 T-2 ~> Pa] + SpV_ml, & ! The specific volume averaged across the mixed layer [R-1 ~> m3 kg-1] TKE_river ! The source of turbulent kinetic energy available for mixing - ! at rivermouths [Z L2 T-3 ~> m3 s-3]. + ! at rivermouths [H L2 T-3 ~> m3 s-3 or W m-2]. real, dimension(max(CS%nsw,1),SZI_(G)) :: & Pen_SW_bnd ! The penetrating fraction of the shortwave heating integrated @@ -294,16 +311,17 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. real :: RmixConst ! A combination of constants used in the river mixing energy - ! calculation [L2 T-2 R-2 ~> m8 s-2 kg-2] + ! calculation [H L2 Z-1 T-2 R-2 ~> m8 s-2 kg-2 or m5 s-2 kg-1] or + ! [H L2 Z-1 T-2 ~> m2 s-2 or kg m-1 s-2] real, dimension(SZI_(G)) :: & dKE_FC, & ! The change in mean kinetic energy due to free convection - ! [Z L2 T-2 ~> m3 s-2]. + ! [H L2 T-2 ~> m3 s-2 or J m-2]. h_CA ! The depth to which convective adjustment has gone [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)) :: & dKE_CA, & ! The change in mean kinetic energy due to convective - ! adjustment [Z L2 T-2 ~> m3 s-2]. + ! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. cTKE ! The turbulent kinetic energy source due to convective - ! adjustment [Z L2 T-2 ~> m3 s-2]. + ! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZJ_(G)) :: & Hsfc_max, & ! The thickness of the surface region (mixed and buffer layers) ! after entrainment but before any buffer layer detrainment [H ~> m or kg m-2]. @@ -322,8 +340,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C real :: dHsfc, dHD ! Local copies of nondimensional parameters [nondim] real :: H_nbr ! A minimum thickness based on neighboring thicknesses [H ~> m or kg m-2]. - real :: absf_x_H ! The absolute value of f times the mixed layer thickness [Z T-1 ~> m s-1]. - real :: kU_star ! Ustar times the Von Karman constant [Z T-1 ~> m s-1]. + real :: absf_x_H ! The absolute value of f times the mixed layer thickness [H T-1 ~> m s-1 or kg m-2 s-1]. + real :: kU_star ! Ustar times the Von Karman constant [H T-1 ~> m s-1 or kg m-2 s-1]. real :: dt__diag ! A rescaled copy of dt_diag (if present) or dt [T ~> s]. logical :: write_diags ! If true, write out diagnostics with this step. logical :: reset_diags ! If true, zero out the accumulated diagnostics. @@ -340,8 +358,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C if (.not. associated(tv%eqn_of_state)) call MOM_error(FATAL, & "MOM_mixed_layer: Temperature, salinity and an equation of state "//& "must now be used.") - if (.NOT. associated(fluxes%ustar)) call MOM_error(FATAL, & - "MOM_mixed_layer: No surface TKE fluxes (ustar) defined in mixedlayer!") + if (.not. (associated(fluxes%ustar) .or. associated(fluxes%tau_mag))) call MOM_error(FATAL, & + "MOM_mixed_layer: No surface TKE fluxes (ustar or tau_mag) defined in mixedlayer!") nkmb = CS%nkml+CS%nkbl Inkml = 1.0 / REAL(CS%nkml) @@ -417,12 +435,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Extract the friction velocity from the forcing type. call find_ustar(fluxes, tv, U_star_2d, G, GV, US) + if (CS%Resolve_Ekman .and. (CS%nkml>1)) & + call find_ustar(fluxes, tv, U_star_H_2d, G, GV, US, H_T_units=.true.) !$OMP parallel default(shared) firstprivate(dKE_CA,cTKE,h_CA,max_BL_det,p_ref,p_ref_cv) & - !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,Rcv,ksort, & - !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,htot,Ttot,Stot,TKE,Conv_en, & + !$OMP private(h,u,v,h_orig,eps,T,S,opacity_band,d_ea,d_eb,R0,SpV0,Rcv,ksort, & + !$OMP dR0_dT,dR0_dS,dRcv_dT,dRcv_dS,dSpV0_dT,dSpV0_dS,htot,Ttot,Stot,TKE,Conv_en, & !$OMP RmixConst,TKE_river,Pen_SW_bnd,netMassInOut,NetMassOut, & - !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,dKE_FC, & + !$OMP Net_heat,Net_salt,uhtot,vhtot,R0_tot,Rcv_tot,SpV0_tot,dKE_FC, & !$OMP Idecay_len_TKE,cMKE,Hsfc,dHsfc,dHD,H_nbr,kU_Star, & !$OMP absf_x_H,ebml,eaml) !$OMP do @@ -434,7 +454,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C eps(i,k) = 0.0 ; if (k > nkmb) eps(i,k) = GV%Angstrom_H T(i,k) = tv%T(i,j,k) ; S(i,k) = tv%S(i,j,k) enddo ; enddo - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_Z) + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacity_band, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif do k=1,nz ; do i=is,ie d_ea(i,k) = 0.0 ; d_eb(i,k) = 0.0 @@ -449,26 +476,35 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C do k=1,CS%nkml ; do i=is,ie p_ref(i) = p_ref(i) + 0.5*(GV%H_to_RZ*GV%g_Earth)*h(i,k) enddo ; enddo - call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + if (CS%nonBous_energetics) then + call calculate_specific_vol_derivs(T(:,1), S(:,1), p_ref, dSpV0_dT, dSpV0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_spec_vol(T(:,k), S(:,k), p_ref, SpV0(:,k), tv%eqn_of_state, EOSdom) + enddo + else + call calculate_density_derivs(T(:,1), S(:,1), p_ref, dR0_dT, dR0_dS, tv%eqn_of_state, EOSdom) + do k=1,nz + call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) + enddo + endif call calculate_density_derivs(T(:,1), S(:,1), p_ref_cv, dRcv_dT, dRcv_dS, tv%eqn_of_state, EOSdom) do k=1,nz - call calculate_density(T(:,k), S(:,k), p_ref, R0(:,k), tv%eqn_of_state, EOSdom) call calculate_density(T(:,k), S(:,k), p_ref_cv, Rcv(:,k), tv%eqn_of_state, EOSdom) enddo if (CS%ML_resort) then if (CS%ML_presort_nz_conv_adj > 0) & - call convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, & US, CS, CS%ML_presort_nz_conv_adj) - call sort_ML(h, R0, eps, G, GV, CS, ksort) + call sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) else do k=1,nz ; do i=is,ie ; ksort(i,k) = k ; enddo ; enddo ! Undergo instantaneous entrainment into the buffer layers and mixed layers ! to remove hydrostatic instabilities. Any water that is lighter than ! currently in the mixed or buffer layer is entrained. - call convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) + call convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, dKE_CA, cTKE, j, G, GV, US, CS) do i=is,ie ; h_CA(i) = h(i,1) ; enddo endif @@ -478,18 +514,26 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Here we add an additional source of TKE to the mixed layer where river ! is present to simulate unresolved estuaries. The TKE input is diagnosed ! as follows: - ! TKE_river[Z L2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * + ! TKE_river[H L2 T-3 ~> m3 s-3] = 0.5*rivermix_depth * g * Irho0**2 * drho_ds * ! River*(Samb - Sriver) = CS%mstar*U_star^3 ! where River is in units of [R Z T-1 ~> kg m-2 s-1]. ! Samb = Ambient salinity at the mouth of the estuary ! rivermix_depth = The prescribed depth over which to mix river inflow ! drho_ds = The gradient of density wrt salt at the ambient surface salinity. ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) - RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 - do i=is,ie - TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & - (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) - enddo + if (CS%nonBous_energetics) then + RmixConst = -0.5*CS%rivermix_depth * GV%g_Earth + do i=is,ie + TKE_river(i) = max(0.0, RmixConst * dSpV0_dS(i) * & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + enddo + else + RmixConst = 0.5*CS%rivermix_depth * GV%g_Earth * Irho0**2 + do i=is,ie + TKE_river(i) = max(0.0, RmixConst*dR0_dS(i)* & + (fluxes%lrunoff(i,j) + fluxes%frunoff(i,j)) * S(i,1)) + enddo + endif else do i=is,ie ; TKE_river(i) = 0.0 ; enddo endif @@ -507,8 +551,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C tv, aggregate_FW_forcing) ! This subroutine causes the mixed layer to entrain to depth of free convection. - call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, Rcv_tot, & - u, v, T, S, R0, Rcv, eps, dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & + call mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, R0_tot, SpV0_tot, Rcv_tot, & + u, v, T, S, R0, SpV0, Rcv, eps, dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, dKE_FC, & j, ksort, G, GV, US, CS, tv, fluxes, dt, aggregate_FW_forcing) @@ -520,14 +564,14 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! First the TKE at the depth of free convection that is available ! to drive mixing is calculated. call find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & j, ksort, G, GV, US, CS) ! Here the mechanically driven entrainment occurs. call mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, dR0_dT, dRcv_dT, & - cMKE, Idt_diag, nsw, Pen_SW_bnd, opacity_band, TKE, & - Idecay_len_TKE, j, ksort, G, GV, US, CS) + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, Pen_SW_bnd, & + opacity_band, TKE, Idecay_len_TKE, j, ksort, G, GV, US, CS) call absorbRemainingSW(G, GV, US, h(:,1:), opacity_band, nsw, optics, j, dt, & CS%H_limit_fluxes, CS%correct_absorption, CS%absorb_all_SW, & @@ -540,19 +584,46 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! Calculate the homogeneous mixed layer properties and store them in layer 0. do i=is,ie ; if (htot(i) > 0.0) then Ih = 1.0 / htot(i) - R0(i,0) = R0_tot(i) * Ih ; Rcv(i,0) = Rcv_tot(i) * Ih + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0_tot(i) * Ih + else + R0(i,0) = R0_tot(i) * Ih + endif + Rcv(i,0) = Rcv_tot(i) * Ih T(i,0) = Ttot(i) * Ih ; S(i,0) = Stot(i) * Ih h(i,0) = htot(i) else ! This may not ever be needed? - T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; R0(i,0) = R0(i,1) ; Rcv(i,0) = Rcv(i,1) + T(i,0) = T(i,1) ; S(i,0) = S(i,1) ; Rcv(i,0) = Rcv(i,1) + if (CS%nonBous_energetics) then + SpV0(i,0) = SpV0(i,1) + else + R0(i,0) = R0(i,1) + endif h(i,0) = htot(i) endif ; enddo if (write_diags .and. allocated(CS%ML_depth)) then ; do i=is,ie CS%ML_depth(i,j) = h(i,0) ! Store the diagnostic. enddo ; endif - if (associated(Hml)) then ; do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * (h(i,0) * GV%H_to_Z) ! Rescale the diagnostic for output. - enddo ; endif + + if (associated(Hml)) then + ! Return the mixed layerd depth in [Z ~> m]. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + Hml(i,j) = G%mask2dT(i,j) * GV%H_to_Z*h(i,0) + enddo + else + do i=is,ie ; dp_ml(i) = GV%g_Earth * GV%H_to_RZ * h(i,0) ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p_sfc(i) = tv%p_surf(i,j) ; enddo + else + do i=is,ie ; p_sfc(i) = 0.0 ; enddo + endif + call average_specific_vol(T(:,0), S(:,0), p_sfc, dp_ml, SpV_ml, tv%eqn_of_state) + do i=is,ie + Hml(i,j) = G%mask2dT(i,j) * GV%H_to_RZ * SpV_ml(i) * h(i,0) + enddo + endif + endif ! At this point, return water to the original layers, but constrained to ! still be sorted. After this point, all the water that is in massive @@ -565,8 +636,8 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! these unused layers (but not currently in the code). if (CS%ML_resort) then - call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & - d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) + call resort_ML(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), GV%Rlay(:), eps, & + d_ea, d_eb, ksort, G, GV, CS, dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) endif if (CS%limit_det .or. (CS%id_Hsfc_max > 0) .or. (CS%id_Hsfc_min > 0)) then @@ -598,13 +669,13 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! from the buffer layer into the interior. These steps might best be ! treated in conjunction. if (CS%nkbl == 1) then - call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & + call mixedlayer_detrain_1(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, d_eb, j, G, GV, US, CS, & dRcv_dT, dRcv_dS, max_BL_det) elseif (CS%nkbl == 2) then - call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), Rcv(:,0:), & + call mixedlayer_detrain_2(h(:,0:), T(:,0:), S(:,0:), R0(:,0:), SpV0(:,0:), Rcv(:,0:), & GV%Rlay(:), dt, dt__diag, d_ea, j, G, GV, US, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) else ! CS%nkbl not = 1 or 2 ! This code only works with 1 or 2 buffer layers. call MOM_error(FATAL, "MOM_mixed_layer: CS%nkbl must be 1 or 2 for now.") @@ -628,14 +699,21 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C ! as the third piece will then optimally describe mixed layer ! restratification. For nkml>=4 the whole strategy should be revisited. do i=is,ie - kU_star = CS%vonKar*fluxes%ustar(i,j) ! Maybe could be replaced with u*+w*? - if (associated(fluxes%ustar_shelf) .and. & - associated(fluxes%frac_shelf_h)) then - if (fluxes%frac_shelf_h(i,j) > 0.0) & - kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & - fluxes%frac_shelf_h(i,j) * (CS%vonKar*fluxes%ustar_shelf(i,j)) + ! Perhaps in the following, u* could be replaced with u*+w*? + kU_star = CS%vonKar * U_star_H_2d(i,j) + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then + if (fluxes%frac_shelf_h(i,j) > 0.0) then + if (allocated(tv%SpV_avg)) then + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * ((CS%vonKar*fluxes%ustar_shelf(i,j)) / & + (GV%H_to_RZ * tv%SpV_avg(i,j,1))) + else + kU_star = (1.0 - fluxes%frac_shelf_h(i,j)) * kU_star + & + fluxes%frac_shelf_h(i,j) * (CS%vonKar*GV%Z_to_H*fluxes%ustar_shelf(i,j)) + endif + endif endif - absf_x_H = 0.25 * GV%H_to_Z * h(i,0) * & + absf_x_H = 0.25 * h(i,0) * & ((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) ! If the mixed layer vertical viscosity specification is changed in @@ -756,7 +834,7 @@ end subroutine bulkmixedlayer !> This subroutine does instantaneous convective entrainment into the buffer !! layers and mixed layers to remove hydrostatic instabilities. Any water that !! is lighter than currently in the mixed- or buffer- layer is entrained. -subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & +subroutine convective_adjustment(h, u, v, R0, SpV0, Rcv, T, S, eps, d_eb, & dKE_CA, cTKE, j, G, GV, US, CS, nz_conv) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -768,6 +846,8 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! points [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: T !< Layer temperatures [C ~> degC]. @@ -780,10 +860,10 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & !! a layer. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment [Z L2 T-2 ~> m3 s-2]. + !! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(out) :: cTKE !< The buoyant turbulent kinetic energy !! source due to convective adjustment - !! [Z L2 T-2 ~> m3 s-2]. + !! [H L2 T-2 ~> m3 s-2 or J m-2]. integer, intent(in) :: j !< The j-index to work on. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure @@ -795,6 +875,8 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & real, dimension(SZI_(G)) :: & R0_tot, & ! The integrated potential density referenced to the surface ! of the layers which are fully entrained [H R ~> kg m-2 or kg2 m-5]. + SpV0_tot, & ! The integrated specific volume referenced to the surface + ! of the layers which are fully entrained [H R-1 ~> m4 kg-1 or m]. Rcv_tot, & ! The integrated coordinate value potential density of the ! layers that are fully entrained [H R ~> kg m-2 or kg2 m-5]. Ttot, & ! The integrated temperature of layers which are fully @@ -808,13 +890,14 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & h_orig_k1 ! The depth of layer k1 before convective adjustment [H ~> m or kg m-2]. real :: h_ent ! The thickness from a layer that is entrained [H ~> m or kg m-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! in [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. + logical :: unstable integer :: is, ie, nz, i, k, k1, nzc, nkmb is = G%isc ; ie = G%iec ; nz = GV%ke - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) nzc = nz ; if (present(nz_conv)) nzc = nz_conv nkmb = CS%nkml+CS%nkbl @@ -826,7 +909,11 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & h_orig_k1(i) = h(i,k1) KE_orig(i) = 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2) uhtot(i) = h(i,k1)*u(i,k1) ; vhtot(i) = h(i,k1)*v(i,k1) - R0_tot(i) = R0(i,k1) * h(i,k1) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0(i,k1) * h(i,k1) + else + R0_tot(i) = R0(i,k1) * h(i,k1) + endif cTKE(i,k1) = 0.0 ; dKE_CA(i,k1) = 0.0 Rcv_tot(i) = Rcv(i,k1) * h(i,k1) @@ -834,15 +921,28 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & enddo do k=k1+1,nzc do i=is,ie - if ((h(i,k) > eps(i,k)) .and. (R0_tot(i) > h(i,k1)*R0(i,k))) then + if (CS%nonBous_energetics) then + unstable = (SpV0_tot(i) < h(i,k1)*SpV0(i,k)) + else + unstable = (R0_tot(i) > h(i,k1)*R0(i,k)) + endif + if ((h(i,k) > eps(i,k)) .and. unstable) then h_ent = h(i,k)-eps(i,k) - cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H2_2Rho0 * & - (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + cTKE(i,k1) = cTKE(i,k1) + 0.5 * h_ent * (GV%g_Earth * GV%H_to_RZ) * & + (h(i,k1)*SpV0(i,k) - SpV0_tot(i)) * CS%nstar2 + SpV0_tot(i) = SpV0_tot(i) + h_ent * SpV0(i,k) + else + cTKE(i,k1) = cTKE(i,k1) + h_ent * g_H_2Rho0 * & + (R0_tot(i) - h(i,k1)*R0(i,k)) * CS%nstar2 + R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) + endif if (k < nkmb) then cTKE(i,k1) = cTKE(i,k1) + cTKE(i,k) dKE_CA(i,k1) = dKE_CA(i,k1) + dKE_CA(i,k) endif - R0_tot(i) = R0_tot(i) + h_ent * R0(i,k) KE_orig(i) = KE_orig(i) + 0.5*h_ent* & (u(i,k)*u(i,k) + v(i,k)*v(i,k)) uhtot(i) = uhtot(i) + h_ent*u(i,k) @@ -862,10 +962,14 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! layer in question, if it has entrained. do i=is,ie ; if (h(i,k1) > h_orig_k1(i)) then Ih = 1.0 / h(i,k1) - R0(i,k1) = R0_tot(i) * Ih + if (CS%nonBous_energetics) then + SpV0(i,k1) = SpV0_tot(i) * Ih + else + R0(i,k1) = R0_tot(i) * Ih + endif u(i,k1) = uhtot(i) * Ih ; v(i,k1) = vhtot(i) * Ih - dKE_CA(i,k1) = dKE_CA(i,k1) + GV%H_to_Z * (CS%bulk_Ri_convective * & - (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2))) + dKE_CA(i,k1) = dKE_CA(i,k1) + CS%bulk_Ri_convective * & + (KE_orig(i) - 0.5*h(i,k1)*(u(i,k1)**2 + v(i,k1)**2)) Rcv(i,k1) = Rcv_tot(i) * Ih T(i,k1) = Ttot(i) * Ih ; S(i,k1) = Stot(i) * Ih endif ; enddo @@ -873,7 +977,11 @@ subroutine convective_adjustment(h, u, v, R0, Rcv, T, S, eps, d_eb, & ! If lower mixed or buffer layers are massless, give them the properties of the ! layer above. do k=2,min(nzc,nkmb) ; do i=is,ie ; if (h(i,k) == 0.0) then - R0(i,k) = R0(i,k-1) + if (CS%nonBous_energetics) then + SpV0(i,k) = SpV0(i,k-1) + else + R0(i,k) = R0(i,k-1) + endif Rcv(i,k) = Rcv(i,k-1) ; T(i,k) = T(i,k-1) ; S(i,k) = S(i,k-1) endif ; enddo ; enddo @@ -883,8 +991,8 @@ end subroutine convective_adjustment !! convection. The depth of free convection is the shallowest depth at which the !! fluid is denser than the average of the fluid above. subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & - dR0_dT, dRcv_dT, dR0_dS, dRcv_dS, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, dR0_dS, dSpV0_dS, dRcv_dS, & netMassInOut, netMassOut, Net_heat, Net_salt, & nsw, Pen_SW_bnd, opacity_band, Conv_En, & dKE_FC, j, ksort, G, GV, US, CS, tv, fluxes, dt, & @@ -909,6 +1017,8 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(out) :: R0_tot !< The integrated mixed layer potential density referenced !! to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(out) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. real, dimension(SZI_(G)), intent(out) :: Rcv_tot !< The integrated mixed layer coordinate !! variable potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & @@ -922,6 +1032,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. @@ -930,10 +1043,14 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(SZI_(G)), intent(in) :: dR0_dS !< The partial derivative of R0 with respect to !! salinity [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect to + !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dS !< The partial derivative of Rcv with respect to !! salinity [R S-1 ~> kg m-3 ppt-1]. real, dimension(SZI_(G)), intent(in) :: netMassInOut !< The net mass flux (if non-Boussinesq) @@ -954,9 +1071,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(max(nsw,1),SZI_(G),SZK_(GV)), intent(in) :: opacity_band !< The opacity in each band of !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(out) :: Conv_En !< The buoyant turbulent kinetic energy source - !! due to free convection [Z L2 T-2 ~> m3 s-2]. + !! due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(out) :: dKE_FC !< The vertically integrated change in kinetic - !! energy due to free convection [Z L2 T-2 ~> m3 s-2]. + !! energy due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & intent(in) :: ksort !< The density-sorted k-indices. @@ -992,7 +1109,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: T_precip ! The temperature of the precipitation [C ~> degC]. real :: C1_3, C1_6 ! 1/3 and 1/6 [nondim] real :: En_fn, Frac, x1 ! Nondimensional temporary variables [nondim]. - real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. + real :: dr, dr0 ! Temporary variables [R H ~> kg m-2 or kg2 m-5] or [R-1 H ~> m4 kg-1 or m]. real :: dr_ent, dr_comp ! Temporary variables [R H ~> kg m-2 or kg2 m-5]. real :: dr_dh ! The partial derivative of dr_ent with h_ent [R ~> kg m-3]. real :: h_min, h_max ! The minimum and maximum estimates for h_ent [H ~> m or kg m-2] @@ -1000,9 +1117,9 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real :: h_evap ! The thickness that is evaporated [H ~> m or kg m-2]. real :: dh_Newt ! The Newton's method estimate of the change in ! h_ent between iterations [H ~> m or kg m-2]. - real :: g_H2_2Rho0 ! Half the gravitational acceleration times the square of + real :: g_H_2Rho0 ! Half the gravitational acceleration times ! the conversion from H to Z divided by the mean density, - ! [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: opacity ! The opacity converted to inverse thickness units [H-1 ~> m-1 or m2 kg-1] real :: sum_Pen_En ! The potential energy change due to penetrating @@ -1016,7 +1133,7 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Angstrom = GV%Angstrom_H C1_3 = 1.0/3.0 ; C1_6 = 1.0/6.0 - g_H2_2Rho0 = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0) + g_H_2Rho0 = (GV%g_Earth * GV%H_to_Z) / (2.0 * GV%Rho0) Idt = 1.0 / dt is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1060,10 +1177,17 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Stot(i) = h_ent*S(i,k) + Net_salt(i) uhtot(i) = u(i,1)*netMassIn(i) + u(i,k)*h_ent vhtot(i) = v(i,1)*netMassIn(i) + v(i,k)*h_ent - R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & + if (CS%nonBous_energetics) then + SpV0_tot(i) = (h_ent*SpV0(i,k) + netMassIn(i)*SpV0(i,1)) + & +! dSpV0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & + (dSpV0_dT(i)*(Net_heat(i) + Pen_absorbed) - & + dSpV0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + else + R0_tot(i) = (h_ent*R0(i,k) + netMassIn(i)*R0(i,1)) + & ! dR0_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & (dR0_dT(i)*(Net_heat(i) + Pen_absorbed) - & dR0_dS(i) * (netMassIn(i) * S(i,1) - Net_salt(i))) + endif Rcv_tot(i) = (h_ent*Rcv(i,k) + netMassIn(i)*Rcv(i,1)) + & ! dRcv_dT(i)*netMassIn(i)*(T_precip - T(i,1)) + & (dRcv_dT(i)*(Net_heat(i) + Pen_absorbed) - & @@ -1075,7 +1199,8 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & if (associated(tv%TempxPmE)) tv%TempxPmE(i,j) = tv%TempxPmE(i,j) + & T_precip * netMassIn(i) * GV%H_to_RZ else ! This is a massless column, but zero out the summed variables anyway for safety. - htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; R0_tot(i) = 0.0 ; Rcv_tot = 0.0 + htot(i) = 0.0 ; Ttot(i) = 0.0 ; Stot(i) = 0.0 ; Rcv_tot = 0.0 + R0_tot(i) = 0.0 ; SpV0_tot(i) = 0.0 uhtot(i) = 0.0 ; vhtot(i) = 0.0 ; Conv_En(i) = 0.0 ; dKE_FC(i) = 0.0 endif ; enddo @@ -1093,7 +1218,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent - R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + h_ent*SpV0(i,k) + else + R0_tot(i) = R0_tot(i) + h_ent*R0(i,k) + endif uhtot(i) = uhtot(i) + h_ent*u(i,k) vhtot(i) = vhtot(i) + h_ent*v(i,k) @@ -1117,7 +1246,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif Stot(i) = Stot(i) + h_evap*S(i,k) - R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + dSpV0_dS(i)*h_evap*S(i,k) + else + R0_tot(i) = R0_tot(i) + dR0_dS(i)*h_evap*S(i,k) + endif Rcv_tot(i) = Rcv_tot(i) + dRcv_dS(i)*h_evap*S(i,k) d_eb(i,k) = d_eb(i,k) - h_evap @@ -1136,14 +1269,25 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! The following section calculates how much fluid will be entrained. h_avail = h(i,k) - eps(i,k) if (h_avail > 0.0) then - dr = R0_tot(i) - htot(i)*R0(i,k) h_ent = 0.0 - dr0 = dr - do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then - dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & - opacity_band(n,i,k)*htot(i) - endif ; enddo + if (CS%nonBous_energetics) then + dr = htot(i)*SpV0(i,k) - SpV0_tot(i) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + else + dr = R0_tot(i) - htot(i)*R0(i,k) + + dr0 = dr + do n=1,nsw ; if (Pen_SW_bnd(n,i) > 0.0) then + dr0 = dr0 - (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + opacity_band(n,i,k)*htot(i) + endif ; enddo + endif ! Some entrainment will occur from this layer. if (dr0 > 0.0) then @@ -1153,8 +1297,13 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! density averaged over the mixed layer and that layer. opacity = opacity_band(n,i,k) SW_trans = exp(-h_avail*opacity) - dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & - ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + if (CS%nonBous_energetics) then + dr_comp = dr_comp - (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + else + dr_comp = dr_comp + (dR0_dT(i)*Pen_SW_bnd(n,i)) * & + ((1.0 - SW_trans) - opacity*(htot(i)+h_avail)*SW_trans) + endif endif ; enddo if (dr_comp >= 0.0) then ! The entire layer is entrained. @@ -1171,7 +1320,11 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_min = 0.0 ; h_max = h_avail do n=1,nsw - r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + if (CS%nonBous_energetics) then + r_SW_top(n) = -dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + r_SW_top(n) = dR0_dT(i) * Pen_SW_bnd(n,i) + endif C2(n) = r_SW_top(n) * opacity_band(n,i,k)**2 enddo do itt=1,10 @@ -1218,27 +1371,40 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & En_fn = ((opacity*htot(i) + 2.0) * & ((1.0-SW_trans) / x1) - 1.0 + SW_trans) endif - sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + if (CS%nonBous_energetics) then + sum_Pen_En = sum_Pen_En + (dSpV0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + else + sum_Pen_En = sum_Pen_En - (dR0_dT(i)*Pen_SW_bnd(n,i)) * En_fn + endif Pen_absorbed = Pen_absorbed + Pen_SW_bnd(n,i) * (1.0 - SW_trans) Pen_SW_bnd(n,i) = Pen_SW_bnd(n,i) * SW_trans endif ; enddo - Conv_En(i) = Conv_En(i) + g_H2_2Rho0 * h_ent * & - ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + if (CS%nonBous_energetics) then + ! This and the other energy calculations assume that specific volume is + ! conserved during mixing, which ignores certain thermobaric contributions. + Conv_En(i) = Conv_En(i) + 0.5 * (GV%g_Earth * GV%H_to_RZ) * h_ent * & + ( (SpV0(i,k)*htot(i) - SpV0_tot(i)) + sum_Pen_En ) + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + Conv_En(i) = Conv_En(i) + g_H_2Rho0 * h_ent * & + ( (R0_tot(i) - R0(i,k)*htot(i)) + sum_Pen_En ) + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif - R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) Stot(i) = Stot(i) + h_ent * S(i,k) Ttot(i) = Ttot(i) + (h_ent * T(i,k) + Pen_absorbed) Rcv_tot(i) = Rcv_tot(i) + (h_ent * Rcv(i,k) + Pen_absorbed*dRcv_dT(i)) endif ! dr0 > 0.0 - if (h_ent > 0.0) then - if (htot(i) > 0.0) & + + if ((h_ent > 0.0) .and. (htot(i) > 0.0)) & dKE_FC(i) = dKE_FC(i) + CS%bulk_Ri_convective * 0.5 * & - ((GV%H_to_Z*h_ent) / (htot(i)*(h_ent+htot(i)))) * & + ((h_ent) / (htot(i)*(h_ent+htot(i)))) * & ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) + if (h_ent > 0.0) then htot(i) = htot(i) + h_ent h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent @@ -1249,7 +1415,6 @@ subroutine mixedlayer_convection(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif endif - endif ! h_avail>0 endif ; enddo ! i loop enddo ! k loop @@ -1259,7 +1424,7 @@ end subroutine mixedlayer_convection !> This subroutine determines the TKE available at the depth of free !! convection to drive mechanical entrainment. subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_FC, dKE_CA, & - TKE, TKE_river, Idecay_len_TKE, cMKE, dt, Idt_diag, & + TKE, TKE_river, Idecay_len_TKE, cMKE, tv, dt, Idt_diag, & j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -1276,28 +1441,30 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F !! the time-evolving surface density in !! non-Boussinesq mode [Z T-1 ~> m s-1] real, dimension(SZI_(G)), intent(inout) :: Conv_En !< The buoyant turbulent kinetic energy source - !! due to free convection [Z L2 T-2 ~> m3 s-2]. + !! due to free convection [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(in) :: dKE_FC !< The vertically integrated change in !! kinetic energy due to free convection - !! [Z L2 T-2 ~> m3 s-2]. + !! [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: cTKE !< The buoyant turbulent kinetic energy !! source due to convective adjustment - !! [Z L2 T-2 ~> m3 s-2]. + !! [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G),SZK_(GV)), & intent(in) :: dKE_CA !< The vertically integrated change in !! kinetic energy due to convective - !! adjustment [Z L2 T-2 ~> m3 s-2]. + !! adjustment [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(out) :: TKE !< The turbulent kinetic energy available for - !! mixing over a time step [Z L2 T-2 ~> m3 s-2]. + !! mixing over a time step [H L2 T-2 ~> m3 s-2 or J m-2] real, dimension(SZI_(G)), intent(out) :: Idecay_len_TKE !< The inverse of the vertical decay !! scale for TKE [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(in) :: TKE_river !< The source of turbulent kinetic energy !! available for driving mixing at river mouths - !! [Z L2 T-3 ~> m3 s-3]. + !! [H L2 T-3 ~> m3 s-3 or W m-2]. real, dimension(2,SZI_(G)), intent(out) :: cMKE !< Coefficients of HpE and HpE^2 in !! calculating the denominator of MKE_rate, !! [H-1 ~> m-1 or m2 kg-1] and [H-2 ~> m-2 or m4 kg-2]. + type(thermo_var_ptrs), intent(inout) :: tv !< A structure containing pointers to any + !! available thermodynamic fields. real, intent(in) :: dt !< The time step [T ~> s]. real, intent(in) :: Idt_diag !< The inverse of the accumulated diagnostic !! time interval [T-1 ~> s-1]. @@ -1310,24 +1477,26 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F ! convection to drive mechanical entrainment. ! Local variables - real :: dKE_conv ! The change in mean kinetic energy due to all convection [Z L2 T-2 ~> m3 s-2]. + real :: dKE_conv ! The change in mean kinetic energy due to all convection [H L2 T-2 ~> m3 s-2 or J m-2]. real :: nstar_FC ! The effective efficiency with which the energy released by ! free convection is converted to TKE, often ~0.2 [nondim]. real :: nstar_CA ! The effective efficiency with which the energy released by ! convective adjustment is converted to TKE, often ~0.2 [nondim]. real :: TKE_CA ! The potential energy released by convective adjustment if - ! that release is positive [Z L2 T-2 ~> m3 s-2]. + ! that release is positive [H L2 T-2 ~> m3 s-2 or J m-2]. real :: MKE_rate_CA ! MKE_rate for convective adjustment [nondim], 0 to 1. real :: MKE_rate_FC ! MKE_rate for free convection [nondim], 0 to 1. - real :: totEn_Z ! The total potential energy released by convection, [Z3 T-2 ~> m3 s-2]. + real :: totEn_Z ! The total potential energy released by convection, [H Z2 T-2 ~> m3 s-2 or J m-2]. real :: Ih ! The inverse of a thickness [H-1 ~> m-1 or m2 kg-1]. real :: exp_kh ! The nondimensional decay of TKE across a layer [nondim]. real :: absf ! The absolute value of f averaged to thickness points [T-1 ~> s-1]. real :: U_star ! The friction velocity [Z T-1 ~> m s-1]. - real :: absf_Ustar ! The absolute value of f divided by U_star [Z-1 ~> m-1]. - real :: wind_TKE_src ! The surface wind source of TKE [Z L2 T-3 ~> m3 s-3]. + real :: absf_Ustar ! The absolute value of f divided by U_star converted to thickness units [H-1 ~> m-1 or m2 kg-1] + real :: wind_TKE_src ! The surface wind source of TKE [H L2 T-3 ~> m3 s-3 or W m-2]. real :: diag_wt ! The ratio of the current timestep to the diagnostic ! timestep (which may include 2 calls) [nondim]. + real :: H_to_Z ! The thickness to depth conversion factor, which in non-Boussinesq mode is + ! based on the layer-averaged specific volume [Z H-1 ~> nondim or m3 kg-1] integer :: is, ie, nz, i is = G%isc ; ie = G%iec ; nz = GV%ke @@ -1337,6 +1506,12 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F do i=is,ie U_star = U_star_2d(i,j) + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + H_to_Z = GV%H_to_Z + else + H_to_Z = GV%H_to_RZ * tv%SpV_avg(i,j,1) + endif + if (associated(fluxes%ustar_shelf) .and. associated(fluxes%frac_shelf_h)) then if (fluxes%frac_shelf_h(i,j) > 0.0) & U_star = (1.0 - fluxes%frac_shelf_h(i,j)) * U_star + & @@ -1344,14 +1519,15 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F endif if (U_star < CS%ustar_min) U_star = CS%ustar_min + if (CS%omega_frac < 1.0) then absf = 0.25*((abs(G%CoriolisBu(I,J)) + abs(G%CoriolisBu(I-1,J-1))) + & (abs(G%CoriolisBu(I,J-1)) + abs(G%CoriolisBu(I-1,J)))) if (CS%omega_frac > 0.0) & absf = sqrt(CS%omega_frac*4.0*CS%omega**2 + (1.0-CS%omega_frac)*absf**2) endif - absf_Ustar = absf / U_star - Idecay_len_TKE(i) = (absf_Ustar * CS%TKE_decay) * GV%H_to_Z + absf_Ustar = H_to_Z * absf / U_star + Idecay_len_TKE(i) = absf_Ustar * CS%TKE_decay ! The first number in the denominator could be anywhere up to 16. The ! value of 3 was chosen to minimize the time-step dependence of the amount @@ -1362,9 +1538,9 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F ! This equation assumes that small & large scales contribute to mixed layer ! deepening at similar rates, even though small scales are dissipated more ! rapidly (implying they are less efficient). -! Ih = 1.0/(16.0*CS%vonKar*U_star*dt) - Ih = GV%H_to_Z/(3.0*CS%vonKar*U_star*dt) - cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = (absf_Ustar*GV%H_to_Z) * Ih +! Ih = H_to_Z / (16.0*CS%vonKar*U_star*dt) + Ih = H_to_Z / (3.0*CS%vonKar*U_star*dt) + cMKE(1,i) = 4.0 * Ih ; cMKE(2,i) = absf_Ustar * Ih if (Idecay_len_TKE(i) > 0.0) then exp_kh = exp(-htot(i)*Idecay_len_TKE(i)) @@ -1382,7 +1558,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F if (totEn_Z > 0.0) then nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1392,7 +1568,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F if (Conv_En(i) > 0.0) then totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA * (htot(i) / h_CA(i)) ) nstar_FC = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(htot(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*htot(i))**3) * totEn_Z)) else nstar_FC = CS%nstar endif @@ -1400,7 +1576,7 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F totEn_Z = US%L_to_Z**2 * (Conv_En(i) + TKE_CA) if (TKE_CA > 0.0) then nstar_CA = CS%nstar * totEn_Z / (totEn_Z + 0.2 * & - sqrt(0.5 * dt * (absf*(h_CA(i)*GV%H_to_Z))**3 * totEn_Z)) + sqrt(0.5 * dt * (H_to_Z**2*(absf*h_CA(i))**3) * totEn_Z)) else nstar_CA = CS%nstar endif @@ -1422,15 +1598,25 @@ subroutine find_starting_TKE(htot, h_CA, fluxes, U_star_2d, Conv_En, cTKE, dKE_F dKE_conv = dKE_CA(i,1) * MKE_rate_CA + dKE_FC(i) * MKE_rate_FC ! At this point, it is assumed that cTKE is positive and stored in TKE_CA! ! Note: Removed factor of 2 in u*^3 terms. - TKE(i) = (dt*CS%mstar)*((US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & - (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + TKE(i) = (dt*CS%mstar)*((GV%Z_to_H*US%Z_to_L**2*(U_star*U_Star*U_Star))*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + else + ! Note that GV%Z_to_H*US%Z_to_L**2*U_star**3 = GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star + TKE(i) = (dt*CS%mstar) * ((GV%RZ_to_H*US%Z_to_L * fluxes%tau_mag(i,j) * U_star)*exp_kh) + & + (exp_kh * dKE_conv + nstar_FC*Conv_En(i) + nstar_CA * TKE_CA) + endif if (CS%do_rivermix) then ! Add additional TKE at river mouths TKE(i) = TKE(i) + TKE_river(i)*dt*exp_kh endif if (CS%TKE_diagnostics) then - wind_TKE_src = CS%mstar*(US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + if (GV%Boussinesq .or. GV%semi_Boussinesq .or. .not.(associated(fluxes%tau_mag))) then + wind_TKE_src = CS%mstar*(GV%Z_to_H*US%Z_to_L**2*U_star*U_Star*U_Star) * diag_wt + else + wind_TKE_src = CS%mstar*(GV%RZ_to_H * US%Z_to_L*fluxes%tau_mag(i,j) * U_star) * diag_wt + endif CS%diag_TKE_wind(i,j) = CS%diag_TKE_wind(i,j) + & ( wind_TKE_src + TKE_river(i) * diag_wt ) CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + dKE_conv*Idt_diag @@ -1449,8 +1635,8 @@ end subroutine find_starting_TKE !> This subroutine calculates mechanically driven entrainment. subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & - R0_tot, Rcv_tot, u, v, T, S, R0, Rcv, eps, & - dR0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & + R0_tot, SpV0_tot, Rcv_tot, u, v, T, S, R0, SpV0, Rcv, eps, & + dR0_dT, dSpV0_dT, dRcv_dT, cMKE, Idt_diag, nsw, & Pen_SW_bnd, opacity_band, TKE, & Idecay_len_TKE, j, ksort, G, GV, US, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. @@ -1473,6 +1659,8 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! velocity [H L T-1 ~> m2 s-1 or kg m-1 s-1]. real, dimension(SZI_(G)), intent(inout) :: R0_tot !< The integrated mixed layer potential density !! referenced to 0 pressure [H R ~> kg m-2 or kg2 m-5]. + real, dimension(SZI_(G)), intent(inout) :: SpV0_tot !< The integrated mixed layer specific volume referenced + !! to 0 pressure [H R-1 ~> m4 kg-1 or m]. real, dimension(SZI_(G)), intent(inout) :: Rcv_tot !< The integrated mixed layer coordinate variable !! potential density [H R ~> kg m-2 or kg2 m-5]. real, dimension(SZI_(G),SZK_(GV)), & @@ -1486,6 +1674,9 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), & + intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1]. real, dimension(SZI_(G),SZK0_(GV)), & intent(in) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. @@ -1494,6 +1685,8 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! that will be left in each layer [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(in) :: dR0_dT !< The partial derivative of R0 with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect to + !! temperature [R-1 C-1 ~> m3 kg-1 degC-1]. real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of Rcv with respect to !! temperature [R C-1 ~> kg m-3 degC-1]. real, dimension(2,SZI_(G)), intent(in) :: cMKE !< Coefficients of HpE and HpE^2 used in calculating the @@ -1510,7 +1703,7 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & !! penetrating shortwave radiation [H-1 ~> m-1 or m2 kg-1]. real, dimension(SZI_(G)), intent(inout) :: TKE !< The turbulent kinetic energy !! available for mixing over a time - !! step [Z L2 T-2 ~> m3 s-2]. + !! step [H L2 T-2 ~> m3 s-2 or J m-2]. real, dimension(SZI_(G)), intent(inout) :: Idecay_len_TKE !< The vertical TKE decay rate [H-1 ~> m-1 or m2 kg-1]. integer, intent(in) :: j !< The j-index to work on. integer, dimension(SZI_(G),SZK_(GV)), & @@ -1537,18 +1730,18 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & ! conversion from H to m divided by the mean density, ! in [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. real :: TKE_full_ent ! The TKE remaining if a layer is fully entrained - ! [Z L2 T-2 ~> m3 s-2]. + ! [H L2 T-2 ~> m3 s-2 or J m-2]. real :: dRL ! Work required to mix water from the next layer ! across the mixed layer [L2 T-2 ~> m2 s-2]. real :: Pen_En_Contrib ! Penetrating SW contributions to the changes in ! TKE, divided by layer thickness in m [L2 T-2 ~> m2 s-2]. real :: Cpen1 ! A temporary variable [L2 T-2 ~> m2 s-2]. real :: dMKE ! A temporary variable related to the release of mean - ! kinetic energy [H Z L2 T-2 ~> m4 s-2 or kg m s-2] - real :: TKE_ent ! The TKE that remains if h_ent were entrained [Z L2 T-2 ~> m3 s-2]. + ! kinetic energy [H2 L2 T-2 ~> m4 s-2 or kg2 m-2 s-2] + real :: TKE_ent ! The TKE that remains if h_ent were entrained [H L2 T-2 ~> m3 s-2 or J m-2] real :: TKE_ent1 ! The TKE that would remain, without considering the - ! release of mean kinetic energy [Z L2 T-2 ~> m3 s-2]. - real :: dTKE_dh ! The partial derivative of TKE with h_ent [Z L2 T-2 H-1 ~> m2 s-2 or m5 s-2 kg-1]. + ! release of mean kinetic energy [H L2 T-2 ~> m3 s-2 or J m-2] + real :: dTKE_dh ! The partial derivative of TKE with h_ent [L2 T-2 ~> m2 s-2] real :: Pen_dTKE_dh_Contrib ! The penetrating shortwave contribution to ! dTKE_dh [L2 T-2 ~> m2 s-2]. real :: EF4_val ! The result of EF4() (see later) [H-1 ~> m-1 or m2 kg-1]. @@ -1581,8 +1774,12 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & h_avail = h(i,k) - eps(i,k) if ((h_avail > 0.) .and. ((TKE(i) > 0.) .or. (htot(i) < Hmix_min))) then - dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) - dMKE = (GV%H_to_Z * CS%bulk_Ri_ML) * 0.5 * & + if (CS%nonBous_energetics) then + dRL = 0.5 * (GV%g_Earth * GV%H_to_RZ) * (SpV0_tot(i) - SpV0(i,k)*htot(i)) + else + dRL = g_H_2Rho0 * (R0(i,k)*htot(i) - R0_tot(i) ) + endif + dMKE = CS%bulk_Ri_ML * 0.5 * & ((uhtot(i)-u(i,k)*htot(i))**2 + (vhtot(i)-v(i,k)*htot(i))**2) ! Find the TKE that would remain if the entire layer were entrained. @@ -1621,14 +1818,19 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & opacity*h_avail*f2_x1) endif - Pen_En_Contrib = Pen_En_Contrib + & - (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + if (CS%nonBous_energetics) then + Pen_En_Contrib = Pen_En_Contrib - & + (0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + else + Pen_En_Contrib = Pen_En_Contrib + & + (g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i)) * (Pen_En1 - f1_kh) + endif endif ; enddo HpE = htot(i)+h_avail MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) EF4_val = EF4(htot(i)+h_neglect,h_avail,Idecay_len_TKE(i)) - TKE_full_ent = (exp_kh*TKE(i) - (h_avail*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib)) + & + TKE_full_ent = (exp_kh*TKE(i) - h_avail*(dRL*f1_kh + Pen_En_Contrib)) + & MKE_rate*dMKE*EF4_val if ((TKE_full_ent >= 0.0) .or. (h_avail+htot(i) <= Hmix_min)) then ! The layer will be fully entrained. @@ -1637,12 +1839,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & if (CS%TKE_diagnostics) then E_HxHpE = h_ent / ((htot(i)+h_neglect)*(htot(i)+h_ent+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & - Idt_diag * ((exp_kh-1.0)* TKE(i) + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & MKE_rate*dMKE*(EF4_val-E_HxHpE)) - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(GV%H_to_Z*h_ent)*dRL + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(GV%H_to_Z*h_ent)*Pen_En_Contrib + Idt_diag*h_ent*Pen_En_Contrib CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & Idt_diag*MKE_rate*dMKE*E_HxHpE endif @@ -1702,21 +1903,25 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & Pen_En1 = exp_kh * ((1.0+opacity*htot(i))*f1_x1 + & opacity*h_ent*f2_x1) endif - Cpen1 = g_H_2Rho0*dR0_dT(i)*Pen_SW_bnd(n,i) + if (CS%nonBous_energetics) then + Cpen1 = -0.5 * (GV%g_Earth * GV%H_to_RZ) * dSpV0_dT(i) * Pen_SW_bnd(n,i) + else + Cpen1 = g_H_2Rho0 * dR0_dT(i) * Pen_SW_bnd(n,i) + endif Pen_En_Contrib = Pen_En_Contrib + Cpen1*(Pen_En1 - f1_kh) Pen_dTKE_dh_Contrib = Pen_dTKE_dh_Contrib + & Cpen1*((1.0-SW_trans) - opacity*(htot(i) + h_ent)*SW_trans) endif ; enddo ! (Pen_SW_bnd(n,i) > 0.0) - TKE_ent1 = exp_kh* TKE(i) - (h_ent*GV%H_to_Z)*(dRL*f1_kh + Pen_En_Contrib) + TKE_ent1 = exp_kh* TKE(i) - h_ent*(dRL*f1_kh + Pen_En_Contrib) EF4_val = EF4(htot(i)+h_neglect,h_ent,Idecay_len_TKE(i),dEF4_dh) HpE = htot(i)+h_ent MKE_rate = 1.0/(1.0 + (cMKE(1,i)*HpE + cMKE(2,i)*HpE**2)) TKE_ent = TKE_ent1 + dMKE*EF4_val*MKE_rate ! TKE_ent is the TKE that would remain if h_ent were entrained. - dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL*GV%H_to_Z) + & - Pen_dTKE_dh_Contrib*GV%H_to_Z) + dMKE * MKE_rate* & + dTKE_dh = ((-Idecay_len_TKE(i)*TKE_ent1 - dRL) + & + Pen_dTKE_dh_Contrib) + dMKE * MKE_rate* & (dEF4_dh - EF4_val*MKE_rate*(cMKE(1,i)+2.0*cMKE(2,i)*HpE)) ! dh_Newt = -TKE_ent / dTKE_dh ! Bisect if the Newton's method prediction is outside of the bounded range. @@ -1750,14 +1955,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & E_HxHpE = h_ent / ((htot(i)+h_neglect)*(HpE+h_neglect)) CS%diag_TKE_mech_decay(i,j) = CS%diag_TKE_mech_decay(i,j) + & - Idt_diag * ((exp_kh-1.0)* TKE(i) + (h_ent*GV%H_to_Z)*dRL*(1.0-f1_kh) + & + Idt_diag * ((exp_kh-1.0)* TKE(i) + h_ent*dRL*(1.0-f1_kh) + & dMKE*MKE_rate*(EF4_val-E_HxHpE)) - CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - & - Idt_diag*(h_ent*GV%H_to_Z)*dRL - CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - & - Idt_diag*(h_ent*GV%H_to_Z)*Pen_En_Contrib - CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + & - Idt_diag*dMKE*MKE_rate*E_HxHpE + CS%diag_TKE_mixing(i,j) = CS%diag_TKE_mixing(i,j) - Idt_diag*h_ent*dRL + CS%diag_TKE_pen_SW(i,j) = CS%diag_TKE_pen_SW(i,j) - Idt_diag*h_ent*Pen_En_Contrib + CS%diag_TKE_RiBulk(i,j) = CS%diag_TKE_RiBulk(i,j) + Idt_diag*dMKE*MKE_rate*E_HxHpE endif TKE(i) = 0.0 @@ -1771,7 +1973,11 @@ subroutine mechanical_entrainment(h, d_eb, htot, Ttot, Stot, uhtot, vhtot, & endif ; enddo htot(i) = htot(i) + h_ent - R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + if (CS%nonBous_energetics) then + SpV0_tot(i) = SpV0_tot(i) + (h_ent * SpV0(i,k) + Pen_absorbed*dSpV0_dT(i)) + else + R0_tot(i) = R0_tot(i) + (h_ent * R0(i,k) + Pen_absorbed*dR0_dT(i)) + endif h(i,k) = h(i,k) - h_ent d_eb(i,k) = d_eb(i,k) - h_ent @@ -1790,12 +1996,14 @@ end subroutine mechanical_entrainment !> This subroutine generates an array of indices that are sorted by layer !! density. -subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) +subroutine sort_ML(h, R0, SpV0, eps, G, GV, CS, ksort) 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),SZK0_(GV)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: R0 !< The potential density used to sort !! the layers [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(in) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK_(GV)), intent(in) :: eps !< The (small) thickness that must !! remain in each layer [H ~> m or kg m-2]. type(bulkmixedlayer_CS), intent(in) :: CS !< Bulk mixed layer control structure @@ -1803,6 +2011,7 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) ! Local variables real :: R0sort(SZI_(G),SZK_(GV)) ! The sorted potential density [R ~> kg m-3] + real :: SpV0sort(SZI_(G),SZK_(GV)) ! The sorted specific volume [R-1 ~> m3 kg-1] integer :: nsort(SZI_(G)) ! The number of layers left to sort logical :: done_sorting(SZI_(G)) integer :: i, k, ks, is, ie, nz, nkmb @@ -1821,27 +2030,44 @@ subroutine sort_ML(h, R0, eps, G, GV, CS, ksort) do k=1,nz ; do i=is,ie ; ksort(i,k) = -1 ; enddo ; enddo do i=is,ie ; nsort(i) = 0 ; done_sorting(i) = .false. ; enddo - do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then - if (done_sorting(i)) then ; ks = nsort(i) ; else - do ks=nsort(i),1,-1 - if (R0(i,k) >= R0sort(i,ks)) exit - R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) - enddo - if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. - endif - ksort(i,ks+1) = k - R0sort(i,ks+1) = R0(i,k) - nsort(i) = nsort(i) + 1 - endif ; enddo ; enddo + if (CS%nonBous_energetics) then + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (SpV0(i,k) <= SpV0sort(i,ks)) exit + SpV0sort(i,ks+1) = SpV0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + SpV0sort(i,ks+1) = SpV0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + else + do k=1,nz ; do i=is,ie ; if (h(i,k) > eps(i,k)) then + if (done_sorting(i)) then ; ks = nsort(i) ; else + do ks=nsort(i),1,-1 + if (R0(i,k) >= R0sort(i,ks)) exit + R0sort(i,ks+1) = R0sort(i,ks) ; ksort(i,ks+1) = ksort(i,ks) + enddo + if ((k > nkmb) .and. (ks == nsort(i))) done_sorting(i) = .true. + endif + + ksort(i,ks+1) = k + R0sort(i,ks+1) = R0(i,k) + nsort(i) = nsort(i) + 1 + endif ; enddo ; enddo + endif end subroutine sort_ML !> This subroutine actually moves properties between layers to achieve a !! resorted state, with all of the resorted water either moved into the correct !! interior layers or in the top nkmb layers. -subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS) +subroutine resort_ML(h, T, S, R0, SpV0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid !! structure. @@ -1851,6 +2077,8 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Layer salinities [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining !! potential density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -1876,6 +2104,10 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS !! potential density referenced !! to the surface with salinity, !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of SpV0 with respect + !! to temperature [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of SpV0 with respect + !! to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential !! density with potential @@ -1914,15 +2146,18 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS real :: S_up, S_dn ! Salinities projected to match the target densities of two layers [S ~> ppt] real :: R0_up, R0_dn ! Potential densities projected to match the target coordinate ! densities of two layers [R ~> kg m-3] + real :: SpV0_up, SpV0_dn ! Specific volumes projected to be consistent with the target coordinate + ! densities of two layers [R-1 ~> m3 kg-1] real :: I_hup, I_hdn ! Inverse of the new thicknesses of the two layers [H-1 ~> m-1 or m2 kg-1] real :: h_to_up, h_to_dn ! Thickness transferred to two layers [H ~> m or kg m-2] real :: wt_dn ! Fraction of the thickness transferred to the deeper layer [nondim] real :: dR1, dR2 ! Density difference with the target densities of two layers [R ~> kg m-3] - real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging - ! of a pair of layers [R H2 ~> kg m-1 or kg3 m-6] + real :: dPE, min_dPE ! Values proportional to the potential energy change due to the merging of a + ! pair of layers [R H2 ~> kg m-1 or kg3 m-7] or [R-1 H2 ~> m5 kg-1 or kg m-1] real :: hmin, min_hmin ! The thickness of the thinnest layer [H ~> m or kg m-2] real :: h_tmp(SZK_(GV)) ! A copy of the original layer thicknesses [H ~> m or kg m-2] real :: R0_tmp(SZK_(GV)) ! A copy of the original layer potential densities [R ~> kg m-3] + real :: SpV0_tmp(SZK_(GV)) ! A copy of the original layer specific volumes [R ~> kg m-3] real :: T_tmp(SZK_(GV)) ! A copy of the original layer temperatures [C ~> degC] real :: S_tmp(SZK_(GV)) ! A copy of the original layer salinities [S ~> ppt] real :: Rcv_tmp(SZK_(GV)) ! A copy of the original layer coordinate densities [R ~> kg m-3] @@ -2024,13 +2259,19 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS T_dn = T(i,k) + dT_dR * dR2 S_dn = S(i,k) + dS_dR * dR2 - R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 - R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 + if (CS%nonBous_energetics) then + SpV0_up = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR1 + SpV0_dn = SpV0(i,k) + (dT_dR*dSpV0_dT(i) + dS_dR*dSpV0_dS(i)) * dR2 + + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((SpV0_up < SpV0(i,0)) .or. (SpV0_dn < SpV0(i,0))) exit + else + R0_up = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR1 + R0_dn = R0(i,k) + (dT_dR*dR0_dT(i) + dS_dR*dR0_dS(i)) * dR2 - ! Make sure the new properties are acceptable. - if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) & - ! Avoid creating obviously unstable profiles. - exit + ! Make sure the new properties are acceptable, and avoid creating obviously unstable profiles. + if ((R0_up > R0(i,0)) .or. (R0_dn > R0(i,0))) exit + endif wt_dn = (Rcv(i,k) - RcvTgt(k2-1)) / (RcvTgt(k2) - RcvTgt(k2-1)) h_to_up = (h(i,k)-eps(i,k)) * (1.0 - wt_dn) @@ -2038,8 +2279,13 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS I_hup = 1.0 / (h(i,k2-1) + h_to_up) I_hdn = 1.0 / (h(i,k2) + h_to_dn) - R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup - R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + if (CS%nonBous_energetics) then + SpV0(i,k2-1) = (SpV0(i,k2)*h(i,k2-1) + SpV0_up*h_to_up) * I_hup + SpV0(i,k2) = (SpV0(i,k2)*h(i,k2) + SpV0_dn*h_to_dn) * I_hdn + else + R0(i,k2-1) = (R0(i,k2)*h(i,k2-1) + R0_up*h_to_up) * I_hup + R0(i,k2) = (R0(i,k2)*h(i,k2) + R0_dn*h_to_dn) * I_hdn + endif T(i,k2-1) = (T(i,k2)*h(i,k2-1) + T_up*h_to_up) * I_hup T(i,k2) = (T(i,k2)*h(i,k2) + T_dn*h_to_dn) * I_hdn @@ -2083,7 +2329,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ks_min = -1 ; min_dPE = 1.0 ; min_hmin = 0.0 do ks=1,nks-1 k1 = ks2(ks) ; k2 = ks2(ks+1) - dPE = max(0.0, (R0(i,k2)-R0(i,k1)) * h(i,k1) * h(i,k2)) + if (CS%nonBous_energetics) then + dPE = max(0.0, (SpV0(i,k1) - SpV0(i,k2)) * (h(i,k1) * h(i,k2))) + else + dPE = max(0.0, (R0(i,k2) - R0(i,k1)) * h(i,k1) * h(i,k2)) + endif hmin = min(h(i,k1)-eps(i,k1), h(i,k2)-eps(i,k2)) if ((ks_min < 0) .or. (dPE < min_dPE) .or. & ((dPE <= 0.0) .and. (hmin < min_hmin))) then @@ -2101,7 +2351,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS h(i,k_src) = eps(i,k_src) h(i,k_tgt) = h(i,k_tgt) + h_move I_hnew = 1.0 / (h(i,k_tgt)) - R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = (SpV0(i,k_tgt)*h_tgt_old + SpV0(i,k_src)*h_move) * I_hnew + else + R0(i,k_tgt) = (R0(i,k_tgt)*h_tgt_old + R0(i,k_src)*h_move) * I_hnew + endif T(i,k_tgt) = (T(i,k_tgt)*h_tgt_old + T(i,k_src)*h_move) * I_hnew S(i,k_tgt) = (S(i,k_tgt)*h_tgt_old + S(i,k_src)*h_move) * I_hnew @@ -2127,7 +2381,12 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS ! Save all the properties of the nkmb layers that might be replaced. do k=1,nkmb - h_tmp(k) = h(i,k) ; R0_tmp(k) = R0(i,k) + h_tmp(k) = h(i,k) + if (CS%nonBous_energetics) then + SpV0_tmp(k) = SpV0(i,k) + else + R0_tmp(k) = R0(i,k) + endif T_tmp(k) = T(i,k) ; S_tmp(k) = S(i,k) ; Rcv_tmp(k) = Rcv(i,k) h(i,k) = 0.0 @@ -2145,7 +2404,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS h_move = h(i,k_src)-eps(i,k_src) h(i,k_src) = eps(i,k_src) h(i,k_tgt) = h_move - R0(i,k_tgt) = R0(i,k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0(i,k_src) + else + R0(i,k_tgt) = R0(i,k_src) + endif T(i,k_tgt) = T(i,k_src) ; S(i,k_tgt) = S(i,k_src) Rcv(i,k_tgt) = Rcv(i,k_src) @@ -2154,7 +2417,11 @@ subroutine resort_ML(h, T, S, R0, Rcv, RcvTgt, eps, d_ea, d_eb, ksort, G, GV, CS d_eb(i,k_tgt) = d_eb(i,k_tgt) + h_move else h(i,k_tgt) = h_tmp(k_src) - R0(i,k_tgt) = R0_tmp(k_src) + if (CS%nonBous_energetics) then + SpV0(i,k_tgt) = SpV0_tmp(k_src) + else + R0(i,k_tgt) = R0_tmp(k_src) + endif T(i,k_tgt) = T_tmp(k_src) ; S(i,k_tgt) = S_tmp(k_src) Rcv(i,k_tgt) = Rcv_tmp(k_src) @@ -2177,8 +2444,8 @@ end subroutine resort_ML !> This subroutine moves any water left in the former mixed layers into the !! two buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & - dR0_dT, dR0_dS, dRcv_dT, dRcv_dS, max_BL_det) +subroutine mixedlayer_detrain_2(h, T, S, R0, Spv0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, G, GV, US, CS, & + dR0_dT, dR0_dS, dSpV0_dT, dSpV0_dS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2]. @@ -2187,6 +2454,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -2208,6 +2477,12 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, !! potential density referenced to the !! surface with salinity !! [R S-1 ~> kg m-3 ppt-1]. + real, dimension(SZI_(G)), intent(in) :: dSpV0_dT !< The partial derivative of specific + !! volume with respect to temeprature + !! [R-1 C-1 ~> m3 kg-1 degC-1] + real, dimension(SZI_(G)), intent(in) :: dSpV0_dS !< The partial derivative of specific + !! volume with respect to salinity + !! [R-1 S-1 ~> m3 kg-1 ppt-1] real, dimension(SZI_(G)), intent(in) :: dRcv_dT !< The partial derivative of !! coordinate defining potential density !! with potential temperature, @@ -2228,6 +2503,8 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! layers [H ~> m or kg m-2]. real :: R0_to_bl ! The depth integrated amount of R0 that is detrained to the ! buffer layer [H R ~> kg m-2 or kg2 m-5] + real :: SpV0_to_bl ! The depth integrated amount of SpV0 that is detrained to the + ! buffer layer [H R-1 ~> m4 kg-1 or m] real :: Rcv_to_bl ! The depth integrated amount of Rcv that is detrained to the ! buffer layer [H R ~> kg m-2 or kg2 m-5] real :: T_to_bl ! The depth integrated amount of T that is detrained to the @@ -2246,27 +2523,36 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: stays_min, stays_max ! The minimum and maximum permitted values of ! stays [H ~> m or kg m-2]. + logical :: intermediate ! True if the water in layer kb1 is intermediate in density + ! between the water in kb2 and the water being detrained. logical :: mergeable_bl ! If true, it is an option to combine the two ! buffer layers and create water that matches ! the target density of an interior layer. + logical :: better_to_merge ! True if it is energetically favorable to merge layers real :: stays_merge ! If the two buffer layers can be combined ! stays_merge is the thickness of the upper ! layer that remains [H ~> m or kg m-2]. real :: stays_min_merge ! The minimum allowed value of stays_merge [H ~> m or kg m-2]. real :: dR0_2dz, dRcv_2dz ! Half the vertical gradients of R0 and Rcv [R H-1 ~> kg m-4 or m-1] + real :: dSpV0_2dz ! Half the vertical gradients of SpV0 and Rcv [R-1 H-1 ~> m2 kg-1 or m5 kg-2] ! real :: dT_2dz ! Half the vertical gradient of T [C H-1 ~> degC m-1 or degC m2 kg-1] ! real :: dS_2dz ! Half the vertical gradient of S [S H-1 ~> ppt m-1 or ppt m2 kg-1] real :: scale_slope ! A nondimensional number < 1 used to scale down ! the slope within the upper buffer layer when ! water MUST be detrained to the lower layer [nondim]. - real :: dPE_extrap ! The potential energy change due to dispersive + real :: dPE_extrap_rhoG ! The potential energy change due to dispersive ! advection or mixing layers, divided by ! rho_0*g [H2 ~> m2 or kg2 m-4]. + real :: dPE_extrapolate ! The potential energy change due to dispersive advection or + ! mixing layers [R Z L2 T-2 ~> J m-2]. real :: dPE_det, dPE_merge ! The energy required to mix the detrained water ! into the buffer layer or the merge the two ! buffer layers [R H2 L2 Z-1 T-2 ~> J m-2 or J kg2 m-8]. + real :: dPE_det_nB, dPE_merge_nB ! The energy required to mix the detrained water + ! into the buffer layer or the merge the two + ! buffer layers [R Z L2 T-2 ~> J m-2]. real :: h_from_ml ! The amount of additional water that must be ! drawn from the mixed layer [H ~> m or kg m-2]. @@ -2284,8 +2570,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: h2_to_k1, h2_to_k1_rem ! Fluxes of lower buffer layer water to the interior layer that ! is just denser than the lower buffer layer [H ~> m or kg m-2]. - real :: R0_det, T_det, S_det ! Detrained values of R0 [R ~> kg m-3], T [C ~> degC] and S [S ~> ppt] + real :: R0_det ! Detrained value of potential density referenced to the surface [R ~> kg m-3] + real :: SpV0_det ! Detrained value of specific volume referenced to the surface [R-1 ~> m3 kg-1] + real :: T_det, S_det ! Detrained values of temperature [C ~> degC] and salinity [S ~> ppt] real :: Rcv_stays, R0_stays ! Values of Rcv and R0 that stay in a layer [R ~> kg m-3] + real :: SpV0_stays ! Values of SpV0 that stay in a layer [R-1 ~> m3 kg-1] real :: T_stays, S_stays ! Values of T and S that stay in a layer, [C ~> degC] and S [S ~> ppt] real :: dSpice_det, dSpice_stays! The spiciness difference between an original ! buffer layer and the water that moves into @@ -2296,7 +2585,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! moves into an interior layer [R ~> kg m-3]. real :: dSpice_2dz ! The vertical gradient of spiciness used for ! advection [R H-1 ~> kg m-4 or m-1]. - + real :: dSpiceSpV_stays ! The specific volume based spiciness difference between an original + ! buffer layer and the water that stays in that layer [R-1 ~> m3 kg-1] + real :: dSpiceSpV_lim ! A limit on the specific volume based spiciness difference + ! between the lower buffer layer and the water that + ! moves into an interior layer [R-1 ~> m3 kg-1] real :: dPE_ratio ! Multiplier of dPE_det at which merging is ! permitted - here (detrainment_per_day/dt)*30 ! days? [nondim] @@ -2306,11 +2599,12 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: dT_dS_gauge, dS_dT_gauge ! The relative scales of temperature and ! salinity changes in defining spiciness, in ! [C S-1 ~> degC ppt-1] and [S C-1 ~> ppt degC-1]. - real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2]. + real :: I_denom ! A work variable with units of [S2 R-2 ~> ppt2 m6 kg-2] or [R2 S2 ~> ppt2 kg2 m-6]. real :: g_2 ! 1/2 g_Earth [L2 Z-1 T-2 ~> m s-2]. real :: Rho0xG ! Rho0 times G_Earth [R L2 Z-1 T-2 ~> kg m-2 s-2]. real :: I2Rho0 ! 1 / (2 Rho0) [R-1 ~> m3 kg-1]. + real :: Idt_diag ! The inverse of the timestep used for diagnostics [T-1 ~> s-1]. real :: Idt_H2 ! The square of the conversion from thickness to Z ! divided by the time step [Z2 H-2 T-1 ~> s-1 or m6 kg-2 s-1]. logical :: stable_Rcv ! If true, the buffer layers are stable with @@ -2326,22 +2620,25 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, real :: Ihk0, Ihk1, Ih12 ! Assorted inverse thickness work variables [H-1 ~> m-1 or m2 kg-1] real :: dR1, dR2, dR2b, dRk1 ! Assorted density difference work variables [R ~> kg m-3] real :: dR0, dR21, dRcv ! Assorted density difference work variables [R ~> kg m-3] + real :: dSpV0, dSpVk1 ! Assorted specific volume difference work variables [R-1 ~> m3 kg-1] real :: dRcv_stays, dRcv_det, dRcv_lim ! Assorted densities [R ~> kg m-3] real :: Angstrom ! The minimum layer thickness [H ~> m or kg m-2]. real :: h2_to_k1_lim ! A limit on the thickness that can be detrained to layer k1 [H ~> m or kg m-2] real :: T_new, T_max, T_min ! Temperature of the detrained water and limits on it [C ~> degC] real :: S_new, S_max, S_min ! Salinity of the detrained water and limits on it [S ~> ppt] - + logical :: stable integer :: i, k, k0, k1, is, ie, nz, kb1, kb2, nkmb + is = G%isc ; ie = G%iec ; nz = GV%ke kb1 = CS%nkml+1; kb2 = CS%nkml+2 nkmb = CS%nkml+CS%nkbl h_neglect = GV%H_subroundoff g_2 = 0.5 * GV%g_Earth Rho0xG = GV%Rho0 * GV%g_Earth + Idt_diag = 1.0 / dt_diag Idt_H2 = GV%H_to_Z**2 / dt_diag - I2Rho0 = 0.5 / (GV%Rho0) + I2Rho0 = 0.5 / GV%Rho0 Angstrom = GV%Angstrom_H ! This is hard coding of arbitrary and dimensional numbers. @@ -2361,12 +2658,16 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! As coded this has the k and i loop orders switched, but k is CS%nkml is ! often just 1 or 2, so this seems like it should not be a problem, especially ! since it means that a number of variables can now be scalars, not arrays. - h_to_bl = 0.0 ; R0_to_bl = 0.0 + h_to_bl = 0.0 ; R0_to_bl = 0.0 ; SpV0_to_bl = 0.0 Rcv_to_bl = 0.0 ; T_to_bl = 0.0 ; S_to_bl = 0.0 do k=1,CS%nkml ; if (h(i,k) > 0.0) then h_to_bl = h_to_bl + h(i,k) - R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + if (CS%nonBous_energetics) then + SpV0_to_bl = SpV0_to_bl + SpV0(i,k)*h(i,k) + else + R0_to_bl = R0_to_bl + R0(i,k)*h(i,k) + endif Rcv_to_bl = Rcv_to_bl + Rcv(i,k)*h(i,k) T_to_bl = T_to_bl + T(i,k)*h(i,k) @@ -2375,8 +2676,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, d_ea(i,k) = d_ea(i,k) - h(i,k) h(i,k) = 0.0 endif ; enddo - if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl - else ; R0_det = R0(i,0) ; endif + + if (CS%nonBous_energetics) then + if (h_to_bl > 0.0) then ; SpV0_det = SpV0_to_bl / h_to_bl + else ; SpV0_det = SpV0(i,0) ; endif + else + if (h_to_bl > 0.0) then ; R0_det = R0_to_bl / h_to_bl + else ; R0_det = R0(i,0) ; endif + endif ! This code does both downward detrainment from both the mixed layer and the ! buffer layers. @@ -2401,8 +2708,11 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h_min_bl = MIN(CS%Hbuffer_min, CS%Hbuffer_rel_min*h(i,0)) stable_Rcv = .true. - if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) & - stable_Rcv = .false. + if (CS%nonBous_energetics) then + if (((SpV0(i,kb1)-SpV0(i,kb2)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + else + if (((R0(i,kb2)-R0(i,kb1)) * (Rcv(i,kb2)-Rcv(i,kb1)) <= 0.0)) stable_Rcv = .false. + endif h1 = h(i,kb1) ; h2 = h(i,kb2) @@ -2417,26 +2727,36 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! are not meaningful, but may later be used to determine the properties of ! waters moving into the lower buffer layer. So the properties of the ! lower buffer layer are set to be between those of the upper buffer layer - ! and the next denser interior layer, measured by R0. This probably does + ! and the next denser interior layer, measured by R0 or SpV0. This probably does ! not happen very often, so I am not too worried about the inefficiency of ! the following loop. do k1=kb2+1,nz ; if (h(i,k1) > 2.0*Angstrom) exit ; enddo - R0(i,kb2) = R0(i,kb1) - Rcv(i,kb2) = Rcv(i,kb1) ; T(i,kb2) = T(i,kb1) ; S(i,kb2) = S(i,kb1) + if (CS%nonBous_energetics) then + SpV0(i,kb2) = SpV0(i,kb1) + if (k1 <= nz) then ; if (SpV0(i,k1) <= SpV0(i,kb1)) then + SpV0(i,kb2) = 0.5*(SpV0(i,kb1)+SpV0(i,k1)) + + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + else + R0(i,kb2) = R0(i,kb1) - if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then - R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) + if (k1 <= nz) then ; if (R0(i,k1) >= R0(i,kb1)) then + R0(i,kb2) = 0.5*(R0(i,kb1)+R0(i,k1)) - Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) - T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) - S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) - endif ; endif + Rcv(i,kb2) = 0.5*(Rcv(i,kb1)+Rcv(i,k1)) + T(i,kb2) = 0.5*(T(i,kb1)+T(i,k1)) + S(i,kb2) = 0.5*(S(i,kb1)+S(i,k1)) + endif ; endif + endif endif ! (h2 = 0 && h1 > 0) - dPE_extrap = 0.0 ; dPE_merge = 0.0 + dPE_extrap_rhoG = 0.0 ; dPE_extrapolate = 0.0 ; dPE_merge = 0.0 ; dPE_merge_nB = 0.0 mergeable_bl = .false. if ((h1 > 0.0) .and. (h2 > 0.0) .and. (h_to_bl > 0.0) .and. & (stable_Rcv)) then @@ -2453,12 +2773,23 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! into the lower one, each with an energy change that equals that required ! to mix the detrained water with the upper buffer layer. h1_avail = h1 - MAX(0.0,h_min_bl-h_to_bl) - if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. & - (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl)) then - dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & - (Rcv(i,kb2) - Rcv(i,kb1)) - b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) + if (CS%nonBous_energetics) then + intermediate = (SpV0(i,kb1) > SpV0(i,kb2)) .and. (h_to_bl*SpV0(i,kb1) < SpV0_to_bl) + else + intermediate = (R0(i,kb1) < R0(i,kb2)) .and. (h_to_bl*R0(i,kb1) > R0_to_bl) + endif + + if ((k1<=nz) .and. (h2 > h_min_bl) .and. (h1_avail > 0.0) .and. intermediate) then + if (CS%nonBous_energetics) then + dSpVk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (SpV0(i,kb2) - SpV0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = (RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + else + dRk1 = (RcvTgt(k1) - Rcv(i,kb2)) * (R0(i,kb2) - R0(i,kb1)) / & + (Rcv(i,kb2) - Rcv(i,kb1)) + b1 = dRk1 / (R0(i,kb2) - R0(i,kb1)) ! b1 = RcvTgt(k1) - Rcv(i,kb2)) / (Rcv(i,kb2) - Rcv(i,kb1)) + endif ! Apply several limits to the detrainment. ! Entrain less than the mass in h2, and keep the base of the buffer @@ -2468,8 +2799,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! buffer layers with upwind advection from the layer above. if (h2_to_k1*(h1_avail + b1*(h1_avail + h2)) > h2*h1_avail) & h2_to_k1 = (h2*h1_avail) / (h1_avail + b1*(h1_avail + h2)) - if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & - h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + + if (CS%nonBous_energetics) then + if (h2_to_k1*(dSpVk1 * h2) < (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*SpV0(i,kb1) - SpV0_to_bl) * h1 / (dSpVk1 * h2) + else + if (h2_to_k1*(dRk1 * h2) > (h_to_bl*R0(i,kb1) - R0_to_bl) * h1) & + h2_to_k1 = (h_to_bl*R0(i,kb1) - R0_to_bl) * h1 / (dRk1 * h2) + endif if ((k1==kb2+1) .and. (CS%BL_extrap_lim > 0.)) then ! Simply do not detrain very light water into the lightest isopycnal @@ -2511,9 +2848,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) S_det = S(i,kb2) + I_denom * & (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The detrained values of R0 are based on changes in T and S. - R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & - (S_det-S(i,kb2)) * dR0_dS(i) + + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif if (CS%BL_extrap_lim >= 0.) then ! Only do this detrainment if the new layer's temperature and salinity @@ -2555,10 +2898,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2*S(i,kb1)) * Ih2f S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 - ! Changes in R0 are based on changes in T and S. - R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + & - h1_to_h2*R0(i,kb1)) * Ih2f - R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h(i,kb2)*SpV0(i,kb2) - h2_to_k1*SpV0_det) + h1_to_h2*SpV0(i,kb1)) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = ((h(i,kb2)*R0(i,kb2) - h2_to_k1*R0_det) + h1_to_h2*R0(i,kb1)) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif h(i,kb1) = h(i,kb1) - h1_to_h2 ; h1 = h(i,kb1) h(i,kb2) = (h(i,kb2) - h2_to_k1) + h1_to_h2 ; h2 = h(i,kb2) @@ -2579,8 +2926,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, k0 = k1-1 dR1 = RcvTgt(k0)-Rcv(i,kb1) ; dR2 = Rcv(i,kb2)-RcvTgt(k0) - if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. & - (h2*dR2 < h1*dR1) .and. (R0(i,kb2) > R0(i,kb1))) then + if (CS%nonBous_energetics) then + stable = (SpV0(i,kb2) < SpV0(i,kb1)) + else + stable = (R0(i,kb2) > R0(i,kb1)) + endif + + if ((k0>kb2) .and. (dR1 > 0.0) .and. (h1 > h_min_bl) .and. (h2*dR2 < h1*dR1) .and. stable) then ! An interior isopycnal layer (k0) is intermediate in density between ! the two buffer layers, and there can be detrainment. The entire ! lower buffer layer is combined with a portion of the upper buffer @@ -2589,12 +2941,20 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ((dR1+dR2)*h1 + dR1*(h1+h2) + & sqrt((dR2*h1-dR1*h2)**2 + 4*(h1+h2)*h2*(dR1+dR2)*dR2)) - stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & - h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) - if ((stays_merge > stays_min_merge) .and. & - (stays_merge + h2_to_k1_rem >= h1 + h2)) then - mergeable_bl = .true. - dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1))*(h1-stays_merge)*(h2-stays_merge) + if (CS%nonBous_energetics) then + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(SpV0(i,kb1) - SpV0_det) / (SpV0(i,kb2) - SpV0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge_nB = g_2*GV%H_to_RZ**2*(SpV0(i,kb1)-SpV0(i,kb2)) * ((h1-stays_merge)*(h2-stays_merge)) + endif + else + stays_min_merge = MAX(h_min_bl, 2.0*h_min_bl - h_to_bl, & + h1 - (h1+h2)*(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1))) + if ((stays_merge > stays_min_merge) .and. (stays_merge + h2_to_k1_rem >= h1 + h2)) then + mergeable_bl = .true. + dPE_merge = g_2*(R0(i,kb2)-R0(i,kb1)) * (h1-stays_merge)*(h2-stays_merge) + endif endif endif @@ -2635,9 +2995,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv + dRcv_dS(i) * dSpice_det) S_det = S(i,kb2) + I_denom * & (dRcv_dS(i) * dRcv - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The detrained values of R0 are based on changes in T and S. - R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & - (S_det-S(i,kb2)) * dR0_dS(i) + ! The detrained values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb2) + (T_det-T(i,kb2)) * dSpV0_dT(i) + & + (S_det-S(i,kb2)) * dSpV0_dS(i) + else + R0_det = R0(i,kb2) + (T_det-T(i,kb2)) * dR0_dT(i) + & + (S_det-S(i,kb2)) * dR0_dS(i) + endif ! Now that the properties of the detrained water are known, ! potentially limit the amount of water that is detrained to @@ -2703,9 +3068,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, S(i,kb2) = (h2*S(i,kb2) - h2_to_k1*S_det) * Ih2f S(i,k1) = ((h(i,k1)+h_neglect)*S(i,k1) + h2_to_k1*S_det) * Ihk1 - ! Changes in R0 are based on changes in T and S. - R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f - R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + ! Changes in R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0(i,kb2) = (h2*SpV0(i,kb2) - h2_to_k1*SpV0_det) * Ih2f + SpV0(i,k1) = ((h(i,k1)+h_neglect)*SpV0(i,k1) + h2_to_k1*SpV0_det) * Ihk1 + else + R0(i,kb2) = (h2*R0(i,kb2) - h2_to_k1*R0_det) * Ih2f + R0(i,k1) = ((h(i,k1)+h_neglect)*R0(i,k1) + h2_to_k1*R0_det) * Ihk1 + endif else ! h2==h2_to_k1 can happen if dR2b = 0 exactly, but this is very ! unlikely. In this case the entirety of layer kb2 is detrained. @@ -2715,13 +3085,22 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, Rcv(i,k1) = (h(i,k1)*Rcv(i,k1) + h2*Rcv(i,kb2)) * Ihk1 T(i,k1) = (h(i,k1)*T(i,k1) + h2*T(i,kb2)) * Ihk1 S(i,k1) = (h(i,k1)*S(i,k1) + h2*S(i,kb2)) * Ihk1 - R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + if (CS%nonBous_energetics) then + SpV0(i,k1) = (h(i,k1)*SpV0(i,k1) + h2*SpV0(i,kb2)) * Ihk1 + else + R0(i,k1) = (h(i,k1)*R0(i,k1) + h2*R0(i,kb2)) * Ihk1 + endif endif h(i,k1) = h(i,k1) + h2_to_k1 h(i,kb2) = h(i,kb2) - h2_to_k1 ; h2 = h(i,kb2) - ! dPE_extrap should be positive here. - dPE_extrap = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + ! dPE_extrap_rhoG should be positive here. + if (CS%nonBous_energetics) then + dPE_extrap_rhoG = 0.5*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) / SpV0(i,k1) + dPE_extrapolate = 0.5*GV%g_Earth*GV%H_to_RZ**2*(SpV0(i,kb2)-SpV0_det) * (h2_to_k1*h2) + else + dPE_extrap_rhoG = I2Rho0*(R0_det-R0(i,kb2))*h2_to_k1*h2 + endif d_ea(i,kb2) = d_ea(i,kb2) - h2_to_k1 d_ea(i,k1) = d_ea(i,k1) + h2_to_k1 @@ -2748,9 +3127,15 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, Ihdet = 0.0 ; if (h_to_bl > 0.0) Ihdet = 1.0 / h_to_bl Ih1f = 1.0 / (h_det_to_h1 + h_ml_to_h1) - R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & - (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih - R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + if (CS%nonBous_energetics) then + SpV0(i,kb2) = ((h2*SpV0(i,kb2) + h1*SpV0(i,kb1)) + & + (h_det_to_h2*SpV0_to_bl*Ihdet + h_ml_to_h2*SpV0(i,0))) * Ih + SpV0(i,kb1) = (h_det_to_h1*SpV0_to_bl*Ihdet + h_ml_to_h1*SpV0(i,0)) * Ih1f + else + R0(i,kb2) = ((h2*R0(i,kb2) + h1*R0(i,kb1)) + & + (h_det_to_h2*R0_to_bl*Ihdet + h_ml_to_h2*R0(i,0))) * Ih + R0(i,kb1) = (h_det_to_h1*R0_to_bl*Ihdet + h_ml_to_h1*R0(i,0)) * Ih1f + endif Rcv(i,kb2) = ((h2*Rcv(i,kb2) + h1*Rcv(i,kb1)) + & (h_det_to_h2*Rcv_to_bl*Ihdet + h_ml_to_h2*Rcv(i,0))) * Ih @@ -2774,18 +3159,30 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (allocated(CS%diag_PE_detrain) .or. allocated(CS%diag_PE_detrain2)) then - R0_det = R0_to_bl*Ihdet - s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & - h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & - h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & - (R0_det-R0(i,0))*h_det_to_h2 ) + & - h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap ) + if (CS%nonBous_energetics) then + SpV0_det = SpV0_to_bl*Ihdet + s1en = Idt_diag * ( -GV%H_to_RZ**2 * g_2 * ((SpV0(i,kb2)-SpV0(i,kb1))*h1*h2 + & + h_det_to_h2*( (SpV0(i,kb1)-SpV0_det)*h1 + (SpV0(i,kb2)-SpV0_det)*h2 ) + & + h_ml_to_h2*( (SpV0(i,kb2)-SpV0(i,0))*h2 + (SpV0(i,kb1)-SpV0(i,0))*h1 + & + (SpV0_det-SpV0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(SpV0_det-SpV0(i,0))) - dPE_extrapolate ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_diag*dPE_extrapolate + else + R0_det = R0_to_bl*Ihdet + s1en = g_2 * Idt_H2 * ( ((R0(i,kb2)-R0(i,kb1))*h1*h2 + & + h_det_to_h2*( (R0(i,kb1)-R0_det)*h1 + (R0(i,kb2)-R0_det)*h2 ) + & + h_ml_to_h2*( (R0(i,kb2)-R0(i,0))*h2 + (R0(i,kb1)-R0(i,0))*h1 + & + (R0_det-R0(i,0))*h_det_to_h2 ) + & + h_det_to_h1*h_ml_to_h1*(R0_det-R0(i,0))) - 2.0*GV%Rho0*dPE_extrap_rhoG ) + + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap_rhoG + endif if (allocated(CS%diag_PE_detrain)) & CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + s1en - - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + s1en + Idt_H2*Rho0xG*dPE_extrap endif elseif ((h_to_bl > 0.0) .or. (h1 < h_min_bl) .or. (h2 < h_min_bl)) then @@ -2797,8 +3194,18 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (h_from_ml > 0.0) then ! Some water needs to be moved from the mixed layer so that the upper ! (and perhaps lower) buffer layers exceed their minimum thicknesses. - dPE_extrap = dPE_extrap - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) - R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + if (CS%nonBous_energetics) then + ! The choice of which specific volume to use in the denominator could be revisited. + ! dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) / SpV0(i,0) + dPE_extrap_rhoG = dPE_extrap_rhoG + 0.5*h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) * & + ( (h_to_bl + h_from_ml) / (SpV0_to_bl + h_from_ml*SpV0(i,0)) ) + dPE_extrapolate = dPE_extrapolate + 0.5*GV%g_Earth*GV%H_to_RZ**2 * & + h_from_ml*(SpV0_to_bl - SpV0(i,0)*h_to_bl) + SpV0_to_bl = SpV0_to_bl + h_from_ml*SpV0(i,0) + else + dPE_extrap_rhoG = dPE_extrap_rhoG - I2Rho0*h_from_ml*(R0_to_bl - R0(i,0)*h_to_bl) + R0_to_bl = R0_to_bl + h_from_ml*R0(i,0) + endif Rcv_to_bl = Rcv_to_bl + h_from_ml*Rcv(i,0) T_to_bl = T_to_bl + h_from_ml*T(i,0) S_to_bl = S_to_bl + h_from_ml*S(i,0) @@ -2810,8 +3217,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, ! The absolute value should be unnecessary and 1e9 is just a large number. b1 = 1.0e9 - if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & - b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + if (CS%nonBous_energetics) then + if (SpV0(i,kb1) - SpV0(i,kb2) > 1.0e-9*abs(SpV0_det - SpV0(i,kb1))) & + b1 = abs(SpV0_det - SpV0(i,kb1)) / (SpV0(i,kb1) - SpV0(i,kb2)) + else + if (R0(i,kb2) - R0(i,kb1) > 1.0e-9*abs(R0(i,kb1) - R0_det)) & + b1 = abs(R0(i,kb1) - R0_det) / (R0(i,kb2) - R0(i,kb1)) + endif stays_min = MAX((1.0-b1)*h1 - b1*h2, 0.0, h_min_bl - h_to_bl) stays_max = h1 - MAX(h_min_bl-h2,0.0) @@ -2831,9 +3243,9 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, if (s2 < 0.0) then ! The energy released by detrainment from the lower buffer layer can be ! used to mix water from the upper buffer layer into the lower one. - s3sq = I_ya*MAX(bh0*h1-dPE_extrap, 0.0) + s3sq = I_ya*MAX(bh0*h1-dPE_extrap_rhoG, 0.0) else - s3sq = I_ya*(bh0*h1-MIN(dPE_extrap,0.0)) + s3sq = I_ya*(bh0*h1-MIN(dPE_extrap_rhoG,0.0)) endif if (s3sq == 0.0) then @@ -2871,10 +3283,17 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, endif endif - dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & - (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & - (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & - Rho0xG*dPE_extrap + if (CS%nonBous_energetics) then + dPE_det_nB = -g_2*GV%H_to_RZ**2*((SpV0(i,kb1)*h_to_bl - SpV0_to_bl)*stays + & + (SpV0(i,kb2)-SpV0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + dPE_extrapolate + else + dPE_det = g_2*((R0(i,kb1)*h_to_bl - R0_to_bl)*stays + & + (R0(i,kb2)-R0(i,kb1)) * (h1-stays) * & + (h2 - scale_slope*stays*((h1+h2)+h_to_bl)/(h1+h2)) ) - & + Rho0xG*dPE_extrap_rhoG + endif if (dPE_time_ratio*h_to_bl > h_to_bl+h(i,0)) then dPE_ratio = (h_to_bl+h(i,0)) / h_to_bl @@ -2882,7 +3301,13 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, dPE_ratio = dPE_time_ratio endif - if ((mergeable_bl) .and. (num_events*dPE_ratio*dPE_det > dPE_merge)) then + if (CS%nonBous_energetics) then + better_to_merge = (num_events*dPE_ratio*dPE_det_nB > dPE_merge_nB) + else + better_to_merge = (num_events*dPE_ratio*dPE_det > dPE_merge) + endif + + if (mergeable_bl .and. better_to_merge) then ! It is energetically preferable to merge the two buffer layers, detrain ! them into interior layer (k0), move the remaining upper buffer layer ! water into the lower buffer layer, and detrain undiluted into the @@ -2909,8 +3334,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, I_denom = 1.0 / (dRcv_dS(i)**2 + (dT_dS_gauge*dRcv_dT(i))**2) dSpice_2dz = (dS_dT_gauge*dRcv_dS(i)*(T(i,kb1)-T(i,kb2)) - & dT_dS_gauge*dRcv_dT(i)*(S(i,kb1)-S(i,kb2))) * Ih12 - dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & - dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + if (CS%nonBous_energetics) then + ! Use the specific volume differences to limit the coordinate density change. + dSpice_lim = -Rcv(i,kb1) * (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / (SpV0(i,kb1) * h_to_bl) + else + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + endif if (dSpice_lim * dSpice_2dz <= 0.0) dSpice_2dz = 0.0 if (stays > 0.0) then @@ -2923,15 +3354,20 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv_stays + dRcv_dS(i) * dSpice_stays) S_stays = S(i,kb1) + I_denom * & (dRcv_dS(i) * dRcv_stays - dT_dS_gauge * dRcv_dT(i) * dSpice_stays) - ! The values of R0 are based on changes in T and S. - R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & - (S_stays-S(i,kb1)) * dR0_dS(i) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_stays = SpV0(i,kb1) + (T_stays-T(i,kb1)) * dSpV0_dT(i) + & + (S_stays-S(i,kb1)) * dSpV0_dS(i) + else + R0_stays = R0(i,kb1) + (T_stays-T(i,kb1)) * dR0_dT(i) + & + (S_stays-S(i,kb1)) * dR0_dS(i) + endif else ! Limit the spiciness of the water that moves into the lower buffer layer. if (abs(dSpice_lim) < abs(dSpice_2dz*h1_to_k0)) & dSpice_2dz = dSpice_lim/h1_to_k0 ! These will be multiplied by 0 later. - T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 + T_stays = 0.0 ; S_stays = 0.0 ; R0_stays = 0.0 ; SpV0_stays = 0.0 endif dSpice_det = - dSpice_2dz*(stays + h1_to_h2) @@ -2939,9 +3375,14 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, (dT_dS_gauge * dRcv_dT(i) * dRcv_det + dRcv_dS(i) * dSpice_det) S_det = S(i,kb1) + I_denom * & (dRcv_dS(i) * dRcv_det - dT_dS_gauge * dRcv_dT(i) * dSpice_det) - ! The values of R0 are based on changes in T and S. - R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & - (S_det-S(i,kb1)) * dR0_dS(i) + ! The values of R0 or SpV0 are based on changes in T and S. + if (CS%nonBous_energetics) then + SpV0_det = SpV0(i,kb1) + (T_det-T(i,kb1)) * dSpV0_dT(i) + & + (S_det-S(i,kb1)) * dSpV0_dS(i) + else + R0_det = R0(i,kb1) + (T_det-T(i,kb1)) * dR0_dT(i) + & + (S_det-S(i,kb1)) * dR0_dS(i) + endif T(i,k0) = ((h1_to_k0*T_det + h2*T(i,kb2)) + h(i,k0)*T(i,k0)) * Ihk0 T(i,kb2) = (h1*T(i,kb1) - stays*T_stays - h1_to_k0*T_det) * Ih2f @@ -2951,29 +3392,40 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, S(i,kb2) = (h1*S(i,kb1) - stays*S_stays - h1_to_k0*S_det) * Ih2f S(i,kb1) = (S_to_bl + stays*S_stays) * Ih1f - R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 - R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f - R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + if (CS%nonBous_energetics) then + SpV0(i,k0) = ((h1_to_k0*SpV0_det + h2*SpV0(i,kb2)) + h(i,k0)*SpV0(i,k0)) * Ihk0 + SpV0(i,kb2) = (h1*SpV0(i,kb1) - stays*SpV0_stays - h1_to_k0*SpV0_det) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*SpV0_stays) * Ih1f + else + R0(i,k0) = ((h1_to_k0*R0_det + h2*R0(i,kb2)) + h(i,k0)*R0(i,k0)) * Ihk0 + R0(i,kb2) = (h1*R0(i,kb1) - stays*R0_stays - h1_to_k0*R0_det) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*R0_stays) * Ih1f + endif ! ! The following is 2nd-order upwind advection without limiters. ! dT_2dz = (T(i,kb1) - T(i,kb2)) * Ih12 ! T(i,k0) = (h1_to_k0*(T(i,kb1) - dT_2dz*(stays+h1_to_h2)) + & ! h2*T(i,kb2) + h(i,k0)*T(i,k0)) * Ihk0 ! T(i,kb2) = T(i,kb1) + dT_2dz*(h1_to_k0-stays) -! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + & -! dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! T(i,kb1) = (T_to_bl + stays*(T(i,kb1) + dT_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f ! dS_2dz = (S(i,kb1) - S(i,kb2)) * Ih12 ! S(i,k0) = (h1_to_k0*(S(i,kb1) - dS_2dz*(stays+h1_to_h2)) + & ! h2*S(i,kb2) + h(i,k0)*S(i,k0)) * Ihk0 ! S(i,kb2) = S(i,kb1) + dS_2dz*(h1_to_k0-stays) -! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + & -! dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f -! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 -! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & -! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 -! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) -! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + & -! dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! S(i,kb1) = (S_to_bl + stays*(S(i,kb1) + dS_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! if (CS%nonBous_energetics) then +! dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih12 +! SpV0(i,k0) = (h1_to_k0*(SpV0(i,kb1) - dSpV0_2dz*(stays+h1_to_h2)) + & +! h2*SpV0(i,kb2) + h(i,k0)*SpV0(i,k0)) * Ihk0 +! SpV0(i,kb2) = SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0-stays) +! SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + dSpV0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! else +! dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih12 +! R0(i,k0) = (h1_to_k0*(R0(i,kb1) - dR0_2dz*(stays+h1_to_h2)) + & +! h2*R0(i,kb2) + h(i,k0)*R0(i,k0)) * Ihk0 +! R0(i,kb2) = R0(i,kb1) + dR0_2dz*(h1_to_k0-stays) +! R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + dR0_2dz*(h1_to_k0 + h1_to_h2))) * Ih1f +! endif d_ea(i,kb1) = (d_ea(i,kb1) + h_to_bl) + (stays - h1) d_ea(i,kb2) = d_ea(i,kb2) + (h1_to_h2 - h2) @@ -2982,10 +3434,17 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h1_to_h2 h(i,k0) = h(i,k0) + (h1_to_k0 + h2) - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_merge_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_merge + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif else ! Not mergeable_bl. ! There is no further detrainment from the buffer layers, and the ! upper buffer layer water is distributed optimally between the @@ -2993,37 +3452,64 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h1_to_h2 = h1 - stays Ih1f = 1.0 / (h_to_bl + stays) ; Ih2f = 1.0 / (h2 + h1_to_h2) Ih = 1.0 / (h1 + h2) - dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih - R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - & - scale_slope*dR0_2dz*stays)) * Ih2f - R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + & - scale_slope*dR0_2dz*h1_to_h2)) * Ih1f - - ! Use 2nd order upwind advection of spiciness, limited by the value - ! in the detrained water to determine the detrained temperature and - ! salinity. - dR0 = scale_slope*dR0_2dz*h1_to_h2 - dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & - dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & - scale_slope*h1_to_h2 * Ih - if (h_to_bl > 0.0) then - dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & - dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) /& - h_to_bl + if (CS%nonBous_energetics) then + dSpV0_2dz = (SpV0(i,kb1) - SpV0(i,kb2)) * Ih + SpV0(i,kb2) = (h2*SpV0(i,kb2) + h1_to_h2*(SpV0(i,kb1) - scale_slope*dSpV0_2dz*stays)) * Ih2f + SpV0(i,kb1) = (SpV0_to_bl + stays*(SpV0(i,kb1) + scale_slope*dSpV0_2dz*h1_to_h2)) * Ih1f else - dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & - dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + dR0_2dz = (R0(i,kb1) - R0(i,kb2)) * Ih + R0(i,kb2) = (h2*R0(i,kb2) + h1_to_h2*(R0(i,kb1) - scale_slope*dR0_2dz*stays)) * Ih2f + R0(i,kb1) = (R0_to_bl + stays*(R0(i,kb1) + scale_slope*dR0_2dz*h1_to_h2)) * Ih1f endif - if (dSpice_stays*dSpice_lim <= 0.0) then - dSpice_stays = 0.0 - elseif (abs(dSpice_stays) > abs(dSpice_lim)) then - dSpice_stays = dSpice_lim + + ! Use 2nd order upwind advection of spiciness, limited by the value in the + ! detrained water to determine the detrained temperature and salinity. + if (CS%nonBous_energetics) then + dSpV0 = scale_slope*dSpV0_2dz*h1_to_h2 + dSpiceSpV_stays = (dS_dT_gauge*dSpV0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpiceSpV_lim = (dS_dT_gauge*dSpV0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dSpV0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpiceSpV_lim = dS_dT_gauge*dSpV0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dSpV0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpiceSpV_stays*dSpiceSpV_lim <= 0.0) then + dSpiceSpV_stays = 0.0 + elseif (abs(dSpiceSpV_stays) > abs(dSpiceSpV_lim)) then + dSpiceSpV_stays = dSpiceSpV_lim + endif + I_denom = 1.0 / (dSpV0_dS(i)**2 + (dT_dS_gauge*dSpV0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dSpV0_dT(i) * dSpV0 + dSpV0_dS(i) * dSpiceSpV_stays) + S_stays = S(i,kb1) + I_denom * & + (dSpV0_dS(i) * dSpV0 - dT_dS_gauge * dSpV0_dT(i) * dSpiceSpV_stays) + else + dR0 = scale_slope*dR0_2dz*h1_to_h2 + dSpice_stays = (dS_dT_gauge*dR0_dS(i)*(T(i,kb1)-T(i,kb2)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,kb1)-S(i,kb2))) * & + scale_slope*h1_to_h2 * Ih + if (h_to_bl > 0.0) then + dSpice_lim = (dS_dT_gauge*dR0_dS(i)*(T_to_bl-T(i,kb1)*h_to_bl) - & + dT_dS_gauge*dR0_dT(i)*(S_to_bl-S(i,kb1)*h_to_bl)) / h_to_bl + else + dSpice_lim = dS_dT_gauge*dR0_dS(i)*(T(i,0)-T(i,kb1)) - & + dT_dS_gauge*dR0_dT(i)*(S(i,0)-S(i,kb1)) + endif + if (dSpice_stays*dSpice_lim <= 0.0) then + dSpice_stays = 0.0 + elseif (abs(dSpice_stays) > abs(dSpice_lim)) then + dSpice_stays = dSpice_lim + endif + I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) + T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & + (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) + S_stays = S(i,kb1) + I_denom * & + (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) endif - I_denom = 1.0 / (dR0_dS(i)**2 + (dT_dS_gauge*dR0_dT(i))**2) - T_stays = T(i,kb1) + dT_dS_gauge * I_denom * & - (dT_dS_gauge * dR0_dT(i) * dR0 + dR0_dS(i) * dSpice_stays) - S_stays = S(i,kb1) + I_denom * & - (dR0_dS(i) * dR0 - dT_dS_gauge * dR0_dT(i) * dSpice_stays) + ! The detrained values of Rcv are based on changes in T and S. Rcv_stays = Rcv(i,kb1) + (T_stays-T(i,kb1)) * dRcv_dT(i) + & (S_stays-S(i,kb1)) * dRcv_dS(i) @@ -3058,10 +3544,19 @@ subroutine mixedlayer_detrain_2(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, j, h(i,kb1) = stays + h_to_bl h(i,kb2) = h(i,kb2) + h1_to_h2 - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det - if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & - CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_diag*dPE_det_nB + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_diag*(dPE_det_nB + dPE_extrapolate) + else + ! Recasting dPE_det into the same units as dPE_det_nB changes these diagnostics slightly + ! in some cases for reasons that are not understood. + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + Idt_H2*dPE_det + if (allocated(CS%diag_PE_detrain2)) CS%diag_PE_detrain2(i,j) = & + CS%diag_PE_detrain2(i,j) + Idt_H2*(dPE_det + Rho0xG*dPE_extrap_rhoG) + endif endif endif ! End of detrainment... @@ -3072,7 +3567,7 @@ end subroutine mixedlayer_detrain_2 !> This subroutine moves any water left in the former mixed layers into the !! single buffer layers and may also move buffer layer water into the interior !! isopycnal layers. -subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & +subroutine mixedlayer_detrain_1(h, T, S, R0, SpV0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_eb, & j, G, GV, US, CS, dRcv_dT, dRcv_dS, max_BL_det) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -3082,6 +3577,8 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: S !< Salinity [S ~> ppt]. real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: R0 !< Potential density referenced to !! surface pressure [R ~> kg m-3]. + real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: SpV0 !< Specific volume referenced to + !! surface pressure [R-1 ~> m3 kg] real, dimension(SZI_(G),SZK0_(GV)), intent(inout) :: Rcv !< The coordinate defining potential !! density [R ~> kg m-3]. real, dimension(SZK_(GV)), intent(in) :: RcvTgt !< The target value of Rcv for each @@ -3126,18 +3623,26 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! extrapolating [S R-1 ~> ppt m3 kg-1] real :: dRml ! The density range within the extent of the mixed layers [R ~> kg m-3] real :: dR0_dRcv ! The relative changes in the potential density and the coordinate density [nondim] + real :: dSpV0_dRcv ! The relative changes in the specific volume and the coordinate density [R-2 ~> m6 kg-2] real :: I_denom ! A work variable [S2 R-2 ~> ppt2 m6 kg-2]. real :: Sdown ! The salinity of the detrained water [S ~> ppt] real :: Tdown ! The temperature of the detrained water [C ~> degC] real :: dt_Time ! The timestep divided by the detrainment timescale [nondim]. - real :: g_H2_2Rho0dt ! Half the gravitational acceleration times the square of the + real :: g_H_2Rho0dt ! Half the gravitational acceleration times the ! conversion from H to m divided by the mean density times the time - ! step [L2 Z T-3 H-2 R-1 ~> m4 s-3 kg-1 or m10 s-3 kg-3]. + ! step [L2 T-3 H-1 R-1 ~> m4 s-3 kg-1 or m7 s-3 kg-2]. real :: g_H2_2dt ! Half the gravitational acceleration times the square of the ! conversion from H to Z divided by the diagnostic time step ! [L2 Z H-2 T-3 ~> m s-3 or m7 kg-2 s-3]. + real :: nB_g_H_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ divided by the diagnostic time step + ! [L2 R H-1 T-3 ~> kg m s-3 or m4 s-3]. + real :: nB_gRZ_H2_2dt ! Half the gravitational acceleration times the conversion from + ! H to RZ squared divided by the diagnostic time step + ! [L2 R2 Z H-2 T-3 ~> kg2 m-2 s-3 or m4 s-3]. real :: x1 ! A temporary work variable [various] logical :: splittable_BL(SZI_(G)), orthogonal_extrap + logical :: must_unmix integer :: i, is, ie, k, k1, nkmb, nz is = G%isc ; ie = G%iec ; nz = GV%ke @@ -3146,24 +3651,45 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e "CS%nkbl must be 1 in mixedlayer_detrain_1.") dt_Time = dt / CS%BL_detrain_time - g_H2_2Rho0dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * GV%Rho0 * dt_diag) - g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) + + if (CS%nonBous_energetics) then + nB_g_H_2dt = (GV%g_Earth * GV%H_to_RZ) / (2.0 * dt_diag) + nB_gRZ_H2_2dt = GV%H_to_RZ * nB_g_H_2dt + else + g_H2_2dt = (GV%g_Earth * GV%H_to_Z**2) / (2.0 * dt_diag) + g_H_2Rho0dt = g_H2_2dt * GV%RZ_to_H + endif ! Move detrained water into the buffer layer. do k=1,CS%nkml do i=is,ie ; if (h(i,k) > 0.0) then Ih = 1.0 / (h(i,nkmb) + h(i,k)) - if (CS%TKE_diagnostics) & - CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & - g_H2_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (allocated(CS%diag_PE_detrain)) & - CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & - g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - if (allocated(CS%diag_PE_detrain2)) & - CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & - g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) - - R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + + if (CS%nonBous_energetics) then + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) - & + nB_g_H_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) - & + nB_gRZ_H2_2dt * (h(i,k) * h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,k)) + + SpV0(i,nkmb) = (SpV0(i,nkmb)*h(i,nkmb) + SpV0(i,k)*h(i,k)) * Ih + else + if (CS%TKE_diagnostics) & + CS%diag_TKE_conv_s2(i,j) = CS%diag_TKE_conv_s2(i,j) + & + g_H_2Rho0dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain)) & + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + if (allocated(CS%diag_PE_detrain2)) & + CS%diag_PE_detrain2(i,j) = CS%diag_PE_detrain2(i,j) + & + g_H2_2dt * h(i,k) * h(i,nkmb) * (R0(i,nkmb) - R0(i,k)) + + R0(i,nkmb) = (R0(i,nkmb)*h(i,nkmb) + R0(i,k)*h(i,k)) * Ih + endif Rcv(i,nkmb) = (Rcv(i,nkmb)*h(i,nkmb) + Rcv(i,k)*h(i,k)) * Ih T(i,nkmb) = (T(i,nkmb)*h(i,nkmb) + T(i,k)*h(i,k)) * Ih S(i,nkmb) = (S(i,nkmb)*h(i,nkmb) + S(i,k)*h(i,k)) * Ih @@ -3193,11 +3719,24 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e ! the released buoyancy. With multiple buffer layers, much more ! graceful options are available. do i=is,ie ; if (h(i,nkmb) > 0.0) then - if ((R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb))) then - if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then - detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + if (CS%nonBous_energetics) then + must_unmix = (SpV0(i,0) > SpV0(i,nz)) .and. (SpV0(i,nz) > SpV0(i,nkmb)) + else + must_unmix = (R0(i,0) < R0(i,nz)) .and. (R0(i,nz) < R0(i,nkmb)) + endif + if (must_unmix) then + if (CS%nonBous_energetics) then + if ((SpV0(i,0)-SpV0(i,nz))*h(i,0) > (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb)) then + detrain(i) = (SpV0(i,nz)-SpV0(i,nkmb))*h(i,nkmb) / (SpV0(i,0)-SpV0(i,nkmb)) + else + detrain(i) = (SpV0(i,0)-SpV0(i,nz))*h(i,0) / (SpV0(i,0)-SpV0(i,nkmb)) + endif else - detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + if ((R0(i,nz)-R0(i,0))*h(i,0) > (R0(i,nkmb)-R0(i,nz))*h(i,nkmb)) then + detrain(i) = (R0(i,nkmb)-R0(i,nz))*h(i,nkmb) / (R0(i,nkmb)-R0(i,0)) + else + detrain(i) = (R0(i,nz)-R0(i,0))*h(i,0) / (R0(i,nkmb)-R0(i,0)) + endif endif d_eb(i,CS%nkml) = d_eb(i,CS%nkml) + detrain(i) @@ -3205,12 +3744,22 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e d_eb(i,nkmb) = d_eb(i,nkmb) - detrain(i) d_ea(i,nkmb) = d_ea(i,nkmb) + detrain(i) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & - (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) - x1 = R0(i,0) - R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) - R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + if (CS%nonBous_energetics) then + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) - nB_gRZ_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (SpV0(i,nkmb) - SpV0(i,0)) + x1 = SpV0(i,0) + SpV0(i,0) = SpV0(i,0) - detrain(i)*(SpV0(i,0)-SpV0(i,nkmb)) / h(i,0) + SpV0(i,nkmb) = SpV0(i,nkmb) - detrain(i)*(SpV0(i,nkmb)-x1) / h(i,nkmb) + else + if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & + CS%diag_PE_detrain(i,j) + g_H2_2dt * detrain(i)* & + (h(i,0) + h(i,nkmb)) * (R0(i,nkmb) - R0(i,0)) + x1 = R0(i,0) + R0(i,0) = R0(i,0) - detrain(i)*(R0(i,0)-R0(i,nkmb)) / h(i,0) + R0(i,nkmb) = R0(i,nkmb) - detrain(i)*(R0(i,nkmb)-x1) / h(i,nkmb) + endif + x1 = Rcv(i,0) Rcv(i,0) = Rcv(i,0) - detrain(i)*(Rcv(i,0)-Rcv(i,nkmb)) / h(i,0) Rcv(i,nkmb) = Rcv(i,nkmb) - detrain(i)*(Rcv(i,nkmb)-x1) / h(i,nkmb) @@ -3258,9 +3807,13 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e else ; orthogonal_extrap = .true. ; endif endif - if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle - ! In this case there is an inversion of in-situ density relative to - ! the coordinate variable. Do not detrain from the buffer layer. + ! Check for the case when there is an inversion of in-situ density relative to + ! the coordinate variable. Do not detrain from the buffer layer in this case. + if (CS%nonBous_energetics) then + if ((SpV0(i,0) <= SpV0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + else + if ((R0(i,0) >= R0(i,k1)) .or. (Rcv(i,0) >= Rcv(i,nkmb))) cycle + endif if (orthogonal_extrap) then ! 36 here is a typical oceanic value of (dR/dS) / (dR/dT) - it says @@ -3273,20 +3826,33 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e dT_dR = (T(i,0) - T(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) dS_dR = (S(i,0) - S(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) endif - dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & - (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) - ! Once again, there is an apparent density inversion in Rcv. - if (dRml < 0.0) cycle - dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + + if (CS%nonBous_energetics) then + dRml = dt_Time * (SpV0(i,0) - SpV0(i,nkmb)) * & + (Rcv(i,0) - Rcv(i,k1)) / (SpV0(i,k1) - SpV0(i,0)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dSpV0_dRcv = (SpV0(i,0) - SpV0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + else + dRml = dt_Time * (R0(i,nkmb) - R0(i,0)) * & + (Rcv(i,0) - Rcv(i,k1)) / (R0(i,0) - R0(i,k1)) + if (dRml < 0.0) cycle ! Once again, there is an apparent density inversion in Rcv. + dR0_dRcv = (R0(i,0) - R0(i,k1)) / (Rcv(i,0) - Rcv(i,k1)) + endif if ((Rcv(i,nkmb) - dRml < RcvTgt(k)) .and. (max_det_rem(i) > h(i,nkmb))) then ! In this case, the buffer layer is split into two isopycnal layers. - detrain(i) = h(i,nkmb)*(Rcv(i,nkmb) - RcvTgt(k)) / & - (RcvTgt(k+1) - RcvTgt(k)) + detrain(i) = h(i,nkmb) * (Rcv(i,nkmb) - RcvTgt(k)) / & + (RcvTgt(k+1) - RcvTgt(k)) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & - (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dSpV0_dRcv + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - RcvTgt(k)) * dR0_dRcv + endif + endif Tdown = detrain(i) * (T(i,nkmb) + dT_dR*(RcvTgt(k+1)-Rcv(i,nkmb))) T(i,k) = (h(i,k) * T(i,k) + & @@ -3333,9 +3899,15 @@ subroutine mixedlayer_detrain_1(h, T, S, R0, Rcv, RcvTgt, dt, dt_diag, d_ea, d_e h(i,k+1) = h(i,k+1) + detrain(i) h(i,nkmb) = h(i,nkmb) - detrain(i) - if (allocated(CS%diag_PE_detrain)) CS%diag_PE_detrain(i,j) = & - CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & - (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + if (allocated(CS%diag_PE_detrain)) then + if (CS%nonBous_energetics) then + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) + nB_gRZ_H2_2dt * detrain(i) * dSpV0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + else + CS%diag_PE_detrain(i,j) = CS%diag_PE_detrain(i,j) - g_H2_2dt * detrain(i) * dR0_dRcv * & + (h(i,nkmb)-detrain(i)) * (RcvTgt(k+1) - Rcv(i,nkmb) + dRml) + endif + endif endif endif ! (RcvTgt(k) <= Rcv(i,nkmb)) endif ! splittable_BL @@ -3379,7 +3951,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) character(len=40) :: mdl = "MOM_mixed_layer" ! This module's name. real :: omega_frac_dflt ! The default value for ML_OMEGA_FRAC [nondim] real :: ustar_min_dflt ! The default value for BML_USTAR_MIN [Z T-1 ~> m s-1] - real :: Hmix_min_z ! The default value of HMIX_MIN [Z ~> m] + real :: Hmix_min_z ! HMIX_MIN in units of vertical extent [Z ~> m], used to set other defaults integer :: isd, ied, jsd, jed logical :: use_temperature, use_omega isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3438,12 +4010,12 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) call get_param(param_file, mdl, "HMIX_MIN", Hmix_min_Z, & "The minimum mixed layer depth if the mixed layer depth "//& "is determined dynamically.", units="m", default=0.0, scale=US%m_to_Z) - CS%Hmix_min = GV%Z_to_H * Hmix_min_Z + CS%Hmix_min = GV%m_to_H * (US%Z_to_m * Hmix_min_Z) call get_param(param_file, mdl, "MECH_TKE_FLOOR", CS%mech_TKE_floor, & "A tiny floor on the amount of turbulent kinetic energy that is used when "//& "the mixed layer does not yet contain HMIX_MIN fluid. The default is so "//& "small that its actual value is irrelevant, so long as it is greater than 0.", & - units="m3 s-2", default=1.0e-150, scale=US%m_to_Z*US%m_s_to_L_T**2, & + units="m3 s-2", default=1.0e-150, scale=GV%m_to_H*US%m_s_to_L_T**2, & do_not_log=(Hmix_min_Z<=0.0)) call get_param(param_file, mdl, "LIMIT_BUFFER_DETRAIN", CS%limit_det, & @@ -3520,7 +4092,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "layers before sorting when ML_RESORT is true.", & units="nondim", default=0, fail_if_missing=.true.) ! Fail added by AJA. ! This gives a minimum decay scale that is typically much less than Angstrom. - ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%H_to_Z*GV%H_subroundoff) + ustar_min_dflt = 2e-4*CS%omega*(GV%Angstrom_Z + GV%dZ_subroundoff) call get_param(param_file, mdl, "BML_USTAR_MIN", CS%ustar_min, & "The minimum value of ustar that should be used by the "//& "bulk mixed layer model in setting vertical TKE decay "//& @@ -3528,6 +4100,11 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) 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) if (CS%ustar_min<=0.0) call MOM_error(FATAL, "BML_USTAR_MIN must be positive.") + call get_param(param_file, mdl, "BML_NONBOUSINESQ", CS%nonBous_energetics, & + "If true, use non-Boussinesq expressions for the energetic calculations "//& + "used in the bulk mixed layer calculations.", & + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq)) + call get_param(param_file, mdl, "RESOLVE_EKMAN", CS%Resolve_Ekman, & "If true, the NKML>1 layers in the mixed layer are "//& "chosen to optimally represent the impact of the Ekman "//& @@ -3546,7 +4123,7 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) if (CS%do_rivermix) & call get_param(param_file, mdl, "RIVERMIX_DEPTH", CS%rivermix_depth, & "The depth to which rivers are mixed if DO_RIVERMIX is "//& - "defined.", units="m", default=0.0, scale=US%m_to_Z) + "defined.", units="m", default=0.0, scale=GV%m_to_H) call get_param(param_file, mdl, "USE_RIVER_HEAT_CONTENT", CS%use_river_heat_content, & "If true, use the fluxes%runoff_Hflx field to set the "//& "heat carried by runoff, instead of using SST*CP*liq_runoff.", & @@ -3563,28 +4140,28 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) Time, 'Surface mixed layer depth', 'm', conversion=GV%H_to_m) CS%id_TKE_wind = register_diag_field('ocean_model', 'TKE_wind', diag%axesT1, & Time, 'Wind-stirring source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_RiBulk = register_diag_field('ocean_model', 'TKE_RiBulk', diag%axesT1, & Time, 'Mean kinetic energy source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv = register_diag_field('ocean_model', 'TKE_conv', diag%axesT1, & Time, 'Convective source of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_pen_SW = register_diag_field('ocean_model', 'TKE_pen_SW', diag%axesT1, & Time, 'TKE consumed by mixing penetrative shortwave radation through the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mixing = register_diag_field('ocean_model', 'TKE_mixing', diag%axesT1, & Time, 'TKE consumed by mixing that deepens the mixed layer', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_mech_decay = register_diag_field('ocean_model', 'TKE_mech_decay', diag%axesT1, & Time, 'Mechanical energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_decay = register_diag_field('ocean_model', 'TKE_conv_decay', diag%axesT1, & Time, 'Convective energy decay sink of mixed layer TKE', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_TKE_conv_s2 = register_diag_field('ocean_model', 'TKE_conv_s2', diag%axesT1, & Time, 'Spurious source of mixed layer TKE from sigma2', & - 'm3 s-3', conversion=US%Z_to_m*(US%L_to_m**2)*(US%s_to_T**3)) + 'm3 s-3', conversion=GV%H_to_m*(US%L_to_m**2)*(US%s_to_T**3)) CS%id_PE_detrain = register_diag_field('ocean_model', 'PE_detrain', diag%axesT1, & Time, 'Spurious source of potential energy from mixed layer detrainment', & 'W m-2', conversion=US%RZ3_T3_to_W_m2*US%L_to_Z**2) From 8d628bdb94303417fb4801d2c61d3c3291b5026c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 6 Aug 2023 12:56:23 -0400 Subject: [PATCH 426/629] +*Non-Boussinesq revision of diabatic_aux This commit changes differential_diffuse_TS, diagnoseMLDbyDensityDifference, diagnoseMLDbyEnergy and applyBoundaryFluxesInOut to make them appropriate for use in non-Boussinesq mode, and to eliminate dependencies on the Boussinesq reference density when in that mode. It also adds a new optional argument to extract_optics_slice to enable the use of the layer specific volumes to translate opacities into thickness-based units. The specific set of changes include: - Add the optional argument SpV_avg to extract_optics_slice and use it along with an appropriate value for opacity_scale to optionally convert the units of opacity from [Z-1 ~> m-1] to [H-1 ~> m-1 or m2 kg-1] in non-Boussinesq mode without making use of the Boussinesq reference density. - Use thickness_to_dz and work with internal variables in vertical distances in the denominator of diffusive flux calculations in differential_diffuse_T_S, diagnoseMLDbyDensityDifference and diagnoseMLDbyEnergy. - Refactored diagnoseMLDbyEnergy for probable efficiencies by calling the equation of state with contiguous arguments. - Use specific volume derivatives to calculate non-Boussinesq mode buoyancy fluxes in calculateBuoyancy_Flux1d and applyBoudaryFluxesInOut. - Use the inverse of SpV_avg rather than Rho0 in the calculation of the energy input used to drive river mixing when in non-Boussinesq mode. There are now separate thickness and depth change internal variables in several places to avoid any dependency on the Boussinesq reference density when in non-Boussinesq mode. A total of 8 rescaling factors were eliminated, and in one place, GV%Rho0 was replaced with GV%H_to_RZ. All Boussinesq answers are bitwise identical, but non-Boussinesq answers will change and become less dependent on the Boussinesq reference density, and there is a new optional argument to a publicly visible subroutine. --- .../vertical/MOM_diabatic_aux.F90 | 165 ++++++++++++------ 1 file changed, 108 insertions(+), 57 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6a5e454d19..95c4d43ad3 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -15,6 +15,7 @@ module MOM_diabatic_aux use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, extractFluxes1d, forcing_SinglePointPrint use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz 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 @@ -31,8 +32,8 @@ module MOM_diabatic_aux public diabatic_aux_init, diabatic_aux_end public make_frazil, adjust_salt, differential_diffuse_T_S, triDiagTS, triDiagTS_Eulerian -public find_uv_at_h, diagnoseMLDbyDensityDifference, applyBoundaryFluxesInOut, set_pen_shortwave -public diagnoseMLDbyEnergy +public find_uv_at_h, applyBoundaryFluxesInOut, set_pen_shortwave +public diagnoseMLDbyEnergy, diagnoseMLDbyDensityDifference ! 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 @@ -254,6 +255,7 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) b1_T, b1_S, & ! Variables used by the tridiagonal solvers of T & S [H ~> m or kg m-2]. d1_T, d1_S ! Variables used by the tridiagonal solvers [nondim]. real, dimension(SZI_(G),SZK_(GV)) :: & + dz, & ! Height change across layers [Z ~> m] c1_T, c1_S ! Variables used by the tridiagonal solvers [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)+1) :: & mix_T, mix_S ! Mixing distances in both directions across each interface [H ~> m or kg m-2]. @@ -261,20 +263,27 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) ! added to ensure positive definiteness [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: I_h_int ! The inverse of the thickness associated with an interface [H-1 ~> m-1 or m2 kg-1]. + real :: dz_neglect ! A vertical distance that is so small it is usually lost + ! in roundoff and can be neglected [Z ~> m]. + real :: I_dz_int ! The inverse of the height scale associated with an interface [Z-1 ~> m-1]. real :: b_denom_T ! The first term in the denominator for the expression for b1_T [H ~> m or kg m-2]. real :: b_denom_S ! The first term in the denominator for the expression for b1_S [H ~> m or kg m-2]. integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_neglect = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff !$OMP parallel do default(private) shared(is,ie,js,je,h,h_neglect,dt,Kd_T,Kd_S,G,GV,T,S,nz) do j=js,je + + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie - I_h_int = 1.0 / (0.5 * (h(i,j,1) + h(i,j,2)) + h_neglect) - mix_T(i,2) = ((dt * Kd_T(i,j,2)) * GV%Z_to_H) * I_h_int - mix_S(i,2) = ((dt * Kd_S(i,j,2)) * GV%Z_to_H) * I_h_int + I_dz_int = 1.0 / (0.5 * (dz(i,1) + dz(i,2)) + dz_neglect) + mix_T(i,2) = (dt * Kd_T(i,j,2)) * I_dz_int + mix_S(i,2) = (dt * Kd_S(i,j,2)) * I_dz_int h_tr = h(i,j,1) + h_neglect b1_T(i) = 1.0 / (h_tr + mix_T(i,2)) @@ -286,9 +295,9 @@ subroutine differential_diffuse_T_S(h, T, S, Kd_T, Kd_S, tv, dt, G, GV) enddo do k=2,nz-1 ; do i=is,ie ! Calculate the mixing across the interface below this layer. - I_h_int = 1.0 / (0.5 * (h(i,j,k) + h(i,j,k+1)) + h_neglect) - mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1)) * GV%Z_to_H) * I_h_int - mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1)) * GV%Z_to_H) * I_h_int + I_dz_int = 1.0 / (0.5 * (dz(i,k) + dz(i,k+1)) + dz_neglect) + mix_T(i,K+1) = ((dt * Kd_T(i,j,K+1))) * I_dz_int + mix_S(i,K+1) = ((dt * Kd_S(i,j,K+1))) * I_dz_int c1_T(i,k) = mix_T(i,K) * b1_T(i) c1_S(i,k) = mix_S(i,K) * b1_S(i) @@ -688,19 +697,22 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, ! Local variables real, dimension(SZI_(G)) :: deltaRhoAtKm1, deltaRhoAtK ! Density differences [R ~> kg m-3]. real, dimension(SZI_(G)) :: pRef_MLD, pRef_N2 ! Reference pressures [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m]. + real, dimension(SZI_(G)) :: H_subML, dH_N2 ! Summed thicknesses used in N2 calculation [H ~> m or kg m-2] + real, dimension(SZI_(G)) :: dZ_N2 ! Summed vertical distance used in N2 calculation [Z ~> m] real, dimension(SZI_(G)) :: T_subML, T_deeper ! Temperatures used in the N2 calculation [C ~> degC]. real, dimension(SZI_(G)) :: S_subML, S_deeper ! Salinities used in the N2 calculation [S ~> ppt]. real, dimension(SZI_(G)) :: rho_subML, rho_deeper ! Densities used in the N2 calculation [R ~> kg m-3]. - real, dimension(SZI_(G)) :: dK, dKm1 ! Depths [Z ~> m]. + real, dimension(SZI_(G),SZK_(GV)) :: dZ_2d ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G)) :: dZ, dZm1 ! Layer thicknesses associated with interfaces [Z ~> m] real, dimension(SZI_(G)) :: rhoSurf ! Density used in finding the mixed layer depth [R ~> kg m-3]. real, dimension(SZI_(G), SZJ_(G)) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZI_(G), SZJ_(G)) :: subMLN2 ! Diagnosed stratification below ML [T-2 ~> s-2]. real, dimension(SZI_(G), SZJ_(G)) :: MLD2 ! Diagnosed MLD^2 [Z2 ~> m2]. logical, dimension(SZI_(G)) :: N2_region_set ! If true, all necessary values for calculating N2 ! have been stored already. - real :: gE_Rho0 ! The gravitational acceleration divided by a mean density [Z T-2 R-1 ~> m4 s-2 kg-1]. - real :: dH_subML ! Depth below ML over which to diagnose stratification [H ~> m]. + real :: gE_Rho0 ! The gravitational acceleration, sometimes divided by the Boussinesq + ! reference density [H T-2 R-1 ~> m4 s-2 kg-1 or m s-2]. + real :: dZ_sub_ML ! Depth below ML over which to diagnose stratification [Z ~> m] real :: aFac ! A nondimensional factor [nondim] real :: ddRho ! A density difference [R ~> kg m-3] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -712,7 +724,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if (present(id_N2subML)) then if (present(dz_subML)) then id_N2 = id_N2subML - dH_subML = GV%Z_to_H*dz_subML + dZ_sub_ML = dz_subML else call MOM_error(FATAL, "When the diagnostic of the subML stratification is "//& "requested by providing id_N2_subML to diagnoseMLDbyDensityDifference, "//& @@ -720,29 +732,32 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, endif endif - gE_rho0 = US%L_to_Z**2*GV%g_Earth / GV%Rho0 + gE_rho0 = (US%L_to_Z**2 * GV%g_Earth) / GV%H_to_RZ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke pRef_MLD(:) = 0.0 EOSdom(:) = EOS_domain(G%HI) do j=js,je - do i=is,ie ; dK(i) = 0.5 * h(i,j,1) * GV%H_to_Z ; enddo ! Depth of center of surface layer + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dZ_2d, j, G, GV) + + do i=is,ie ; dZ(i) = 0.5 * dZ_2d(i,1) ; enddo ! Depth of center of surface layer call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, rhoSurf, tv%eqn_of_state, EOSdom) do i=is,ie deltaRhoAtK(i) = 0. MLD(i,j) = 0. if (id_N2>0) then subMLN2(i,j) = 0.0 - H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 + H_subML(i) = h(i,j,1) ; dH_N2(i) = 0.0 ; dZ_N2(i) = 0.0 T_subML(i) = 0.0 ; S_subML(i) = 0.0 ; T_deeper(i) = 0.0 ; S_deeper(i) = 0.0 N2_region_set(i) = (G%mask2dT(i,j)<0.5) ! Only need to work on ocean points. endif enddo do k=2,nz do i=is,ie - dKm1(i) = dK(i) ! Depth of center of layer K-1 - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K + dZm1(i) = dZ(i) ! Depth of center of layer K-1 + dZ(i) = dZ(i) + 0.5 * ( dZ_2d(i,k) + dZ_2d(i,k-1) ) ! Depth of center of layer K enddo ! Prepare to calculate stratification, N2, immediately below the mixed layer by finding @@ -752,15 +767,18 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if (MLD(i,j) == 0.0) then ! Still in the mixed layer. H_subML(i) = H_subML(i) + h(i,j,k) elseif (.not.N2_region_set(i)) then ! This block is below the mixed layer, but N2 has not been found yet. - if (dH_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML + if (dZ_N2(i) == 0.0) then ! Record the temperature, salinity, pressure, immediately below the ML T_subML(i) = tv%T(i,j,k) ; S_subML(i) = tv%S(i,j,k) H_subML(i) = H_subML(i) + 0.5 * h(i,j,k) ! Start midway through this layer. dH_N2(i) = 0.5 * h(i,j,k) - elseif (dH_N2(i) + h(i,j,k) < dH_subML) then + dZ_N2(i) = 0.5 * dz_2d(i,k) + elseif (dZ_N2(i) + dZ_2d(i,k) < dZ_sub_ML) then dH_N2(i) = dH_N2(i) + h(i,j,k) + dZ_N2(i) = dZ_N2(i) + dz_2d(i,k) else ! This layer includes the base of the region where N2 is calculated. T_deeper(i) = tv%T(i,j,k) ; S_deeper(i) = tv%S(i,j,k) dH_N2(i) = dH_N2(i) + 0.5 * h(i,j,k) + dZ_N2(i) = dZ_N2(i) + 0.5 * dz_2d(i,k) N2_region_set(i) = .true. endif endif @@ -776,18 +794,18 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, if ((MLD(i,j) == 0.) .and. (ddRho > 0.) .and. & (deltaRhoAtKm1(i) < densityDiff) .and. (deltaRhoAtK(i) >= densityDiff)) then aFac = ( densityDiff - deltaRhoAtKm1(i) ) / ddRho - MLD(i,j) = dK(i) * aFac + dKm1(i) * (1. - aFac) + MLD(i,j) = (dZ(i) * aFac + dZm1(i) * (1. - aFac)) endif if (id_SQ > 0) MLD2(i,j) = MLD(i,j)**2 enddo ! i-loop enddo ! k-loop do i=is,ie - if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dK(i) ! Assume mixing to the bottom + if ((MLD(i,j) == 0.) .and. (deltaRhoAtK(i) < densityDiff)) MLD(i,j) = dZ(i) ! Mixing goes to the bottom enddo if (id_N2>0) then ! Now actually calculate stratification, N2, below the mixed layer. do i=is,ie ; pRef_N2(i) = (GV%g_Earth * GV%H_to_RZ) * (H_subML(i) + 0.5*dH_N2(i)) ; enddo - ! if ((.not.N2_region_set(i)) .and. (dH_N2(i) > 0.5*dH_subML)) then + ! if ((.not.N2_region_set(i)) .and. (dZ_N2(i) > 0.5*dZ_sub_ML)) then ! ! Use whatever stratification we can, measured over whatever distance is available? ! T_deeper(i) = tv%T(i,j,nz) ; S_deeper(i) = tv%S(i,j,nz) ! N2_region_set(i) = .true. @@ -795,7 +813,7 @@ subroutine diagnoseMLDbyDensityDifference(id_MLD, h, tv, densityDiff, G, GV, US, call calculate_density(T_subML, S_subML, pRef_N2, rho_subML, tv%eqn_of_state, EOSdom) call calculate_density(T_deeper, S_deeper, pRef_N2, rho_deeper, tv%eqn_of_state, EOSdom) do i=is,ie ; if ((G%mask2dT(i,j) > 0.0) .and. N2_region_set(i)) then - subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / (GV%H_to_z * dH_N2(i)) + subMLN2(i,j) = gE_rho0 * (rho_deeper(i) - rho_subML(i)) / dH_N2(i) endif ; enddo endif enddo ! j-loop @@ -844,9 +862,9 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) ! Local variables real, dimension(SZI_(G),SZJ_(G),3) :: MLD ! Diagnosed mixed layer depth [Z ~> m]. real, dimension(SZK_(GV)+1) :: Z_int ! Depths of the interfaces from the surface [Z ~> m] - real, dimension(SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] - real, dimension(SZK_(GV)) :: Rho_c ! A column of layer densities [R ~> kg m-3] - real, dimension(SZK_(GV)) :: pRef_MLD ! The reference pressure for the mixed layer + real, dimension(SZI_(G),SZK_(GV)) :: dZ ! Layer thicknesses in depth units [Z ~> m] + real, dimension(SZI_(G),SZK_(GV)) :: Rho_c ! Columns of layer densities [R ~> kg m-3] + real, dimension(SZI_(G)) :: pRef_MLD ! The reference pressure for the mixed layer ! depth calculation [R L2 T-2 ~> Pa] real, dimension(3) :: PE_threshold ! The energy threshold divided by g [R Z2 ~> kg m-1] @@ -881,6 +899,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) real :: Fgx ! The mixing energy difference from the target [R Z2 ~> kg m-1] real :: Fpx ! The derivative of Fgx with x [R Z ~> kg m-2] + integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: IT, iM integer :: i, j, is, ie, js, je, k, nz @@ -894,15 +913,23 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) PE_threshold(iM) = Mixing_Energy(iM) / (US%L_to_Z**2*GV%g_Earth) enddo - do j=js,je ; do i=is,ie - if (G%mask2dT(i,j) > 0.0) then + MLD(:,:,:) = 0.0 + + EOSdom(:) = EOS_domain(G%HI) + + do j=js,je + ! Find the vertical distances across layers. + call thickness_to_dz(h, tv, dz, j, G, GV) + + do k=1,nz + call calculate_density(tv%T(:,j,k), tv%S(:,j,K), pRef_MLD, rho_c(:,k), tv%eqn_of_state, EOSdom) + enddo - call calculate_density(tv%T(i,j,:), tv%S(i,j,:), pRef_MLD, rho_c, tv%eqn_of_state) + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then Z_int(1) = 0.0 do k=1,nz - DZ(k) = h(i,j,k) * GV%H_to_Z - Z_int(K+1) = Z_int(K) - DZ(k) + Z_int(K+1) = Z_int(K) - dZ(i,k) enddo do iM=1,3 @@ -918,11 +945,11 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) do k=1,nz ! This is the unmixed PE cumulative sum from top down - PE = PE + 0.5 * rho_c(k) * (Z_int(K)**2 - Z_int(K+1)**2) + PE = PE + 0.5 * Rho_c(i,k) * (Z_int(K)**2 - Z_int(K+1)**2) ! This is the depth and integral of density - H_ML_TST = H_ML + DZ(k) - RhoDZ_ML_TST = RhoDZ_ML + rho_c(k) * DZ(k) + H_ML_TST = H_ML + dZ(i,k) + RhoDZ_ML_TST = RhoDZ_ML + Rho_c(i,k) * dZ(i,k) ! The average density assuming all layers including this were mixed Rho_ML = RhoDZ_ML_TST/H_ML_TST @@ -942,8 +969,8 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) R1 = RhoDZ_ML / H_ML ! The density of the mixed layer (not including this layer) D1 = H_ML ! The thickness of the mixed layer (not including this layer) - R2 = rho_c(k) ! The density of this layer - D2 = DZ(k) ! The thickness of this layer + R2 = Rho_c(i,k) ! The density of this layer + D2 = dZ(i,k) ! The thickness of this layer ! This block could be used to calculate the function coefficients if ! we don't reference all values to a surface designated as z=0 @@ -970,7 +997,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) Cc2 = R2 * (D - C) ! First guess for an iteration using Newton's method - X = DZ(k) * 0.5 + X = dZ(i,k) * 0.5 IT=0 do while(IT<10)!We can iterate up to 10 times @@ -1002,7 +1029,7 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) if (abs(Fgx) > PE_Threshold(iM) * PE_Threshold_fraction) then X2 = X - Fgx / Fpx IT = IT + 1 - if (X2 < 0. .or. X2 > DZ(k)) then + if (X2 < 0. .or. X2 > dZ(i,k)) then ! The iteration seems to be robust, but we need to do something *if* ! things go wrong... How should we treat failed iteration? ! Present solution: Stop trying to compute and just say we can't mix this layer. @@ -1021,10 +1048,8 @@ subroutine diagnoseMLDbyEnergy(id_MLD, h, tv, G, GV, US, Mixing_Energy, diagPtr) enddo MLD(i,j,iM) = H_ML enddo - else - MLD(i,j,:) = 0.0 - endif - enddo ; enddo + endif ; enddo + enddo if (id_MLD(1) > 0) call post_data(id_MLD(1), MLD(:,:,1), diagPtr) if (id_MLD(2) > 0) call post_data(id_MLD(2), MLD(:,:,2), diagPtr) @@ -1104,6 +1129,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t SurfPressure, & ! Surface pressure (approximated as 0.0) [R L2 T-2 ~> Pa] dRhodT, & ! change in density per change in temperature [R C-1 ~> kg m-3 degC-1] dRhodS, & ! change in density per change in salinity [R S-1 ~> kg m-3 ppt-1] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with to salinity [R-1 S-1 ~> m3 kg-1 ppt-1] netheat_rate, & ! netheat but for dt=1 [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1111,6 +1138,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t mixing_depth ! Mixed layer depth [Z -> m] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] + ! dz, & ! Layer thicknesses in depth units [Z ~> m] T2d, & ! A 2-d copy of the layer temperatures [C ~> degC] pen_TKE_2d, & ! The TKE required to homogenize the heating by shortwave radiation within ! a layer [R Z3 T-2 ~> J m-2] @@ -1133,6 +1161,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! in units of [Z3 R2 T-2 H-2 ~> kg2 m-5 s-2 or m s-2]. real :: GoRho ! g_Earth times a unit conversion factor divided by density ! [Z T-2 R-1 ~> m4 s-2 kg-1] + real :: g_conv ! The gravitational acceleration times the conversion factors from non-Boussinesq + ! thickness units to mass per units area [R Z2 H-1 T-2 ~> kg m-2 s-2 or m s-2] logical :: calculate_energetics ! If true, calculate the energy required to mix the newly added ! water over the topmost grid cell, assuming that the fluxes of heat and salt ! and rejected brine are initially applied in vanishingly thin layers at the @@ -1201,7 +1231,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP EnthalpyConst,MLD) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & - !$OMP IforcingDepthScale, & + !$OMP IforcingDepthScale,g_conv,dSpV_dT,dSpV_dS, & !$OMP dThickness,dTemp,dSalt,hOld,Ithickness, & !$OMP netMassIn,pres,d_pres,p_lay,dSV_dT_2d, & !$OMP netmassinout_rate,netheat_rate,netsalt_rate, & @@ -1244,7 +1274,14 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Nothing more is done on this j-slice if there is no buoyancy forcing. if (.not.associated(fluxes%sw)) cycle - if (nsw>0) call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=(1.0/GV%Z_to_H)) + if (nsw>0) then + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_Z) + else + call extract_optics_slice(optics, j, G, GV, opacity=opacityBand, opacity_scale=GV%H_to_RZ, & + SpV_avg=tv%SpV_avg) + endif + endif ! The surface forcing is contained in the fluxes type. ! We aggregate the thermodynamic forcing for a time step into the following: @@ -1378,6 +1415,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! Sriver = 0 (i.e. rivers are assumed to be pure freshwater) if (GV%Boussinesq) then RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) * GV%Rho0 + elseif (allocated(tv%SpV_avg)) then + RivermixConst = -0.5*(CS%rivermix_depth*dt) * ( US%L_to_Z**2*GV%g_Earth ) / tv%SpV_avg(i,j,1) else RivermixConst = -0.5*(CS%rivermix_depth*dt) * GV%Rho0 * ( US%L_to_Z**2*GV%g_Earth ) endif @@ -1610,8 +1649,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! 1) Answers will change due to round-off ! 2) Be sure to save their values BEFORE fluxes are used. if (Calculate_Buoyancy) then - drhodt(:) = 0.0 - drhods(:) = 0.0 netPen_rate(:) = 0.0 ! Sum over bands and attenuate as a function of depth. ! netPen_rate is the netSW as a function of depth, but only the surface value is used here, @@ -1623,20 +1660,34 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! H_limit_fluxes, .true., pen_SW_bnd_rate, netPen) do i=is,ie ; do nb=1,nsw ; netPen_rate(i) = netPen_rate(i) + pen_SW_bnd_rate(nb,i) ; enddo ; enddo - ! Density derivatives - if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif - call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & - tv%eqn_of_state, EOSdom) ! 1. Adjust netSalt to reflect dilution effect of FW flux ! 2. Add in the SW heating for purposes of calculating the net ! surface buoyancy flux affecting the top layer. ! 3. Convert to a buoyancy flux, excluding penetrating SW heating ! BGR-Jul 5, 2017: The contribution of SW heating here needs investigated for ePBL. - do i=is,ie - SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & - (dRhodS(i) * (netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & - dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] - enddo + if (associated(tv%p_surf)) then ; do i=is,ie ; SurfPressure(i) = tv%p_surf(i,j) ; enddo ; endif + + if ((.not.GV%Boussinesq) .and. (.not.GV%semi_Boussinesq)) then + g_conv = GV%g_Earth * GV%H_to_RZ * US%L_to_Z**2 + + ! Specific volume derivatives + call calculate_specific_vol_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, EOS_domain(G%HI)) + do i=is,ie + SkinBuoyFlux(i,j) = g_conv * & + (dSpV_dS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dSpV_dT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + else + ! Density derivatives + call calculate_density_derivs(T2d(:,1), tv%S(:,j,1), SurfPressure, dRhodT, dRhodS, & + tv%eqn_of_state, EOSdom) + do i=is,ie + SkinBuoyFlux(i,j) = - GoRho * GV%H_to_Z * & + (dRhodS(i) * ( netSalt_rate(i) - tv%S(i,j,1)*netMassInOut_rate(i)) + & + dRhodT(i) * ( netHeat_rate(i) + netPen_rate(i)) ) ! [Z2 T-3 ~> m2 s-3] + enddo + endif endif enddo ! j-loop finish From 3ef5b93390f4cd53d791cb46a86c1d365e51e395 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 20 Aug 2023 15:16:19 -0400 Subject: [PATCH 427/629] Do not allocate ustar and tau_mag together Modified MOM_surface_forcing_gfdl.F90 and MOM_surface_forcing.F90 to allocate either ustar or tau_mag, but not both, in the forcing and mech_forcing types, depending on whether the model is in Boussinesq mode. Also added tests to convert_IOB_to_forces in the FMS_cap code and to routines in MOM_surface_forcing in the solo_driver code to ensure that only arrays that are associated are set. All answers are bitwise identical, but checksum statements for the unused arrays are eliminated when DEBUG = True. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 47 ++++-- .../solo_driver/MOM_surface_forcing.F90 | 147 +++++++++++++----- 2 files changed, 139 insertions(+), 55 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 164193f6d7..f9f7fe88a0 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -63,6 +63,7 @@ module MOM_surface_forcing_gfdl !! the winds that are being provided in calls to !! update_ocean_model. logical :: use_temperature !< If true, temp and saln used as state variables. + logical :: nonBous !< If true, this run is fully non-Boussinesq real :: wind_stress_multiplier !< A multiplier applied to incoming wind stress [nondim]. real :: Rho0 !< Boussinesq reference density [R ~> kg m-3] @@ -282,8 +283,8 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! allocation and initialization if this is the first time that this ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then - call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., press=.true., & - fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) + call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.not.CS%nonBous, press=.true., & + fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=CS%nonBous) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -718,8 +719,8 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS, dt_ ! allocation and initialization if this is the first time that this ! mechanical forcing type has been used. if (.not.forces%initialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., & - press=.true., tau_mag=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, & + press=.true., tau_mag=CS%nonBous) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) @@ -792,14 +793,26 @@ 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, mag_tau=forces%tau_mag, tau_halo=1) + tau_halo=1) + if (associated(forces%ustar)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=forces%ustar) + if (associated(forces%tau_mag)) & + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=forces%tau_mag) else call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux=forces%taux, tauy=forces%tauy, & - 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 + tau_halo=1) + if (associated(forces%ustar)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, ustar=ustar_tmp) + do j=js,je ; do i=is,ie + forces%ustar(i,j) = wt1*forces%ustar(i,j) + wt2*ustar_tmp(i,j) + enddo ; enddo + endif + if (associated(forces%tau_mag)) then + call extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, mag_tau=tau_mag_tmp) + do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = wt1*forces%tau_mag(i,j) + wt2*tau_mag_tmp(i,j) + enddo ; enddo + endif endif ! Find the net mass source in the input forcing without other adjustments. @@ -960,7 +973,7 @@ subroutine extract_IOB_stresses(IOB, index_bounds, Time, G, US, CS, taux, tauy, ! Set surface momentum stress related fields as a function of staggering. if (present(taux) .or. present(tauy) .or. & - ((do_ustar.or.do_gustless) .and. .not.associated(IOB%stress_mag)) ) then + ((do_ustar .or. do_tau_mag .or. do_gustless) .and. .not.associated(IOB%stress_mag)) ) then if (wind_stagger == BGRID_NE) then taux_in_B(:,:) = 0.0 ; tauy_in_B(:,:) = 0.0 @@ -1278,6 +1291,8 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. real :: Flux_const_dflt ! A default piston velocity for restoring surface properties [m day-1] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq real :: rho_TKE_tidal ! The constant bottom density used to translate tidal amplitudes into the ! tidal bottom TKE input used with INT_TIDE_DISSIPATION [R ~> kg m-3] logical :: new_sim ! False if this simulation was started from a restart file @@ -1320,12 +1335,20 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, mdl, "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "SEMI_BOUSSINESQ", 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=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "RHO_0", CS%Rho0, & "The mean ocean density used with BOUSSINESQ true to "//& "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "LATENT_HEAT_FUSION", CS%latent_heat_fusion, & "The latent heat of fusion.", units="J/kg", default=hlf, scale=US%J_kg_to_Q) call get_param(param_file, mdl, "LATENT_HEAT_VAPORIZATION", CS%latent_heat_vapor, & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 5a37b18604..274a815145 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -72,6 +72,7 @@ module MOM_surface_forcing logical :: use_temperature !< if true, temp & salinity used as state variables logical :: restorebuoy !< if true, use restoring surface buoyancy forcing logical :: adiabatic !< if true, no diapycnal mass fluxes or surface buoyancy forcing + logical :: nonBous !< If true, this run is fully non-Boussinesq logical :: variable_winds !< if true, wind stresses vary with time logical :: variable_buoyforce !< if true, buoyancy forcing varies with time. real :: south_lat !< southern latitude of the domain [degrees_N] or [km] or [m] @@ -252,9 +253,10 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US if (CS%first_call_set_forcing) then ! Allocate memory for the mechanical and thermodynamic forcing fields. - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) - call allocate_forcing_type(G, fluxes, ustar=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) + call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, tau_mag=CS%nonBous, & + fix_accum_bug=CS%fix_ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -529,13 +531,15 @@ 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 + if (associated(forces%tau_mag)) 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))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie forces%ustar(i,j) = sqrt(US%L_to_Z * ((CS%gust_const/CS%Rho0) + & sqrt(0.5*(forces%tauy(i,J-1)*forces%tauy(i,J-1) + forces%tauy(i,J)*forces%tauy(i,J) + & forces%taux(I-1,j)*forces%taux(I-1,j) + forces%taux(I,j)*forces%taux(I,j)))/CS%Rho0) ) - enddo ; enddo + enddo ; enddo ; endif else call stresses_to_ustar(forces, G, US, CS) endif @@ -674,6 +678,9 @@ 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 :: ustar_loc(SZI_(G),SZJ_(G)) ! The local value of ustar [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] 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. @@ -734,16 +741,21 @@ 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 + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie 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 + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = CS%gust(i,j) + sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + forces%ustar(i,j) = sqrt(tau_mag * US%L_to_Z / CS%Rho0) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; 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) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie 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 + enddo ; enddo ; endif endif endif case ("C") @@ -782,21 +794,28 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) if (.not.read_Ustar) then if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie 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 + & + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = 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(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & - sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & - (forces%taux(I-1,j)**2 + forces%taux(I,j)**2)))/CS%Rho0)) - enddo ; enddo + forces%ustar(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 ) + enddo ; enddo ; endif + else + if (associated(forces%tau_mag)) 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))) + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + forces%ustar(i,j) = sqrt(US%L_to_Z * ( (CS%gust_const/CS%Rho0) + & + sqrt(0.5*((forces%tauy(i,J-1)**2 + forces%tauy(i,J)**2) + & + (forces%taux(I-1,j)**2 + forces%taux(I,j)**2)))/CS%Rho0)) + enddo ; enddo ; endif endif endif case default @@ -805,11 +824,14 @@ subroutine wind_forcing_from_file(sfc_state, forces, day, G, US, CS) end select if (read_Ustar) then - call MOM_read_data(filename, CS%Ustar_var, forces%ustar(:,:), & + call MOM_read_data(filename, CS%Ustar_var, ustar_loc(:,:), & 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 + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif endif CS%wind_last_lev = time_lev @@ -833,13 +855,16 @@ 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] + real :: ustar_prev(SZI_(G),SZJ_(G)) ! The pre-override value of ustar [Z T-1 ~> m s-1] + real :: ustar_loc(SZI_(G),SZJ_(G)) ! The value of ustar, perhaps altered by data override [Z T-1 ~> m s-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] integer :: i, j call callTree_enter("wind_forcing_by_data_override, MOM_surface_forcing.F90") if (.not.CS%dataOverrideIsInitialized) then - call allocate_mech_forcing(G, forces, stress=.true., ustar=.true., press=.true., tau_mag=.true.) + call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) call data_override_init(G%Domain) CS%dataOverrideIsInitialized = .True. endif @@ -858,26 +883,40 @@ 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 + if (associated(forces%tau_mag)) then ; 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(i,j) - forces%ustar(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) + enddo ; enddo ; endif + do j=G%jsc,G%jec ; do i=G%isc,G%iec + tau_mag = sqrt(temp_x(i,j)**2 + temp_y(i,j)**2) + CS%gust(i,j) + ustar_loc(i,j) = sqrt( tau_mag * US%L_to_Z / CS%Rho0 ) enddo ; enddo else + if (associated(forces%tau_mag)) then + 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 + ! ustar_loc(i,j) = sqrt( forces%tau_mag(i,j) * US%L_to_Z / CS%Rho0 ) + enddo ; enddo + endif 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)) + ustar_loc(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) + ustar_prev(:,:) = ustar_loc(:,:) + call data_override(G%Domain, 'ustar', ustar_loc, 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 + if (associated(forces%tau_mag)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ustar_prev(i,j) /= ustar_loc(i,j)) then + forces%tau_mag(i,j) = US%Z_to_L * CS%Rho0 * ustar_loc(i,j)**2 + endif ; enddo ; enddo + endif + + if (associated(forces%ustar)) then ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + forces%ustar(i,j) = ustar_loc(i,j) + enddo ; enddo ; endif call pass_vector(forces%taux, forces%tauy, G%Domain, To_All) @@ -894,6 +933,8 @@ subroutine stresses_to_ustar(forces, G, US, CS) ! Local variables real :: I_rho ! The inverse of the reference density times a ratio of scaling ! factors [Z L-1 R-1 ~> m3 kg-1] + real :: tau_mag ! The magnitude of the wind stress including any contributions from + ! sub-gridscale variability or gustiness [R L Z T-2 ~> Pa] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -901,19 +942,29 @@ subroutine stresses_to_ustar(forces, G, US, CS) I_rho = US%L_to_Z / CS%Rho0 if (CS%read_gust_2d) then - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) then ; do j=js,je ; do i=is,ie 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 + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = 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( tau_mag * I_rho ) + enddo ; enddo ; endif else - do j=js,je ; do i=is,ie + if (associated(forces%tau_mag)) 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( forces%tau_mag(i,j) * I_rho ) - enddo ; enddo + enddo ; enddo ; endif + if (associated(forces%ustar)) then ; do j=js,je ; do i=is,ie + tau_mag = 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( tau_mag * I_rho ) + enddo ; enddo ; endif endif end subroutine stresses_to_ustar @@ -1528,6 +1579,8 @@ 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] + logical :: Boussinesq ! If true, this run is fully Boussinesq + logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1550,6 +1603,14 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "ENABLE_THERMODYNAMICS", CS%use_temperature, & "If true, Temperature and salinity are used as state "//& "variables.", default=.true.) + call get_param(param_file, "MOM", "BOUSSINESQ", Boussinesq, & + "If true, make the Boussinesq approximation.", default=.true., do_not_log=.true.) + call get_param(param_file, "MOM", "SEMI_BOUSSINESQ", 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=.true.) + CS%nonBous = .not.(Boussinesq .or. semi_Boussinesq) call get_param(param_file, mdl, "INPUTDIR", CS%inputdir, & "The directory in which all input files are found.", & default=".") @@ -1812,7 +1873,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C "calculate accelerations and the mass for conservation "//& "properties, or with BOUSSINSEQ false to convert some "//& "parameters from vertical units of m to kg m-2.", & - units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) + units="kg m-3", default=1035.0, scale=US%kg_m3_to_R) ! (, do_not_log=CS%nonBous) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back toward some "//& "specified surface state with a rate given by FLUXCONST.", default=.false.) From e2d244f08323522f52f31c8a1b71e765291314a0 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 4 Oct 2023 16:14:00 -0800 Subject: [PATCH 428/629] We need an extra pass_var for Kv_shear - Only when REMAP_AUXILIARY_VARS is true. --- src/core/MOM.F90 | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 3013729109..25f4f27ee7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1623,6 +1623,8 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) + if (associated(CS%visc%Kv_shear)) & + call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, clock=id_clock_pass, halo=1) endif ! Replace the old grid with new one. All remapping must be done by this point in the code. From 08704f8c4f72901bf153221caa77173676692575 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 2 Aug 2023 07:51:17 -0400 Subject: [PATCH 429/629] +*Non-Boussinesq wave_speed calculations Modified the internal wave speed calculation to work in non-Boussinesq mode without any dependencies on the Boussinesq reference density (RHO_0). Many factors of GV%H_to_Z or its inverse are cancelled out in MOM_wave_speed.F90 by working directly in thickness units. The code now uses specific volume derivatives to set the values of g_prime at interfaces when in non-Boussinesq mode, regardless of whether an equation of state is used. This commit also modifies the wave structure calculations in wave_speeds, which includes the use of thickness_to_dz, changes to the units of three arguments to wave_speeds and their counterparts in int_tide_CS, and a number of duplicated calculations of vertical extents mirroring the calculations of thicknesses. Some diagnostic conversion factors were modified accordingly in MOM_internal_tides. This commit involves changing the units of 19 internal variables in wave_speed and 17 internal variables in wave_speeds to use thickness units or other related units. There are 6 new or renamed internal variables in wave_speed and 10 new or renamed variables in wave_speeds. A total 34 thickness rescaling factors or references to GV%Rho0 were cancelled out or replaced. Missing comments describing the units of several real variables were also added. All answers are bitwise identical in Boussinesq mode, but answers do change in non-Boussinesq solutions that depend on the internal wave speed. This commit eliminates the dependencies of the non-Boussinesq wave speed calculations on the Boussinesq reference density. --- src/diagnostics/MOM_wave_speed.F90 | 588 ++++++++++++------ .../lateral/MOM_internal_tides.F90 | 17 +- 2 files changed, 390 insertions(+), 215 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index c2b671f1c6..92c76001c7 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -7,11 +7,12 @@ 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_interface_heights, only : thickness_to_dz 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 -use MOM_EOS, only : calculate_density_derivs +use MOM_EOS, only : calculate_density_derivs, calculate_specific_vol_derivs implicit none ; private @@ -89,27 +90,28 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 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] - 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]. + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1]. 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, in [T2 L-2 ~> s2 m-2]. real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] 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] + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] 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] - 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] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] real :: det, ddet ! Determinant of the eigen system and its derivative with lam. Because the ! units of the eigenvalue change with the number of layers and because of the ! dynamic rescaling that is used to keep det in a numerically representable range, @@ -118,18 +120,21 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ real :: lam ! The eigenvalue [T2 L-2 ~> s2 m-2] real :: dlam ! The change in estimates of the eigenvalue [T2 L-2 ~> s2 m-2] real :: lam0 ! The first guess of the eigenvalue [T2 L-2 ~> s2 m-2] - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, dimension(SZI_(G)) :: & - htot, 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] + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A thickness [H ~> m or kg m-2] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 or m7 s-2 kg-2]. 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]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -148,15 +153,16 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! with each iteration. Because of all of the dynamic rescaling of the determinant ! between rows, its units are not easily interpretable, but the ratio of det/ddet ! always has units of [T2 L-2 ~> s2 m-2] - logical :: use_EOS ! If true, density is calculated from T & S using an equation of state. + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using an equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. 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. integer :: kc ! The number of layers in the column after merging integer :: i, j, k, k2, itt, is, ie, js, je, nz - real :: hw ! The mean of the adjacent layer thicknesses [Z ~> m] - real :: sum_hc ! The sum of the layer thicknesses [Z ~> m] - real :: gp ! A limited local copy of gprime [L2 Z-1 T-2 ~> m s-2] - real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 Z-2 T-2 ~> s-2] + real :: hw ! The mean of the adjacent layer thicknesses [H ~> m or kg m-2] + real :: sum_hc ! The sum of the layer thicknesses [H ~> m or kg m-2] + real :: gp ! A limited local copy of gprime [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1] + real :: N2min ! A minimum buoyancy frequency, including a slope rescaling factor [L2 H-2 T-2 ~> s-2 or m6 kg-2 s-2] logical :: below_mono_N2_frac ! True if an interface is below the fractional depth where N2 should not increase. logical :: below_mono_N2_depth ! True if an interface is below the absolute depth where N2 should not increase. logical :: l_use_ebt_mode, calc_modal_structure @@ -190,9 +196,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ enddo ; enddo ; enddo endif - g_Rho0 = GV%g_Earth / GV%Rho0 - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + g_Rho0 = GV%g_Earth*GV%H_to_Z / GV%Rho0 + H_to_pres = GV%H_to_RZ * GV%g_Earth + ! Note that g_Rho0 = H_to_pres / GV%Rho0**2 + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) use_EOS = associated(tv%eqn_of_state) better_est = CS%better_cg1_est @@ -216,17 +223,17 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ c2_scale = US%m_s_to_L_T**2 / 4096.0**2 ! Other powers of 2 give identical results. min_h_frac = tol_Hfrac / real(nz) - !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS, & + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,tv,use_EOS,nonBous, & !$OMP CS,min_h_frac,calc_modal_structure,l_use_ebt_mode, & !$OMP modal_structure,l_mono_N2_column_fraction,l_mono_N2_depth, & - !$OMP Z_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & + !$OMP H_to_pres,cg1,g_Rho0,rescale,I_rescale,cg1_min2, & !$OMP better_est,tol_solve,tol_merge,c2_scale) 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) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 @@ -234,20 +241,20 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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 + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > 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) + H_here(i) = h(i,j,k) + HxT_here(i) = h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = h(i,j,k) * 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) + H_here(i) = H_here(i) + h(i,j,k) + HxT_here(i) = HxT_here(i) + h(i,j,k) * tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k) * tv%S(i,j,k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -255,18 +262,18 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ Tf(kf(i),i) = HxT_here(i) / H_here(i) Sf(kf(i),i) = HxS_here(i) / H_here(i) endif ; enddo - else + else ! .not. (use_EOS) 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 + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > 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) + H_here(i) = h(i,j,k) + HxR_here(i) = h(i,j,k)*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) + H_here(i) = H_here(i) + h(i,j,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*GV%Rlay(k) endif enddo ; enddo do i=is,ie ; if (H_here(i) > 0.0) then @@ -279,16 +286,21 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) - pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + pres(K) = pres(K-1) + H_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)) H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif ! Sum the reduced gravities to find out how small a density difference is negligibly small. - drxh_sum = 0.0 + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. @@ -297,44 +309,81 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif else ! This estimate is problematic in that it goes like 1/nz for a large number of layers, ! but it is an overestimate (as desired) for a small number of layers, by at a factor ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. - 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 + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + 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 + endif endif - else - drxh_sum = 0.0 + else ! .not. (use_EOS) + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then H_top(1) = 0.0 do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif else - 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 + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + 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 endif endif ! use_EOS + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + ! Find gprime across each internal interface, taking care of convective instabilities by ! merging layers. If the estimated wave speed is too small, simply return zero. - if (g_Rho0 * drxh_sum <= cg1_min2) then + if (cg1_est <= cg1_min2) then cg1(i,j) = 0.0 if (present(modal_structure)) modal_structure(i,j,:) = 0. else @@ -345,9 +394,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ kc = 1 Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if (better_est) then + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) else merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) @@ -362,9 +417,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do K2=kc,2,-1 - if (better_est) then + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) else merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) @@ -381,20 +442,36 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else ! Add a new layer to the column. kc = kc + 1 - drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif 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 + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + 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 (better_est) then + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) else merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) @@ -407,7 +484,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ ! that the tolerance is a factor of two larger, to avoid limit how ! far back we go. do k2=kc,2,-1 - if (better_est) then + if (nonBous .and. better_est) then + merge = ((Rc(k2) - Rc(k2-1)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rc(k2) - Rc(k2-1)) * (Hc(kc) + Hf(k,i)) < & + (Rc(k2-1)*Rc(k2)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((Rc(k2)-Rc(k2-1)) * ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) else merge = ((Rc(k2)-Rc(k2-1)) * (Hc(k2)+Hc(k2-1)) < tol_merge*drxh_sum) @@ -426,9 +509,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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 + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif endif ! use_EOS ! Sum the contributions from all of the interfaces to give an over-estimate @@ -453,14 +542,18 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ do k=2,kc hw = 0.5*(Hc(k-1)+Hc(k)) gp = gprime(K) + if (l_mono_N2_column_fraction>0. .or. l_mono_N2_depth>=0.) then - ! Determine whether N2 estimates should not be allowed to increase with depth. + ! Determine whether N2 estimates should not be allowed to increase with depth. if (l_mono_N2_column_fraction>0.) then - !### Change to: (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) - below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & - l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + below_mono_N2_frac = ((G%bathyT(i,j)+G%Z_ref) - GV%H_to_Z*sum_hc < & + l_mono_N2_column_fraction*(G%bathyT(i,j)+G%Z_ref)) + else + below_mono_N2_frac = (htot(i) - sum_hc < l_mono_N2_column_fraction*htot(i)) + endif endif - if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > GV%H_to_Z*l_mono_N2_depth) + if (l_mono_N2_depth >= 0.) below_mono_N2_depth = (sum_hc > l_mono_N2_depth) if ( (gp > N2min*hw) .and. (below_mono_N2_frac .or. below_mono_N2_depth) ) then ! Filters out regions where N2 increases with depth, but only in a lower fraction @@ -578,17 +671,13 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ else mode_struct(1:kc)=0. endif - ! Note that remapping_core_h requires that the same units be used - ! for both the source and target grid thicknesses, here [H ~> m or kg m-2]. - do k = 1,kc - Hc_H(k) = GV%Z_to_H * Hc(k) - enddo + if (CS%remap_answer_date < 20190101) then - call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & nz, h(i,j,:), modal_structure(i,j,:), & 1.0e-30*GV%m_to_H, 1.0e-10*GV%m_to_H) else - call remapping_core_h(CS%remapping_CS, kc, Hc_H(:), mode_struct, & + call remapping_core_h(CS%remapping_CS, kc, Hc(:), mode_struct, & nz, h(i,j,:), modal_structure(i,j,:), & GV%H_subroundoff, GV%H_subroundoff) endif @@ -666,22 +755,23 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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),SZK_(GV)+1,nmodes),intent(out) :: w_struct !< Wave vertical velocity profile [nondim] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),nmodes),intent(out) :: u_struct !< Wave horizontal velocity 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_max !< Maximum of wave horizontal velocity + !! 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 + !! velocity profile [Z-1 ~> m-1] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: Nb !< Bottom value of buoyancy 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] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_w2 !< depth-integrated vertical velocity + !! profile squared [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_U2 !< depth-integrated horizontal velocity + !! profile squared [H Z-2 ~> m-1 or kg m-4] + real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated buoyancy frequency + !! times vertical velocity profile + !! squared [H T-2 ~> m s-2 or kg m-2 s-2] logical, optional, intent(in) :: full_halos !< If true, do the calculation !! over the entire data domain. @@ -689,27 +779,32 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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] + dSpV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1] + dSpV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 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] - 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]. + H_top, & ! The distance of each filtered interface from the ocean surface [H ~> m or kg m-2] + H_bot, & ! The distance of each filtered interface from the bottom [H ~> m or kg m-2] + gprime, & ! The reduced gravity across each interface [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. N2 ! The buoyancy freqency squared [T-2 ~> s-2] real, dimension(SZK_(GV),SZI_(G)) :: & - Hf, & ! Layer thicknesses after very thin layers are combined [Z ~> m] + Hf, & ! Layer thicknesses after very thin layers are combined [H ~> m or kg m-2] + dzf, & ! Layer vertical extents 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(SZI_(G),SZK_(GV)) :: & + dz_2d ! Height change across layers [Z ~> m] 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, in [T2 L-2 ~> s2 m-2]. - Hc, & ! A column of layer thicknesses after convective instabilities are removed [Z ~> m] + Hc, & ! A column of layer thicknesses after convective instabilities are removed [H ~> m or kg m-2] + dzc, & ! A column of layer vertical extents 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] - 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-1 ~> m-1] + Rc ! A column of layer densities after convective instabilities are removed [R ~> kg m-3] + real :: I_Htot ! The inverse of the total filtered thicknesses [H-1 ~> m-1 or m2 kg-1] real :: c2_scale ! A scaling factor for wave speeds to help control the growth of the determinant and its ! derivative with lam between rows of the Thomas algorithm solver [L2 s2 T-2 m-2 ~> nondim]. ! The exact value should not matter for the final result if it is an even power of 2. @@ -740,20 +835,24 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s xbl, xbr ! lam guesses bracketing a zero-crossing (root) [T2 L-2 ~> s2 m-2] integer :: numint ! number of widows (intervals) in root searching range integer :: nrootsfound ! number of extra roots found (not including 1st root) - real :: Z_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 Z-1 ~> Pa m-1] + real :: H_to_pres ! A conversion factor from thicknesses to pressure [R L2 T-2 H-1 ~> Pa m-1 or Pa m2 kg-1] real, dimension(SZI_(G)) :: & - htot, 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] + htot, hmin, & ! Thicknesses [H ~> m or kg m-2] + H_here, & ! A layer thickness [H ~> m or kg m-2] + dz_here, & ! A layer vertical extent [Z ~> m] + HxT_here, & ! A layer integrated temperature [C H ~> degC m or degC kg m-2] + HxS_here, & ! A layer integrated salinity [S H ~> ppt m or ppt kg m-2] + HxR_here ! A layer integrated density [R H ~> kg m-2 or kg2 m-5] real :: speed2_tot ! overestimate of the mode-1 speed squared [L2 T-2 ~> m2 s-2] real :: speed2_min ! minimum mode speed (squared) to consider in root searching [L2 T-2 ~> m2 s-2] real :: cg1_min2 ! A floor in the squared first mode speed below which 0 is returned [L2 T-2 ~> m2 s-2] + real :: cg1_est ! An initial estimate of the squared first mode speed [L2 T-2 ~> m2 s-2] real, parameter :: reduct_factor = 0.5 ! A factor used in setting speed2_min [nondim] - real :: I_Hnew ! The inverse of a new layer thickness [Z-1 ~> m-1] - real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R Z ~> kg m-2] - real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 Z-1 R-1 ~> m4 s-2 kg-1]. + real :: I_Hnew ! The inverse of a new layer thickness [H-1 ~> m-1 or m2 kg-1] + real :: drxh_sum ! The sum of density differences across interfaces times thicknesses [R H ~> kg m-2 or kg2 m-5] + real :: dSpVxh_sum ! The sum of specific volume differences across interfaces times + ! thicknesses [R-1 H ~> m4 kg-1 or m], negative for stable stratification. + real :: g_Rho0 ! G_Earth/Rho0 [L2 T-2 H-1 R-1 ~> m4 s-2 kg-1 pr m7 s-2 kg-1]. real :: tol_Hfrac ! Layers that together are smaller than this fraction of ! the total water column can be merged for efficiency [nondim]. real :: min_h_frac ! tol_Hfrac divided by the total number of layers [nondim]. @@ -762,7 +861,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! when deciding to merge layers in the calculation [nondim] integer :: kf(SZI_(G)) ! The number of active layers after filtering. integer, parameter :: max_itt = 30 - logical :: use_EOS ! If true, density is calculated from T & S using the equation of state. + logical :: use_EOS ! If true, density or specific volume is calculated from T & S using the equation of state. + logical :: nonBous ! If true, do not make the Boussinesq approximation. 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. integer :: nsub ! number of subintervals used for root finding @@ -777,17 +877,17 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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_fder(SZK_(GV)) ! The mode structure 1st derivative [Z-1 ~> m-1], but it is also temporarily + ! in units of [Z-1 L2 T-2 ~> m 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 + real :: w2avg ! A total for renormalization [H L4 T-4 ~> m5 s-4 or kg m2 s-4] + real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim] + real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -798,9 +898,9 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed endif ; endif - g_Rho0 = GV%g_Earth / GV%Rho0 - ! Simplifying the following could change answers at roundoff. - Z_to_pres = GV%Z_to_H * (GV%H_to_RZ * GV%g_Earth) + g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 + H_to_pres = GV%H_to_RZ * GV%g_Earth + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) use_EOS = associated(tv%eqn_of_state) if (CS%c1_thresh < 0.0) & @@ -830,59 +930,69 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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, & - !$OMP Z_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2,better_est, & - !$OMP tol_solve,tol_merge,c2_scale) + !$OMP parallel do default(private) shared(is,ie,js,je,nz,h,G,GV,US,CS,use_EOS,nonBous, & + !$OMP min_h_frac,H_to_pres,tv,cn,g_Rho0,nmodes,cg1_min2, & + !$OMP better_est,tol_solve,tol_merge,c2_scale) 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) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k)*GV%H_to_Z ; enddo ; enddo + do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo + + call thickness_to_dz(h, tv, dz_2d, j, G, GV) do i=is,ie - hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 + hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 ; dz_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 + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) + dzf(kf(i),i) = dz_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) + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxT_here(i) = h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = h(i,j,k)*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) + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxT_here(i) = HxT_here(i) + h(i,j,k)*tv%T(i,j,k) + HxS_here(i) = HxS_here(i) + h(i,j,k)*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) + dzf(kf(i),i) = dz_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 + else ! .not. (use_EOS) 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 + if ((H_here(i) > hmin(i)) .and. (h(i,j,k) > hmin(i))) then Hf(kf(i),i) = H_here(i) ; Rf(kf(i),i) = HxR_here(i) / H_here(i) + dzf(kf(i),i) = dz_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) + H_here(i) = h(i,j,k) + dz_here(i) = dz_2d(i,k) + HxR_here(i) = h(i,j,k)*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) + H_here(i) = H_here(i) + h(i,j,k) + dz_here(i) = dz_here(i) + dz_2d(i,k) + HxR_here(i) = HxR_here(i) + h(i,j,k)*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) + dzf(kf(i),i) = dz_here(i) endif ; enddo endif @@ -892,16 +1002,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (use_EOS) then pres(1) = 0.0 ; H_top(1) = 0.0 do K=2,kf(i) - pres(K) = pres(K-1) + Z_to_pres*Hf(k-1,i) + pres(K) = pres(K-1) + H_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)) H_top(K) = H_top(K-1) + Hf(k-1,i) enddo - call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & - tv%eqn_of_state, (/2,kf(i)/) ) + if (nonBous) then + call calculate_specific_vol_derivs(T_int, S_int, pres, dSpV_dT, dSpV_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + else + call calculate_density_derivs(T_int, S_int, pres, drho_dT, drho_dS, & + tv%eqn_of_state, (/2,kf(i)/) ) + endif ! Sum the reduced gravities to find out how small a density difference is negligibly small. - drxh_sum = 0.0 + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then ! This is an estimate that is correct for the non-EBT mode for 2 or 3 layers, or for ! clusters of massless layers at interfaces that can be grouped into 2 or 3 layers. @@ -910,33 +1025,57 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & - max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + max(0.0, drho_dT(K)*(Tf(k,i)-Tf(k-1,i)) + drho_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + endif endif else ! This estimate is problematic in that it goes like 1/nz for a large number of layers, ! but it is an overestimate (as desired) for a small number of layers, by at a factor ! of (H1+H2)**2/(H1*H2) >= 4 for two thick layers. - 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 + if (nonBous) then + do K=2,kf(i) + dSpVxh_sum = dSpVxh_sum + 0.5*(Hf(k-1,i)+Hf(k,i)) * & + min(0.0, dSpV_dT(K)*(Tf(k,i)-Tf(k-1,i)) + dSpV_dS(K)*(Sf(k,i)-Sf(k-1,i))) + enddo + else + 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 + endif endif - else - drxh_sum = 0.0 + cg1_est = g_Rho0 * drxh_sum + else ! Not use_EOS + drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then H_top(1) = 0.0 do K=2,kf(i) ; H_top(K) = H_top(K-1) + Hf(k-1,i) ; enddo if (H_top(kf(i)) > 0.0) then I_Htot = 1.0 / (H_top(kf(i)) + Hf(kf(i),i)) ! = 1.0 / (H_top(K) + H_bot(K)) for all K. H_bot(kf(i)+1) = 0.0 - do K=kf(i),2,-1 - H_bot(K) = H_bot(K+1) + Hf(k,i) - drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) - enddo + if (nonBous) then + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + dSpVxh_sum = dSpVxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * & + min(0.0, (Rf(k-1,i)-Rf(k,i)) / (Rf(k,i)*Rf(k-1,i))) + enddo + else + do K=kf(i),2,-1 + H_bot(K) = H_bot(K+1) + Hf(k,i) + drxh_sum = drxh_sum + ((H_top(K) * H_bot(K)) * I_Htot) * max(0.0,Rf(k,i)-Rf(k-1,i)) + enddo + endif endif else do K=2,kf(i) @@ -945,19 +1084,32 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s endif endif + if (nonBous) then + ! Note that dSpVxh_sum is negative for stable stratification. + cg1_est = H_to_pres * abs(dSpVxh_sum) + else + cg1_est = g_Rho0 * drxh_sum + endif + ! Find gprime across each internal interface, taking care of convective ! instabilities by merging layers. - if (g_Rho0 * drxh_sum > cg1_min2) then + if (cg1_est > cg1_min2) then ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. - if (use_EOS) then + if (use_EOS .and. (.not.nonBous)) then kc = 1 - Hc(1) = Hf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) - if (better_est) then + if (better_est .and. nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + ((Hc(kc) * Hf(k,i))*I_Htot) < abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + elseif (nonBous) then + merge = ((dSpV_dT(K)*(Tc(kc)-Tf(k,i)) + dSpV_dS(K)*(Sc(kc)-Sf(k,i))) * & + (Hc(kc) + Hf(k,i)) < abs(2.0 * tol_merge * dSpVxh_sum)) else merge = ((drho_dT(K)*(Tf(k,i)-Tc(kc)) + drho_dS(K)*(Sf(k,i)-Sc(kc))) * & (Hc(kc) + Hf(k,i)) < 2.0 * tol_merge*drxh_sum) @@ -967,14 +1119,21 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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)) + Hc(kc) = Hc(kc) + Hf(k,i) + dzc(kc) = dzc(kc) + dzf(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 (better_est) then + if (better_est .and. nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + ((Hc(k2) * Hc(k2-1))*I_Htot) < abs(tol_merge * dSpVxh_sum) ) + elseif (better_est) then merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & ((Hc(k2) * Hc(k2-1))*I_Htot) < tol_merge*drxh_sum) + elseif (nonBous) then + merge = ( (dSpV_dT(K2)*(Tc(k2-1)-Tc(k2)) + dSpV_dS(K2)*(Sc(k2-1)-Sc(k2))) * & + (Hc(k2) + Hc(k2-1)) < abs(tol_merge * dSpVxh_sum) ) else merge = ((drho_dT(K2)*(Tc(k2)-Tc(k2-1)) + drho_dS(K2)*(Sc(k2)-Sc(k2-1))) * & (Hc(k2) + Hc(k2-1)) < tol_merge*drxh_sum) @@ -985,27 +1144,44 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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) + dzc(kc-1) = dzc(kc) + dzc(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) + if (nonBous) then + dSpV_dS(Kc) = dSpV_dS(K) ; dSpV_dT(Kc) = dSpV_dT(K) + else + drho_dS(Kc) = drho_dS(K) ; drho_dT(Kc) = drho_dT(K) + endif + Tc(kc) = Tf(k,i) ; Sc(kc) = Sf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(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 + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (dSpV_dT(K)*(Tc(k-1)-Tc(k)) + dSpV_dS(K)*(Sc(k-1)-Sc(k))) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (drho_dT(K)*(Tc(k)-Tc(k-1)) + drho_dS(K)*(Sc(k)-Sc(k-1))) + enddo + endif + else ! .not. (use_EOS) ! Do the same with density directly... kc = 1 - Hc(1) = Hf(1,i) ; Rc(1) = Rf(1,i) + Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Rc(1) = Rf(1,i) do k=2,kf(i) - if (better_est) then - merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0 * tol_merge*drxh_sum) + if (nonBous .and. better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (nonBous) then + merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < & + (Rc(kc)*Rf(k,i)) * abs(2.0 * tol_merge * dSpVxh_sum)) + elseif (better_est) then + merge = ((Rf(k,i) - Rc(kc)) * ((Hc(kc) * Hf(k,i))*I_Htot) < 2.0*tol_merge*drxh_sum) else merge = ((Rf(k,i) - Rc(kc)) * (Hc(kc) + Hf(k,i)) < 2.0*tol_merge*drxh_sum) endif @@ -1013,6 +1189,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! 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) + dzc(kc) = dzc(kc) + dzf(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. @@ -1026,19 +1203,26 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! 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) + dzc(kc-1) = dzc(kc) + dzc(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) + Rc(kc) = Rf(k,i) ; Hc(kc) = Hf(k,i) ; dzc(kc) = dzf(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 + if (nonBous) then + do K=2,kc + gprime(K) = H_to_pres * (Rc(k) - Rc(k-1)) / (Rc(k) * Rc(k-1)) + enddo + else + do K=2,kc + gprime(K) = g_Rho0 * (Rc(k)-Rc(k-1)) + enddo + endif endif ! use_EOS !-----------------NOW FIND WAVE SPEEDS--------------------------------------- @@ -1063,8 +1247,13 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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))) + Igl(K) = 1.0 / (gprime(K)*Hc(k)) ; Igu(K) = 1.0 / (gprime(K)*Hc(k-1)) + if (nonBous) then + N2(K) = 2.0*US%L_to_Z**2*gprime(K) * (Hc(k) + Hc(k-1)) / & ! Units are [T-2 ~> s-2] + (dzc(k) + dzc(k-1))**2 + else + N2(K) = 2.0*US%L_to_Z**2*GV%Z_to_H*gprime(K) / (dzc(k) + dzc(k-1)) ! Units are [T-2 ~> s-2] + endif if (better_est) then speed2_tot = speed2_tot + gprime(K)*((H_top(K) * H_bot(K)) * I_Htot) else @@ -1113,12 +1302,11 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! 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] + w2avg = w2avg + 0.5*(mode_struct(K)**2+mode_struct(K+1)**2)*Hc(k) ! [H L4 T-4] enddo renorm = sqrt(htot(i)*a_int/w2avg) ! [T2 L-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 @@ -1131,7 +1319,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! 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) + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) enddo ! boundary condition for derivative is no-gradient @@ -1163,18 +1351,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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), & + call interpolate_column(kc, Hc(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), & + call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & nz, h(i,j,:), modal_structure_fder(:), & GV%H_subroundoff, GV%H_subroundoff) @@ -1313,7 +1495,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! 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) + mode_struct_fder(k) = (mode_struct(k) - mode_struct(k+1)) / dzc(k) enddo ! boundary condition for 1st derivative is no-gradient @@ -1345,18 +1527,12 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s 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), & + call interpolate_column(kc, Hc(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), & + call remapping_core_h(CS%remapping_CS, kc, Hc(1:kc), mode_struct_fder(1:kc), & nz, h(i,j,:), modal_structure_fder(:), & GV%H_subroundoff, GV%H_subroundoff) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 83910e6690..7d1ec38fba 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -110,11 +110,11 @@ module MOM_internal_tides 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] + !! for each mode [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: int_U2 !< Vertical integral of u_struct squared, - !! for each mode [Z-1 ~> m-1] + !! for each mode [H Z-2 ~> m-1 or kg m-4] real, allocatable, dimension(:,:,:) :: int_N2w2 !< Depth-integrated Brunt Vaissalla freqency times - !! vertical profile squared, for each mode [Z T-2 ~> m s-2] + !! vertical profile squared, for each mode [H T-2 ~> m s-2 or kg m-2 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. @@ -529,9 +529,9 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! 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) + & + KE_term = 0.25*GV%H_to_RZ*( ((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 ) + PE_term = 0.25*GV%H_to_RZ*( 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) ) @@ -2820,7 +2820,6 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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') @@ -2971,19 +2970,19 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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) + diag%axesT1, Time, var_descript, 'm', conversion=GV%H_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) + diag%axesT1, Time, var_descript, 'm-1', conversion=US%m_to_Z*GV%H_to_Z) 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) + diag%axesT1, Time, var_descript, 'm s-2', conversion=GV%H_to_m*US%s_to_T**2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) enddo From 2047676a38e1caa9e99b07837395714446fc7fc1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 28 Sep 2023 08:00:41 -0400 Subject: [PATCH 430/629] +*Add halo_size argument to wave_speeds Replace the optional full_halos logical argument to wave_speed and wave_speeds with an optional halo_size integer argument, following the pattern used elsewhere in the MOM6 code, with a similar change to itidal_lowmode_loss. This halo_size argument is used in the call to thickness_to_dz in wave_speeds, and the call to wave_speeds in propagate_int_tides was modified accordingly. In addition, the loop bounds in the MOM_internal_tides code were modified to avoid excessive calculations over the full data domain, some of which would use uninitialized variables. Also modified the logic determining the value of diabatic_halo as returned by extract_diabatic_member to account for the wider halos that are needed when the internal tide code is used. This commit changes the interfaces publicly visible routines and it changes answers in cases when the internal_tides are used by doing calculations of the wave speeds in halo points that are used in that code. --- src/diagnostics/MOM_wave_speed.F90 | 38 +++--- .../lateral/MOM_internal_tides.F90 | 114 ++++++++++-------- .../vertical/MOM_diabatic_driver.F90 | 8 +- 3 files changed, 89 insertions(+), 71 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 92c76001c7..59dbfc184e 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -63,7 +63,7 @@ module MOM_wave_speed contains !> Calculates the wave speed of the first baroclinic mode. -subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_N2_column_fraction, & +subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N2_column_fraction, & mono_N2_depth, modal_structure) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure @@ -73,8 +73,8 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables real, dimension(SZI_(G),SZJ_(G)), intent(out) :: cg1 !< First mode internal wave speed [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 computational domain. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds logical, optional, intent(in) :: use_ebt_mode !< If true, use the equivalent !! barotropic mode instead of the first baroclinic mode. real, optional, intent(in) :: mono_N2_column_fraction !< The lower fraction @@ -158,7 +158,7 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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. integer :: kc ! The number of layers in the column after merging - integer :: i, j, k, k2, itt, is, ie, js, je, nz + integer :: i, j, k, k2, itt, is, ie, js, je, nz, halo real :: hw ! The mean of the adjacent layer thicknesses [H ~> m or kg m-2] real :: sum_hc ! The sum of the layer thicknesses [H ~> m or kg m-2] real :: gp ! A limited local copy of gprime [L2 H-1 T-2 ~> m s-2 or m4 s-1 kg-1] @@ -173,14 +173,15 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, full_halos, use_ebt_mode, mono_ 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] - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speed: "// & "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 + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif l_use_ebt_mode = CS%use_ebt_mode if (present(use_ebt_mode)) l_use_ebt_mode = use_ebt_mode @@ -747,7 +748,7 @@ end subroutine tdma6 !> Calculates the wave speeds for the first few barolinic modes. 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) + int_U2, int_N2w2, halo_size) 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 @@ -772,8 +773,8 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s real, dimension(SZI_(G),SZJ_(G),nmodes), intent(out) :: int_N2w2 !< depth-integrated buoyancy frequency !! times vertical velocity profile !! squared [H T-2 ~> m s-2 or kg m-2 s-2] - logical, optional, intent(in) :: full_halos !< If true, do the calculation - !! over the entire data domain. + integer, optional, intent(in) :: halo_size !< Width of halo within which to + !! calculate wave speeds ! Local variables real, dimension(SZK_(GV)+1) :: & @@ -872,7 +873,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s logical :: sub_rootfound ! if true, subdivision has located root 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 + integer :: i, j, k, k2, itt, is, ie, js, je, nz, iint, m, halo 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 @@ -889,14 +890,15 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s real, parameter :: a_int = 0.5 ! Integral total for normalization [nondim] real :: renorm ! Normalization factor [T2 L-2 ~> s2 m-2] - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ; halo = 0 if (.not. CS%initialized) call MOM_error(FATAL, "MOM_wave_speed / wave_speeds: "// & "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 + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 H_to_pres = GV%H_to_RZ * GV%g_Earth @@ -940,7 +942,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s do i=is,ie ; htot(i) = 0.0 ; enddo do k=1,nz ; do i=is,ie ; htot(i) = htot(i) + h(i,j,k) ; enddo ; enddo - call thickness_to_dz(h, tv, dz_2d, j, G, GV) + call thickness_to_dz(h, tv, dz_2d, j, G, GV, halo_size=halo) do i=is,ie hmin(i) = htot(i)*min_h_frac ; kf(i) = 1 ; H_here(i) = 0.0 ; dz_here(i) = 0.0 @@ -1097,7 +1099,7 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s ! Merge layers to eliminate convective instabilities or exceedingly ! small reduced gravities. Merging layers reduces the estimated wave speed by ! (rho(2)-rho(1))*h(1)*h(2) / H_tot. - if (use_EOS .and. (.not.nonBous)) then + if (use_EOS) then kc = 1 Hc(1) = Hf(1,i) ; dzc(1) = dzf(1,i) ; Tc(1) = Tf(1,i) ; Sc(1) = Sf(1,i) do k=2,kf(i) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 7d1ec38fba..172d2459d5 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -259,6 +259,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, real :: En_initial, Delta_E_check ! Energies for debugging [R Z3 T-2 ~> J m-2] real :: TKE_Froude_loss_check, TKE_Froude_loss_tot ! Energy losses for debugging [R Z3 T-3 ~> W m-2] character(len=160) :: mesg ! The text of an error message + integer :: En_halo_ij_stencil ! The halo size needed for energy advection integer :: a, m, fr, i, j, k, is, ie, js, je, isd, ied, jsd, jed, nAngle integer :: id_g, jd_g ! global (decomp-invar) indices (for debugging) type(group_pass_type), save :: pass_test, pass_En @@ -314,13 +315,16 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, 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.) + Nb, CS%int_w2, CS%int_U2, CS%int_N2w2, halo_size=2) + ! The value of halo_size above would have to be larger if there were + ! not a halo update between the calls to propagate_x and propagate_y. + ! It can be 1 point smaller if teleport is not used. 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). - !do m=1,CS%nMode ; do j=jsd,jed ; do i=isd,ied + !do m=1,CS%nMode ; do j=js-2,je+2 ; do i=is-2,ie+2 ! cn(i,j,m) = cn(i,j,1) / real(m) !enddo ; enddo ; enddo @@ -362,6 +366,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%nAngle, CS%use_PPMang) enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -381,8 +386,13 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call complete_group_pass(pass_test, G%domain) + ! Set the halo size to work on, using similar logic to that used in propagate. This may need + ! to be adjusted depending on the advection scheme and whether teleport is used. + if (CS%upwind_1st) then ; En_halo_ij_stencil = 2 + else ; En_halo_ij_stencil = 3 ; endif + ! Rotate points in the halos as necessary. - call correct_halo_rotation(CS%En, test, G, CS%nAngle) + call correct_halo_rotation(CS%En, test, G, CS%nAngle, halo=En_halo_ij_stencil) ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq @@ -414,6 +424,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, call refract(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), 0.5*dt, & G, US, CS%NAngle, CS%use_PPMang) enddo ; enddo + ! A this point, CS%En is only valid on the computational domain. ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -421,7 +432,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, if (CS%En(i,j,a,fr,m)<0.0) then id_g = i + G%idg_offset ; jd_g = j + G%jdg_offset ! for debugging write(mesg,*) 'After second refraction: En<0.0 at ig=', id_g, ', jg=', jd_g, & - 'En=',CS%En(i,j,a,fr,m) + 'En=', CS%En(i,j,a,fr,m) call MOM_error(WARNING, "propagate_int_tide: "//trim(mesg)) CS%En(i,j,a,fr,m) = 0.0 ! call MOM_error(FATAL, "propagate_int_tide: stopped due to negative energy.") @@ -436,7 +447,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, tot_En(:,:) = 0.0 tot_En_mode(:,:,:,:) = 0.0 do m=1,CS%nMode ; do fr=1,CS%Nfreq - do j=jsd,jed ; do i=isd,ied ; do a=1,CS%nAngle + do j=js,je ; do i=is,ie ; do a=1,CS%nAngle tot_En(i,j) = tot_En(i,j) + CS%En(i,j,a,fr,m) tot_En_mode(i,j,fr,m) = tot_En_mode(i,j,fr,m) + CS%En(i,j,a,fr,m) enddo ; enddo ; enddo @@ -445,7 +456,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to misc. processes (background leakage)------ if (CS%apply_background_drag) then - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_leak_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * CS%decay_rate ! loss rate [R Z3 T-3 ~> W m-2] @@ -468,25 +479,25 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then - do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo - do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie ; htot(i,j) = 0.0 ; enddo ; enddo + do k=1,GV%ke ; do j=js,je ; do i=is,ie htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo if (GV%Boussinesq) then ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here enddo ; enddo else - do j=jsd,jed ; do i=isd,ied + do j=js,je ; do i=is,ie I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) enddo ; enddo endif - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate @@ -515,7 +526,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, do m=1,CS%nMode ; do fr=1,CS%Nfreq ! compute near-bottom and max horizontal baroclinic velocity values at each point - 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 wavenumber magnitude @@ -557,7 +568,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, if (CS%apply_wave_drag) then ! Calculate loss rate and apply loss over the time step call itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, CS%En, CS%TKE_itidal_loss_fixed, & - CS%TKE_itidal_loss, dt, full_halos=.false.) + CS%TKE_itidal_loss, dt, halo_size=0) endif ! Check for En<0 - for debugging, delete later do m=1,CS%nMode ; do fr=1,CS%Nfreq ; do a=1,CS%nAngle @@ -644,7 +655,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! loss from residual of reflection/transmission coefficients if (CS%apply_residual_drag) then - do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=jsd,jed ; do i=isd,ied + do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! implicit form !CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * CS%TKE_residual_loss(i,j,a,fr,m) / & ! (CS%En(i,j,a,fr,m) + en_subRO)) @@ -863,7 +874,7 @@ end subroutine sum_En !> Calculates the energy lost from the propagating internal tide due to !! scattering over small-scale roughness along the lines of Jayne & St. Laurent (2001). -subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, full_halos) +subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixed, TKE_loss, dt, 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 @@ -884,10 +895,9 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe intent(out) :: TKE_loss !< Energy loss rate [R Z3 T-3 ~> W m-2] !! (q*rho*kappa*h^2*N*U^2). real, intent(in) :: dt !< Time increment [T ~> s]. - logical,optional, intent(in) :: full_halos !< If true, do the calculation over the - !! entire computational domain. + integer, optional, intent(in) :: halo_size !< The halo size over which to do the calculations ! Local variables - integer :: j,i,m,fr,a, is, ie, js, je + integer :: j, i, m, fr, a, is, ie, js, je, halo real :: En_tot ! energy for a given mode, frequency, and point summed over angles [R Z3 T-2 ~> J m-2] real :: TKE_loss_tot ! dissipation for a given mode, frequency, and point summed over angles [R Z3 T-3 ~> W m-2] real :: frac_per_sector ! fraction of energy in each wedge [nondim] @@ -901,9 +911,10 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe q_itides = CS%q_itides En_negl = 1e-30*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**2 - if (present(full_halos)) then ; if (full_halos) then - is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed - endif ; endif + if (present(halo_size)) then + halo = halo_size + is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo + endif do j=js,je ; do i=is,ie ; do m=1,CS%nMode ; do fr=1,CS%nFreq @@ -931,7 +942,9 @@ subroutine itidal_lowmode_loss(G, GV, US, CS, Nb, Rho_bot, Ub, En, TKE_loss_fixe enddo else ! no loss if no energy - TKE_loss(i,j,:,fr,m) = 0.0 + do a=1,CS%nAngle + TKE_loss(i,j,a,fr,m) = 0.0 + enddo endif ! Update energy remaining (this is the old explicit calc) @@ -2099,7 +2112,7 @@ end subroutine teleport !> Rotates points in the halos where required to accommodate !! changes in grid orientation, such as at the tripolar fold. -subroutine correct_halo_rotation(En, test, G, NAngle) +subroutine correct_halo_rotation(En, test, G, NAngle, halo) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(:,:,:,:,:), intent(inout) :: En !< The internal gravity wave energy density as a !! function of space, angular orientation, frequency, @@ -2110,18 +2123,19 @@ subroutine correct_halo_rotation(En, test, G, NAngle) !! wave energies in the halo region to be corrected [nondim]. integer, intent(in) :: NAngle !< The number of wave orientations in the !! discretized wave energy spectrum. + integer, intent(in) :: halo !< The halo size over which to do the calculations ! Local variables real, dimension(G%isd:G%ied,NAngle) :: En2d ! A zonal row of the internal gravity wave energy density ! in a frequency band and mode [R Z3 T-2 ~> J m-2]. integer, dimension(G%isd:G%ied) :: a_shift integer :: i_first, i_last, a_new - integer :: a, i, j, isd, ied, jsd, jed, m, fr + integer :: a, i, j, ish, ieh, jsh, jeh, m, fr character(len=160) :: mesg ! The text of an error message - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + ish = G%isc-halo ; ieh = G%iec+halo ; jsh = G%jsc-halo ; jeh = G%jec+halo - do j=jsd,jed - i_first = ied+1 ; i_last = isd-1 - do i=isd,ied + do j=jsh,jeh + i_first = ieh+1 ; i_last = ish-1 + do i=ish,ieh a_shift(i) = 0 if (test(i,j,1) /= 1.0) then if (i 0.0) then - CS%refl_pref_logical(i,j) = .true. - endif - enddo - enddo + do j=jsd,jed ; do i=isd,ied + ! flag cells with partial reflection + if ((CS%refl_angle(i,j) /= CS%nullangle) .and. & + (CS%refl_pref(i,j) < 1.0) .and. (CS%refl_pref(i,j) > 0.0)) then + CS%refl_pref_logical(i,j) = .true. + endif + enddo ; enddo ! Read in double-reflective (ridge) tags from file call get_param(param_file, mdl, "REFL_DBL_FILE", refl_dbl_file, & @@ -2776,11 +2788,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (trim(refl_dbl_file) /= '' ) call MOM_error(FATAL, & "REFL_DBL_FILE: "//trim(filename)//" not found") endif - call pass_var(ridge_temp,G%domain) + call pass_var(ridge_temp, G%domain) allocate(CS%refl_dbl(isd:ied,jsd:jed), source=.false.) - do i=isd,ied ; do j=jsd,jed - if (ridge_temp(i,j) == 1) then; CS%refl_dbl(i,j) = .true. - else ; CS%refl_dbl(i,j) = .false. ; endif + do j=jsd,jed ; do i=isd,ied + CS%refl_dbl(i,j) = (ridge_temp(i,j) == 1) enddo ; enddo ! Read in the transmission coefficient and infer the residual @@ -2797,17 +2808,16 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) "TRANS_FILE: "//trim(filename)//" not found") endif - call pass_var(CS%trans,G%domain) + call pass_var(CS%trans, G%domain) + ! residual allocate(CS%residual(isd:ied,jsd:jed), source=0.0) - do j=jsd,jed - do i=isd,ied - if (CS%refl_pref_logical(i,j)) then - CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) - endif - enddo - enddo - call pass_var(CS%residual,G%domain) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + if (CS%refl_pref_logical(i,j)) then + CS%residual(i,j) = 1. - CS%refl_pref(i,j) - CS%trans(i,j) + endif + enddo ; 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) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 1ccd6a7fb2..5b89c8c726 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -159,6 +159,9 @@ module MOM_diabatic_driver !! evaporated in one time-step [nondim]. integer :: halo_TS_diff = 0 !< The temperature, salinity and thickness halo size that !! must be valid for the diffusivity calculations. + integer :: halo_diabatic = 0 !< The temperature, salinity, specific volume and thickness + !! halo size that must be valid for the diabatic calculations, + !! including vertical mixing and internal tide propagation. logical :: useKPP = .false. !< use CVMix/KPP diffusivities and non-local transport logical :: KPPisPassive !< If true, KPP is in passive mode, not changing answers. logical :: debug !< If true, write verbose checksums for debugging purposes. @@ -2661,7 +2664,7 @@ subroutine extract_diabatic_member(CS, opacity_CSp, optics_CSp, evap_CFL_limit, ! Constants within diabatic_CS if (present(evap_CFL_limit)) evap_CFL_limit = CS%evap_CFL_limit if (present(minimum_forcing_depth)) minimum_forcing_depth = CS%minimum_forcing_depth - if (present(diabatic_halo)) diabatic_halo = CS%halo_TS_diff + if (present(diabatic_halo)) diabatic_halo = CS%halo_diabatic if (present(use_KPP)) use_KPP = CS%use_KPP end subroutine extract_diabatic_member @@ -3513,6 +3516,9 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di halo_TS=CS%halo_TS_diff, double_diffuse=CS%double_diffuse, & physical_OBL_scheme=physical_OBL_scheme) + CS%halo_diabatic = CS%halo_TS_diff + if (CS%use_int_tides) CS%halo_diabatic = max(CS%halo_TS_diff, 2) + if (CS%useKPP .and. (CS%double_diffuse .and. .not.CS%use_CVMix_ddiff)) & call MOM_error(FATAL, 'diabatic_driver_init: DOUBLE_DIFFUSION (old method) does not work '//& 'with KPP. Please set DOUBLE_DIFFUSION=False and USE_CVMIX_DDIFF=True.') From e2bbb08dc2d8827d664bf53def22432168e97e15 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 5 Oct 2023 11:15:24 -0600 Subject: [PATCH 431/629] Set fpmix to false by default --- src/core/MOM_dynamics_split_RK2.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index df28dc0338..0c0fae4f67 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -177,8 +177,7 @@ module MOM_dynamics_split_RK2 !! Euler (1) [nondim]. 0 is often used. logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. - logical :: fpmix !< If true, applies profiles of momentum flux magnitude and direction. - + logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. !>@{ Diagnostic IDs From 6756b4834dfe175aaf8b9d3521a5713c9b04734f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 2 Oct 2023 22:36:08 -0400 Subject: [PATCH 432/629] makedep: Module dependency in nested includes Nested includes are tracked for the purpose of include flags (-I), but not with respect to the content within those files. This patch tracks the module usage statements (`use ...`) inside of any include files and adds them to the Makefile rules of the top-level file. This was implemented within the `nested_inc` function by adding a new argument. --- ac/makedep | 35 +++++++++++++++++++++++++---------- 1 file changed, 25 insertions(+), 10 deletions(-) diff --git a/ac/makedep b/ac/makedep index 502250020b..9da68aa6e6 100755 --- a/ac/makedep +++ b/ac/makedep @@ -150,7 +150,10 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, dep for pair in zip(found_mods, found_objs) for dep in pair ] missing_mods = [m for m in o2uses[o] if m not in all_modules] - incs = nested_inc(o2h[o] + o2inc[o], f2F) + + incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F) + inc_mods = [u for u in inc_used if u not in found_mods and u in all_modules] + incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) incargs = sorted(set(['-I'+os.path.dirname(f) for f in incdeps])) if debug: @@ -167,7 +170,7 @@ def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, print("# program:", ' '.join(o2prg[o]), file=file) if o2mods[o]: print(' '.join(o2mods[o])+':', o, file=file) - print(o + ':', o2F90[o], ' '.join(incdeps+found_deps), file=file) + print(o + ':', o2F90[o], ' '.join(inc_mods + incdeps + found_deps), file=file) print('\t'+fc_rule, ' '.join(incargs), file=file) # Write rule for each object from C @@ -243,10 +246,18 @@ def link_obj(obj, o2uses, mod2o, all_modules): def nested_inc(inc_files, f2F): """List of all files included by "inc_files", either by #include or F90 include.""" + hlst = [] + used_mods = set() + def recur(hfile): if hfile not in f2F.keys(): return - _, _, cpp, inc, _, _ = scan_fortran_file(f2F[hfile]) + + _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile]) + + # Record any module updates inside of include files + used_mods.update(used) + if len(cpp) + len(inc) > 0: for h in cpp+inc: if h not in hlst and h in f2F.keys(): @@ -254,10 +265,11 @@ def nested_inc(inc_files, f2F): hlst.append(h) return return - hlst = [] + for h in inc_files: recur(h) - return inc_files + sorted(set(hlst)) + + return inc_files + sorted(set(hlst)), used_mods def scan_fortran_file(src_file): @@ -268,8 +280,10 @@ def scan_fortran_file(src_file): lines = file.readlines() external_namespace = True + # True if we are in the external (i.e. global) namespace file_has_externals = False + # True if the file contains any external objects for line in lines: match = re_module.match(line.lower()) @@ -321,17 +335,18 @@ def object_file(src_file): def find_files(src_dirs): """Return sorted list of all source files starting from each directory in the list "src_dirs".""" + + # TODO: Make this a user-defined argument + extensions = ('.f90', '.f', '.c', '.inc', '.h', '.fh') + files = [] + for path in src_dirs: if not os.path.isdir(path): raise ValueError("Directory '{}' was not found".format(path)) for p, d, f in os.walk(os.path.normpath(path), followlinks=True): for file in f: - # TODO: use any() - if (file.endswith('.F90') or file.endswith('.f90') - or file.endswith('.f') or file.endswith('.F') - or file.endswith('.h') or file.endswith('.inc') - or file.endswith('.c') or file.endswith('.H')): + if any(file.lower().endswith(ext) for ext in extensions): files.append(p+'/'+file) return sorted(set(files)) From 6d684598e44842cd4c425917afa0edcba046ebac Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 30 Sep 2023 04:12:17 -0400 Subject: [PATCH 433/629] +(*)Non-Boussinesq default for Z_INIT_REMAP_GENERAL Changed the default value of Z_INIT_REMAP_GENERAL to true for fully non-Boussinesq configurations. All existing fully non-Boussinesq cases that use INIT_LAYERS_FROM_Z_FILE = True use this setting, and it is likely that such cases will not work at all if this is false. This change reduces the parameters that need to be changed to go between equivalent Boussinesq and non-Boussinesq configurations to just BOUSSINESQ and SEMI_BOUSSINESQ. The previous default (false) is being retained for any Boussinesq or semi-Bousssinesq cases so that all answers and output are bitwise identical in those cases, but by default some non-Boussinesq solutions change answers, and there are changes to the MOM_parameter_doc files for those non-Boussinesq cases. --- src/initialization/MOM_state_initialization.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index fc676781bc..69d59961ec 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2558,7 +2558,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just call get_param(PF, mdl, "Z_INIT_REMAP_GENERAL", remap_general, & "If false, only initializes to z* coordinates. "//& "If true, allows initialization directly to general coordinates.", & - default=.false., do_not_log=just_read) + default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq) , do_not_log=just_read) call get_param(PF, mdl, "Z_INIT_REMAP_FULL_COLUMN", remap_full_column, & "If false, only reconstructs profiles for valid data points. "//& "If true, inserts vanished layers below the valid data.", & From 13f26036e7849bd435500f00959c45989fb82c38 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 7 Aug 2023 10:27:02 -0400 Subject: [PATCH 434/629] +*Non-Boussinesq revision of lateral_mixing_coeffs This commit revises lateral_mixing_coeffs to work in an appropriate mixture of thickness and vertical extent variables to avoid any dependence on the Boussinesq reference density in non-Boussinesq mode, while retaining the previous answers in Boussinesq mode. This commit adds the new runtime parameter FULL_DEPTH_EADY_GROWTH_RATE to indicate that the denominator of an Eady growth rate calculation should be based on the full depth of the water column, rather than the nominal depth of the bathymetry. The new option is only the default for fully non-Boussinesq cases. A primordial horizontal indexing bug was corrected in the v-direction slope calculation. Because it only applies for very shallow bathymetry, does not appear to impact any existing test cases and went undetected for at least 12 years, it was corrected directly rather than wrapping in another new runtime flag. However, this bug is being retained for now in a comment to help with review and debugging if the answers should change unexpectedly in some yet-to-be identified configuration. Two debugging checksums were added for the output variables calculated in calc_resoln_function. The case of some indices was corrected to follow the MOM6 soft convention using case to indicate the staggering position of variables. The previously incorrect units of one comment were also fixed. There is a new logical element in the VarMix_CS type. To accommodate these changes there are three new internal variables in calc_slope_functions_using_just_e. A total of 9 GV%H_to_Z conversion factors were eliminated with this commit. N2 is no longer calculated separately in calc_slope_functions_using_just_e, but this code is left in a comment as it may be instructive. This commit involved changing the units of one internal variable in calc_QG_Leith_viscosity to use inverse thickness units (as its descriptive comment already indicated). There are already known problems with calc_QG_Leith_viscosity as documented with a fatal error; this will be addressed in a subsequent commit. All answers are bitwise identical in the existing MOM6-examples test suite, but they will change when fully non-Boussinesq, and there is a new entry in some MOM_parameter_doc files. --- .../lateral/MOM_lateral_mixing_coeffs.F90 | 148 ++++++++++++------ 1 file changed, 103 insertions(+), 45 deletions(-) diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 1bf416b00a..4f1dbb89ac 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -10,7 +10,7 @@ module MOM_lateral_mixing_coeffs use MOM_domains, only : create_group_pass, do_group_pass use MOM_domains, only : group_pass_type, pass_var, pass_vector use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_interface_heights, only : find_eta +use MOM_interface_heights, only : find_eta, thickness_to_dz use MOM_isopycnal_slopes, only : calc_isoneutral_slopes use MOM_grid, only : ocean_grid_type use MOM_unit_scaling, only : unit_scale_type @@ -59,16 +59,21 @@ module MOM_lateral_mixing_coeffs !! This parameter is set depending on other parameters. logical :: calculate_depth_fns !< If true, calculate all the depth factors. !! This parameter is set depending on other parameters. - logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rate. + logical :: calculate_Eady_growth_rate !< If true, calculate all the Eady growth rates. !! This parameter is set depending on other parameters. logical :: use_stanley_iso !< If true, use Stanley parameterization in MOM_isopycnal_slopes logical :: use_simpler_Eady_growth_rate !< If true, use a simpler method to calculate the !! Eady growth rate that avoids division by layer thickness. !! This parameter is set depending on other parameters. + logical :: full_depth_Eady_growth_rate !< If true, calculate the Eady growth rate based on an + !! average that includes contributions from sea-level changes + !! in its denominator, rather than just the nominal depth of + !! the bathymetry. This only applies when using the model + !! interface heights as a proxy for isopycnal slopes. real :: cropping_distance !< Distance from surface or bottom to filter out outcropped or !! incropped interfaces for the Eady growth rate calc [Z ~> m] real :: h_min_N2 !< The minimum vertical distance to use in the denominator of the - !! bouyancy frequency used in the slope calculation [Z ~> m] + !! bouyancy frequency used in the slope calculation [H ~> m or kg m-2] real, allocatable :: SN_u(:,:) !< S*N at u-points [T-1 ~> s-1] real, allocatable :: SN_v(:,:) !< S*N at v-points [T-1 ~> s-1] @@ -449,6 +454,12 @@ subroutine calc_resoln_function(h, tv, G, GV, US, CS) if (CS%id_Res_fn > 0) call post_data(CS%id_Res_fn, CS%Res_fn_h, CS%diag) endif + if (CS%debug) then + call hchksum(CS%cg1, "calc_resoln_fn cg1", G%HI, haloshift=1, scale=US%L_T_to_m_s) + call uvchksum("Res_fn_[uv]", CS%Res_fn_u, CS%Res_fn_v, G%HI, haloshift=0, & + scale=1.0, scalar_pair=.true.) + endif + end subroutine calc_resoln_function !> Calculates and stores functions of isopycnal slopes, e.g. Sx, Sy, S*N, mostly used in the Visbeck et al. @@ -684,7 +695,7 @@ subroutine calc_Eady_growth_rate_2D(CS, G, GV, US, h, e, dzu, dzv, dzSxN, dzSyN, integer :: i, j, k, l_seg logical :: crop - dz_neglect = GV%H_subroundoff * GV%H_to_Z + dz_neglect = GV%dZ_subroundoff D_scale = CS%Eady_GR_D_scale if (D_scale<=0.) D_scale = 64.*GV%max_depth ! 0 means use full depth so choose something big r_crp_dist = 1. / max( dz_neglect, CS%cropping_distance ) @@ -818,12 +829,16 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: e !< Interface position [Z ~> m] + ! type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic variables logical, intent(in) :: calculate_slopes !< If true, calculate slopes !! internally otherwise use slopes stored in CS ! Local variables real :: E_x(SZIB_(G),SZJ_(G)) ! X-slope of interface at u points [Z L-1 ~> nondim] (for diagnostics) real :: E_y(SZI_(G),SZJB_(G)) ! Y-slope of interface at v points [Z L-1 ~> nondim] (for diagnostics) + real :: dz_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water columns [Z ~> m] + ! real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! The vertical distance across each layer [Z ~> m] real :: H_cutoff ! Local estimate of a minimum thickness for masking [H ~> m or kg m-2] + real :: dZ_cutoff ! A minimum water column depth for masking [H ~> m or kg m-2] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: S2 ! Interface slope squared [Z2 L-2 ~> nondim] @@ -834,6 +849,8 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop ! the buoyancy frequency squared at u-points [Z T-2 ~> m s-2] real :: S2N2_v_local(SZI_(G),SZJB_(G),SZK_(GV)) ! The depth integral of the slope times ! the buoyancy frequency squared at v-points [Z T-2 ~> m s-2] + logical :: use_dztot ! If true, use the total water column thickness rather than the + ! bathymetric depth for certain calculations. integer :: is, ie, js, je, nz integer :: i, j, k integer :: l_seg @@ -851,6 +868,25 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop h_neglect = GV%H_subroundoff H_cutoff = real(2*nz) * (GV%Angstrom_H + h_neglect) + dZ_cutoff = real(2*nz) * (GV%Angstrom_Z + GV%dz_subroundoff) + + use_dztot = CS%full_depth_Eady_growth_rate ! .or. .not.(GV%Boussinesq or GV%semi_Boussinesq) + + if (use_dztot) then + !$OMP parallel do default(shared) + do j=js-1,je+1 ; do i=is-1,ie+1 + dz_tot(i,j) = e(i,j,1) - e(i,j,nz+1) + enddo ; enddo + ! The following mathematically equivalent expression is more expensive but is less + ! sensitive to roundoff for large Z_ref: + ! call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + ! do j=js-1,je+1 + ! do i=is-1,ie+1 ; dz_tot(i,j) = 0.0 ; enddo + ! do k=1,nz ; do i=is-1,ie+1 + ! dz_tot(i,j) = dz_tot(i,j) + dz(i,j,k) + ! enddo ; enddo + ! enddo + endif ! To set the length scale based on the deformation radius, use wave_speed to ! calculate the first-mode gravity wave speed and then blend the equatorial @@ -864,49 +900,50 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = (e(i+1,j,K)-e(i,j,K))*G%IdxCu(I,j) ! Mask slopes where interface intersects topography - if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo do J=js-1,je ; do i=is-1,ie+1 E_y(i,J) = (e(i,j+1,K)-e(i,j,K))*G%IdyCv(i,J) ! Mask slopes where interface intersects topography - if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. enddo ; enddo else ! This branch is not used. do j=js-1,je+1 ; do I=is-1,ie E_x(I,j) = CS%slope_x(I,j,k) - if (min(h(I,j,k),h(I+1,j,k)) < H_cutoff) E_x(I,j) = 0. + if (min(h(i,j,k),h(i+1,j,k)) < H_cutoff) E_x(I,j) = 0. enddo ; enddo - do j=js-1,je ; do I=is-1,ie+1 + do J=js-1,je ; do i=is-1,ie+1 E_y(i,J) = CS%slope_y(i,J,k) - if (min(h(i,J,k),h(i,J+1,k)) < H_cutoff) E_y(I,j) = 0. + if (min(h(i,j,k),h(i,j+1,k)) < H_cutoff) E_y(i,J) = 0. enddo ; enddo endif ! Calculate N*S*h from this layer and add to the sum do j=js,je ; do I=is-1,ie S2 = ( E_x(I,j)**2 + 0.25*( & - (E_y(I,j)**2+E_y(I+1,j-1)**2) + (E_y(I+1,j)**2+E_y(I,j-1)**2) ) ) + (E_y(i,J)**2+E_y(i+1,J-1)**2) + (E_y(i+1,J)**2+E_y(i,J-1)**2) ) ) + if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) S2 = 0.0 + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i+1,j,k)*h(i+1,j,k-1) / (h(i+1,j,k) + h(i+1,j,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) - if (min(h(i,j,k-1), h(i+1,j,k-1), h(i,j,k), h(i+1,j,k)) < H_cutoff) & - S2 = 0.0 - S2N2_u_local(I,j,k) = (H_geom * GV%H_to_Z) * S2 * N2 + ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + S2N2_u_local(I,j,k) = (H_geom * S2) * (GV%g_prime(k) / max(Hdn, Hup, CS%h_min_N2) ) enddo ; enddo do J=js-1,je ; do i=is,ie S2 = ( E_y(i,J)**2 + 0.25*( & - (E_x(i,J)**2+E_x(i-1,J+1)**2) + (E_x(i,J+1)**2+E_x(i-1,J)**2) ) ) + (E_x(I,j)**2+E_x(I-1,j+1)**2) + (E_x(I,j+1)**2+E_x(I-1,j)**2) ) ) + if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) S2 = 0.0 + Hdn = 2.*h(i,j,k)*h(i,j,k-1) / (h(i,j,k) + h(i,j,k-1) + h_neglect) Hup = 2.*h(i,j+1,k)*h(i,j+1,k-1) / (h(i,j+1,k) + h(i,j+1,k-1) + h_neglect) H_geom = sqrt(Hdn*Hup) - N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) - if (min(h(i,j,k-1), h(i,j+1,k-1), h(i,j,k), h(i,j+1,k)) < H_cutoff) & - S2 = 0.0 - S2N2_v_local(i,J,k) = (H_geom * GV%H_to_Z) * S2 * N2 + ! N2 = GV%g_prime(k) / (GV%H_to_Z * max(Hdn, Hup, CS%h_min_N2)) + S2N2_v_local(i,J,k) = (H_geom * S2) * (GV%g_prime(k) / (max(Hdn, Hup, CS%h_min_N2))) enddo ; enddo enddo ! k + !$OMP parallel do default(shared) do j=js,je do I=is-1,ie ; CS%SN_u(I,j) = 0.0 ; enddo @@ -914,17 +951,22 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop CS%SN_u(I,j) = CS%SN_u(I,j) + S2N2_u_local(I,j,k) enddo ; enddo ! SN above contains S^2*N^2*H, convert to vertical average of S*N - do I=is-1,ie - !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). - !SN_u(I,j) = sqrt( SN_u(I,j) / ( max(G%bathyT(i,j), G%bathyT(i+1,j)) + (G%Z_ref + GV%Angstrom_Z) ) ) - !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then + + if (use_dztot) then + do I=is-1,ie CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & - (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) - else - CS%SN_u(I,j) = 0.0 - endif - enddo + max(dz_tot(i,j), dz_tot(i+1,j), GV%dz_subroundoff) ) + enddo + else + do I=is-1,ie + if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then + CS%SN_u(I,j) = G%OBCmaskCu(I,j) * sqrt( CS%SN_u(I,j) / & + (max(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref) ) + else + CS%SN_u(I,j) = 0.0 + endif + enddo + endif enddo !$OMP parallel do default(shared) do J=js-1,je @@ -932,17 +974,24 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop do k=nz,CS%VarMix_Ktop,-1 ; do i=is,ie CS%SN_v(i,J) = CS%SN_v(i,J) + S2N2_v_local(i,J,k) enddo ; enddo - do i=is,ie - !### Replace G%bathT+G%Z_ref here with (e(i,j,1) - e(i,j,nz+1)). - !SN_v(i,J) = sqrt( SN_v(i,J) / ( max(G%bathyT(i,J), G%bathyT(i,J+1)) + (G%Z_ref + GV%Angstrom_Z) ) ) - !The code below behaves better than the line above. Not sure why? AJA - if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > H_cutoff*GV%H_to_Z ) then + if (use_dztot) then + do i=is,ie CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & - (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) - else - CS%SN_v(i,J) = 0.0 - endif - enddo + max(dz_tot(i,j), dz_tot(i,j+1), GV%dz_subroundoff) ) + enddo + else + do i=is,ie + ! There is a primordial horizontal indexing bug on the following line from the previous + ! versions of the code. This comment should be deleted by the end of 2024. + ! if ( min(G%bathyT(i,j), G%bathyT(i+1,j)) + G%Z_ref > dZ_cutoff ) then + if ( min(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref > dZ_cutoff ) then + CS%SN_v(i,J) = G%OBCmaskCv(i,J) * sqrt( CS%SN_v(i,J) / & + (max(G%bathyT(i,j), G%bathyT(i,j+1)) + G%Z_ref) ) + else + CS%SN_v(i,J) = 0.0 + endif + enddo + endif enddo end subroutine calc_slope_functions_using_just_e @@ -982,7 +1031,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] real :: inv_PI3 ! The inverse of pi cubed [nondim] - integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq,nz + integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB @@ -1002,8 +1051,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**2 ) - Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) - dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * Ih + Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * (GV%Z_to_H * Ih) h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo @@ -1016,8 +1065,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**2 ) - Ih = 1./ ( ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) * GV%H_to_Z ) - dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * Ih + Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * (GV%Z_to_H * Ih) h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo @@ -1143,7 +1192,8 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) CS%calculate_cg1 = .false. CS%calculate_Rd_dx = .false. CS%calculate_res_fns = .false. - CS%use_simpler_Eady_growth_rate = .false. + CS%use_simpler_Eady_growth_rate = .false. + CS%full_depth_Eady_growth_rate = .false. CS%calculate_depth_fns = .false. ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -1298,6 +1348,14 @@ subroutine VarMix_init(Time, G, GV, US, param_file, diag, CS) "The minimum vertical distance to use in the denominator of the "//& "bouyancy frequency used in the slope calculation.", & units="m", default=1.0, scale=GV%m_to_H, do_not_log=CS%use_stored_slopes) + + call get_param(param_file, mdl, "FULL_DEPTH_EADY_GROWTH_RATE", CS%full_depth_Eady_growth_rate, & + "If true, calculate the Eady growth rate based on average slope times "//& + "stratification that includes contributions from sea-level changes "//& + "in its denominator, rather than just the nominal depth of the bathymetry. "//& + "This only applies when using the model interface heights as a proxy for "//& + "isopycnal slopes.", default=.not.(GV%Boussinesq.or.GV%semi_Boussinesq), & + do_not_log=CS%use_stored_slopes) endif endif From a41d0a068117a92a2b430d84a443e4313312d603 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 3 Oct 2023 11:54:47 -0400 Subject: [PATCH 435/629] .testing: Codecov upload uses Github Actions token Anonymous uploads to Codecov are throttled (though it is not clear if this is happening on the Codecov or the GitHub Actions side). Regardless, the advice to get around this throttling seems to be to use the Codecov token associated with the project. The .testing Makefile was modified to use this token if provided, and the GitHub Actions environment now attempts to fetch this from the secrets of the repository. Hopefully individual groups can set this for their own projects, and it will fall back to anonymous upload if unset, but I guess we'll have to see how this plays out. --- .github/workflows/coverage.yml | 4 ++++ .testing/Makefile | 10 +++++++++- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 9922840420..a54fda32a6 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -42,7 +42,11 @@ jobs: - name: Report coverage to CI (PR) if: github.event_name == 'pull_request' run: make report.cov REQUIRE_COVERAGE_UPLOAD=true + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - name: Report coverage to CI (Push) if: github.event_name != 'pull_request' run: make report.cov + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} diff --git a/.testing/Makefile b/.testing/Makefile index d6b06893fe..c2ab27741a 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -571,13 +571,21 @@ endef # Upload coverage reports CODECOV_UPLOADER_URL ?= https://uploader.codecov.io/latest/linux/codecov +CODECOV_TOKEN ?= + +ifdef CODECOV_TOKEN + CODECOV_TOKEN_ARG = -t $(CODECOV_TOKEN) +else + CODECOV_TOKEN_ARG = +endif + codecov: curl -s $(CODECOV_UPLOADER_URL) -o $@ chmod +x codecov .PHONY: report.cov report.cov: run.cov codecov - ./codecov -R build/cov -Z -f "*.gcov" \ + ./codecov $(CODECOV_TOKEN_ARG) -R build/cov -Z -f "*.gcov" \ > build/cov/codecov.out \ 2> build/cov/codecov.err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ From 7cef1e450e9813af9a0ae3d86ae3b3fa58b39a32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 27 Jul 2023 07:39:56 -0400 Subject: [PATCH 436/629] +Rename OBC sea surface height variables Renamed OBC related variables to emphasize that they are sea surface heights, and not sea surface heights or total column mass depending on the Boussinesq approximation. Also changed the units of these renamed variables to [Z ~> m] instead of [H ~> m or kg m-2]. The renamed element of the OBC_segment_type is eta (which is now SSH). The renamed and rescaled elements of the BT_OBC_type are H_[uv] (which are now dZ_[uv]) and eta_outer_[uv] (which are now SSH_outer_[uv]). The internal variables H_[uv] and h_in in apply_velocity_OBCs are now dZ_[uv] and ssh_in. Tidal_elev in update_OBC_segment_data and cff_eta in tidal_bay_set_OBC_data were rescaled but not renamed. There is also a new vertical grid type argument to apply_velocity_OBCs for use in changing the scaling of the SSH variables. A total of 11 GV%Z_to_H or GV%H_to_Z rescaling factors were cancelled out as a result of these changes, while 16 new ones were added, but most of these will in turn be dealt with in a follow-on commit that enables the use of OBCs in non-Boussinesq mode. Because any cases that use Flather open boundary conditions with the non-Boussinesq mode issue a fatal error, all answers are bitwise identical, but there are changes to the names and units of elements in a transparent type. --- src/core/MOM_barotropic.F90 | 93 ++++++++++++++------------- src/core/MOM_open_boundary.F90 | 22 ++++--- src/user/Kelvin_initialization.F90 | 8 +-- src/user/tidal_bay_initialization.F90 | 6 +- 4 files changed, 66 insertions(+), 63 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 4c600d37d2..af2ccaa487 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -71,8 +71,8 @@ module MOM_barotropic type, private :: BT_OBC_type real, allocatable :: Cg_u(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. real, allocatable :: Cg_v(:,:) !< The external wave speed at u-points [L T-1 ~> m s-1]. - real, allocatable :: H_u(:,:) !< The total thickness at the u-points [H ~> m or kg m-2]. - real, allocatable :: H_v(:,:) !< The total thickness at the v-points [H ~> m or kg m-2]. + real, allocatable :: dZ_u(:,:) !< The total vertical column extent at the u-points [Z ~> m]. + real, allocatable :: dZ_v(:,:) !< The total vertical column extent at the v-points [Z ~> m]. real, allocatable :: uhbt(:,:) !< The zonal barotropic thickness fluxes specified !! for open boundary conditions (if any) [H L2 T-1 ~> m3 s-1 or kg s-1]. real, allocatable :: vhbt(:,:) !< The meridional barotropic thickness fluxes specified @@ -81,10 +81,10 @@ module MOM_barotropic !! as set by the open boundary conditions [L T-1 ~> m s-1]. real, allocatable :: vbt_outer(:,:) !< The meridional velocities just outside the domain, !! as set by the open boundary conditions [L T-1 ~> m s-1]. - real, allocatable :: eta_outer_u(:,:) !< The surface height outside of the domain - !! at a u-point with an open boundary condition [H ~> m or kg m-2]. - real, allocatable :: eta_outer_v(:,:) !< The surface height outside of the domain - !! at a v-point with an open boundary condition [H ~> m or kg m-2]. + real, allocatable :: SSH_outer_u(:,:) !< The surface height outside of the domain + !! at a u-point with an open boundary condition [Z ~> m]. + real, allocatable :: SSH_outer_v(:,:) !< The surface height outside of the domain + !! at a v-point with an open boundary condition [Z ~> m]. logical :: apply_u_OBCs !< True if this PE has an open boundary at a u-point. logical :: apply_v_OBCs !< True if this PE has an open boundary at a v-point. !>@{ Index ranges for the open boundary conditions @@ -2338,7 +2338,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP single call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + G, MS, GV, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) !$OMP end single @@ -2908,11 +2908,11 @@ end subroutine set_dtbt !! This subroutine applies the open boundary conditions on barotropic !! velocities and mass transports, as developed by Mehmet Ilicak. subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & - ubt_old, vbt_old, BT_OBC, G, MS, US, halo, dtbt, bebt, & + ubt_old, vbt_old, BT_OBC, G, MS, GV, US, halo, dtbt, bebt, & use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of !! the argument arrays. real, dimension(SZIBW_(MS),SZJW_(MS)), intent(inout) :: ubt !< the zonal barotropic velocity [L T-1 ~> m s-1]. @@ -2935,6 +2935,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, type(BT_OBC_type), intent(in) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: halo !< The extra halo size to use here. real, intent(in) :: dtbt !< The time step [T ~> s]. @@ -2978,14 +2979,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: vel_trans ! The combination of the previous and current velocity ! that does the mass transport [L T-1 ~> m s-1]. - real :: H_u ! The total thickness at the u-point [H ~> m or kg m-2]. - real :: H_v ! The total thickness at the v-point [H ~> m or kg m-2]. + real :: dZ_u ! The total vertical column extent at a u-point [Z ~> m] + real :: dZ_v ! The total vertical column extent at a v-point [Z ~> m] real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] - real :: h_in ! The inflow thickness [H ~> m or kg m-2]. + real :: ssh_in ! The inflow sea surface height [Z ~> m] real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -3004,11 +3005,11 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j)) ! internal - H_u = BT_OBC%H_u(I,j) + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal + dZ_u = BT_OBC%dZ_u(I,j) vel_prev = ubt(I,j) ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/H_u) * (h_in-BT_OBC%eta_outer_u(I,j))) + (BT_OBC%Cg_u(I,j)/dZ_u) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I-1,j) @@ -3018,12 +3019,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - h_in = eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j)) ! external + ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal - H_u = BT_OBC%H_u(I,j) + dZ_u = BT_OBC%dZ_u(I,j) vel_prev = ubt(I,j) ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/H_u) * (BT_OBC%eta_outer_u(I,j)-h_in)) + (BT_OBC%Cg_u(I,j)/dZ_u) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then @@ -3058,12 +3059,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 - h_in = eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1)) ! internal + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal - H_v = BT_OBC%H_v(i,J) + dZ_v = BT_OBC%dZ_v(i,J) vel_prev = vbt(i,J) vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/H_v) * (h_in-BT_OBC%eta_outer_v(i,J))) + (BT_OBC%Cg_v(i,J)/dZ_v) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then @@ -3074,12 +3075,12 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 - h_in = eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2)) ! internal + ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal - H_v = BT_OBC%H_v(i,J) + dZ_v = BT_OBC%dZ_v(i,J) vel_prev = vbt(i,J) vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/H_v) * (BT_OBC%eta_outer_v(i,J)-h_in)) + (BT_OBC%Cg_v(i,J)/dZ_v) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then @@ -3167,21 +3168,21 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (.not. BT_OBC%is_alloced) then allocate(BT_OBC%Cg_u(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%H_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%dZ_u(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%uhbt(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%ubt_outer(isdw-1:iedw,jsdw:jedw), source=0.0) - allocate(BT_OBC%eta_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_u(isdw-1:iedw,jsdw:jedw), source=0.0) allocate(BT_OBC%Cg_v(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%H_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%dZ_v(isdw:iedw,jsdw-1:jedw), source=0.0) allocate(BT_OBC%vhbt(isdw:iedw,jsdw-1:jedw), source=0.0) allocate(BT_OBC%vbt_outer(isdw:iedw,jsdw-1:jedw), source=0.0) - allocate(BT_OBC%eta_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) + allocate(BT_OBC%SSH_outer_v(isdw:iedw,jsdw-1:jedw), source=0.0) BT_OBC%is_alloced = .true. call create_group_pass(BT_OBC%pass_uv, BT_OBC%ubt_outer, BT_OBC%vbt_outer, BT_Domain) call create_group_pass(BT_OBC%pass_uhvh, BT_OBC%uhbt, BT_OBC%vhbt, BT_Domain) - call create_group_pass(BT_OBC%pass_eta_outer, BT_OBC%eta_outer_u, BT_OBC%eta_outer_v, BT_Domain,To_All+Scalar_Pair) - call create_group_pass(BT_OBC%pass_h, BT_OBC%H_u, BT_OBC%H_v, BT_Domain,To_All+Scalar_Pair) + call create_group_pass(BT_OBC%pass_eta_outer, BT_OBC%SSH_outer_u, BT_OBC%SSH_outer_v, BT_Domain,To_All+Scalar_Pair) + call create_group_pass(BT_OBC%pass_h, BT_OBC%dZ_u, BT_OBC%dZ_v, BT_Domain,To_All+Scalar_Pair) call create_group_pass(BT_OBC%pass_cg, BT_OBC%Cg_u, BT_OBC%Cg_v, BT_Domain,To_All+Scalar_Pair) endif @@ -3212,18 +3213,18 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) + BT_OBC%dZ_u(I,j) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = G%bathyT(i+1,j)*GV%Z_to_H + eta(i+1,j) + BT_OBC%dZ_u(I,j) = G%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) endif else if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%H_u(I,j) = eta(i,j) + BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%H_u(I,j) = eta(i+1,j) + BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i+1,j) endif endif - BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_u(i,j)) + BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_u(i,j)) endif endif ; enddo ; enddo if (OBC%Flather_u_BCs_exist_globally) then @@ -3232,7 +3233,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (segment%is_E_or_W .and. segment%Flather) then do j=segment%HI%jsd,segment%HI%jed ; do I=segment%HI%IsdB,segment%HI%IedB BT_OBC%ubt_outer(I,j) = segment%normal_vel_bt(I,j) - BT_OBC%eta_outer_u(I,j) = segment%eta(I,j) + G%Z_ref*GV%Z_to_H + BT_OBC%SSH_outer_u(I,j) = segment%SSH(I,j) + G%Z_ref enddo ; enddo endif enddo @@ -3266,18 +3267,18 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = G%bathyT(i,j)*GV%Z_to_H + eta(i,j) + BT_OBC%dZ_v(i,J) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = G%bathyT(i,j+1)*GV%Z_to_H + eta(i,j+1) + BT_OBC%dZ_v(i,J) = G%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%H_v(i,J) = eta(i,j) + BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%H_v(i,J) = eta(i,j+1) + BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j+1) endif endif - BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * GV%H_to_Z*BT_OBC%H_v(i,J)) + BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) endif endif ; enddo ; enddo if (OBC%Flather_v_BCs_exist_globally) then @@ -3286,7 +3287,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B if (segment%is_N_or_S .and. segment%Flather) then do J=segment%HI%JsdB,segment%HI%JedB ; do i=segment%HI%isd,segment%HI%ied BT_OBC%vbt_outer(i,J) = segment%normal_vel_bt(i,J) - BT_OBC%eta_outer_v(i,J) = segment%eta(i,J) + G%Z_ref*GV%Z_to_H + BT_OBC%SSH_outer_v(i,J) = segment%SSH(i,J) + G%Z_ref enddo ; enddo endif enddo @@ -3309,16 +3310,16 @@ subroutine destroy_BT_OBC(BT_OBC) if (BT_OBC%is_alloced) then deallocate(BT_OBC%Cg_u) - deallocate(BT_OBC%H_u) + deallocate(BT_OBC%dZ_u) deallocate(BT_OBC%uhbt) deallocate(BT_OBC%ubt_outer) - deallocate(BT_OBC%eta_outer_u) + deallocate(BT_OBC%SSH_outer_u) deallocate(BT_OBC%Cg_v) - deallocate(BT_OBC%H_v) + deallocate(BT_OBC%dZ_v) deallocate(BT_OBC%vhbt) deallocate(BT_OBC%vbt_outer) - deallocate(BT_OBC%eta_outer_v) + deallocate(BT_OBC%SSH_outer_v) BT_OBC%is_alloced = .false. endif end subroutine destroy_BT_OBC diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 36a71e3d52..7fb50bc72f 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -200,8 +200,8 @@ module MOM_open_boundary !! segment [H L2 T-1 ~> m3 s-1]. real, allocatable :: normal_vel_bt(:,:) !< The barotropic velocity normal to !! the OB segment [L T-1 ~> m s-1]. - real, allocatable :: eta(:,:) !< The sea-surface elevation along the - !! segment [H ~> m or kg m-2]. + real, allocatable :: SSH(:,:) !< The sea-surface elevation along the + !! segment [Z ~> m]. real, allocatable :: grad_normal(:,:,:) !< The gradient of the normal flow along the !! segment times the grid spacing [L T-1 ~> m s-1], !! with the first index being the corner-point index @@ -3581,7 +3581,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) - allocate(segment%eta(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) if (segment%radiation) & allocate(segment%rx_norm_rad(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%normal_vel(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) @@ -3616,7 +3616,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) - allocate(segment%eta(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) if (segment%radiation) & allocate(segment%ry_norm_rad(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%normal_vel(isd:ied,JsdB:JedB,OBC%ke), source=0.0) @@ -3657,7 +3657,7 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%Cg)) deallocate(segment%Cg) if (allocated(segment%Htot)) deallocate(segment%Htot) if (allocated(segment%h)) deallocate(segment%h) - if (allocated(segment%eta)) deallocate(segment%eta) + if (allocated(segment%SSH)) deallocate(segment%SSH) if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) if (allocated(segment%ry_norm_rad)) deallocate(segment%ry_norm_rad) if (allocated(segment%rx_norm_obl)) deallocate(segment%rx_norm_obl) @@ -3797,7 +3797,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) real :: net_H_int ! Total thickness of the incoming flow in the model [H ~> m or kg m-2] real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1] - real :: tidal_elev ! Interpolated tidal elevation at the OBC points [H ~> m or kg m-2] + real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m] real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] @@ -4376,12 +4376,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * & + GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%eta(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = OBC%ramp_value * (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo else @@ -4390,12 +4391,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * & + GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%eta(i,j) = (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo endif diff --git a/src/user/Kelvin_initialization.F90 b/src/user/Kelvin_initialization.F90 index 88d0cbb482..1fc8a2f564 100644 --- a/src/user/Kelvin_initialization.F90 +++ b/src/user/Kelvin_initialization.F90 @@ -265,7 +265,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! Use inside bathymetry cff = sqrt(GV%g_Earth * depth_tot(i+1,j) ) val2 = mag_SSH * exp(- CS%F_0 * y / cff) - segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) + segment%SSH(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = val2 * (val1 * cff * cosa / depth_tot(i+1,j) ) if (segment%nudged) then do k=1,nz @@ -279,7 +279,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) endif else ! Baroclinic, not rotated yet - segment%eta(I,j) = 0.0 + segment%SSH(I,j) = 0.0 segment%normal_vel_bt(I,j) = 0.0 if (segment%nudged) then do k=1,nz @@ -323,7 +323,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (CS%mode == 0) then cff = sqrt(GV%g_Earth * depth_tot(i,j+1) ) val2 = mag_SSH * exp(- 0.5 * (G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J)) * y / cff) - segment%eta(I,j) = GV%Z_to_H*val2 * cos(omega * time_sec) + segment%SSH(I,j) = val2 * cos(omega * time_sec) segment%normal_vel_bt(I,j) = (val1 * cff * sina / depth_tot(i,j+1) ) * val2 if (segment%nudged) then do k=1,nz @@ -337,7 +337,7 @@ subroutine Kelvin_set_OBC_data(OBC, CS, G, GV, US, h, Time) endif else ! Not rotated yet - segment%eta(i,J) = 0.0 + segment%SSH(i,J) = 0.0 segment%normal_vel_bt(i,J) = 0.0 if (segment%nudged) then do k=1,nz diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 4a20f0e9b3..37a908d3a8 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -74,7 +74,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) ! The following variables are used to set up the transport in the tidal_bay example. real :: time_sec ! Elapsed model time [T ~> s] - real :: cff_eta ! The total column thickness anomalies associated with the inflow [H ~> m or kg m-2] + real :: cff_eta ! The sea surface height anomalies associated with the inflow [Z ~> m] real :: my_flux ! The vlume flux through the face [L2 Z T-1 ~> m3 s-1] real :: total_area ! The total face area of the OBCs [L Z ~> m2] real :: PI ! The ratio of the circumference of a circle to its diameter [nondim] @@ -97,7 +97,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) flux_scale = GV%H_to_m*US%L_to_m time_sec = US%s_to_T*time_type_to_real(Time) - cff_eta = CS%tide_ssh_amp*GV%Z_to_H * sin(2.0*PI*time_sec / CS%tide_period) + cff_eta = CS%tide_ssh_amp * sin(2.0*PI*time_sec / CS%tide_period) my_area = 0.0 my_flux = 0.0 segment => OBC%segment(1) @@ -119,7 +119,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not. segment%on_pe) cycle segment%normal_vel_bt(:,:) = my_flux / (US%m_to_Z*US%m_to_L*total_area) - segment%eta(:,:) = cff_eta + segment%SSH(:,:) = cff_eta enddo ! end segment loop From de385624ba4e8567685d09e9c8cd8142eb93612b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 16:50:17 -0400 Subject: [PATCH 437/629] Read OBC SSH data in Z units Read in open boundary condition SSH and SSHamp segment data directly in rescaled units of [Z ~> m] instead of [H ~> m or kg m-2], which then has to undergo a subsequent conversion. All answers in Boussinesq mode are bitwise identical and non-Boussinesq mode does not work with OBCs yet. --- src/core/MOM_open_boundary.F90 | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7fb50bc72f..86bec85b68 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -1064,8 +1064,8 @@ real function scale_factor_from_name(name, GV, US, Tr_Reg) case ('Vamp') ; scale_factor_from_name = US%m_s_to_L_T case ('DVDX') ; scale_factor_from_name = US%T_to_s case ('DUDY') ; scale_factor_from_name = US%T_to_s - case ('SSH') ; scale_factor_from_name = GV%m_to_H - case ('SSHamp') ; scale_factor_from_name = GV%m_to_H + case ('SSH') ; scale_factor_from_name = US%m_to_Z + case ('SSHamp') ; scale_factor_from_name = US%m_to_Z case default ; scale_factor_from_name = 1.0 end select @@ -4376,13 +4376,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * & - GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%SSH(i,j) = OBC%ramp_value * (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = OBC%ramp_value * (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo else @@ -4391,13 +4390,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) tidal_elev = 0.0 if (OBC%add_tide_constituents) then do c=1,OBC%n_tide_constituents - tidal_elev = tidal_elev + (OBC%tide_fn(c) * & - GV%H_to_Z*segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & + tidal_elev = tidal_elev + (OBC%tide_fn(c) * segment%field(segment%zamp_index)%buffer_dst(i,j,c)) * & cos((time_delta*OBC%tide_frequencies(c) - segment%field(segment%zphase_index)%buffer_dst(i,j,c)) & + (OBC%tide_eq_phases(c) + OBC%tide_un(c))) enddo endif - segment%SSH(i,j) = (GV%H_to_Z*segment%field(m)%buffer_dst(i,j,1) + tidal_elev) + segment%SSH(i,j) = (segment%field(m)%buffer_dst(i,j,1) + tidal_elev) enddo enddo endif From 55c948ad7e9dd3b3c65a79856eee00ae79fe607d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 16:50:44 -0400 Subject: [PATCH 438/629] +Add find_col_avg_SpV Added the new subroutine find_col_avg_SpV to return the column-averaged specific volume based on the coordinate mode and the layer averaged specific volumes that are in tv%SpV_avg. All answers are bitwise identical, but there is a new publicly visible routine. --- src/core/MOM_interface_heights.F90 | 70 +++++++++++++++++++++++++++++- 1 file changed, 69 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 194c39c76d..3dfbc89a03 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -19,7 +19,7 @@ module MOM_interface_heights public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple public calc_derived_thermo -public find_rho_bottom +public find_rho_bottom, find_col_avg_SpV !> Calculates the heights of the free surface or all interfaces from layer thicknesses. interface find_eta @@ -323,6 +323,74 @@ subroutine calc_derived_thermo(tv, h, G, GV, US, halo, debug) end subroutine calc_derived_thermo +!> Determine the column average specific volumes. +subroutine find_col_avg_SpV(h, SpV_avg, tv, 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 !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: SpV_avg !< Column average specific volume [R-1 ~> m3 kg-1] + ! SpV_avg is intent inout to retain excess halo values. + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, optional, intent(in) :: halo_size !< width of halo points on which to work + + ! Local variables + real :: h_tot(SZI_(G)) ! Sum of the layer thicknesses [H ~> m or kg m-3] + real :: SpV_x_h_tot(SZI_(G)) ! Vertical sum of the layer average specific volume times + ! the layer thicknesses [H R-1 ~> m4 kg-1 or m] + real :: I_rho ! The inverse of the Boussiensq reference density [R-1 ~> m3 kg-1] + real :: SpV_lay(SZK_(GV)) ! The inverse of the layer target potential densities [R-1 ~> m3 kg-1] + character(len=128) :: mesg ! A string for error messages + integer i, j, k, is, ie, js, je, nz, halo + + 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 + I_rho = 1.0 / GV%Rho0 + do j=js,je ; do i=is,ie + SpV_avg(i,j) = I_rho + enddo ; enddo + elseif (.not.allocated(tv%SpV_avg)) then + do k=1,nz ; Spv_lay(k) = 1.0 / GV%Rlay(k) ; enddo + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + Spv_lay(k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + else + ! Check that SpV_avg has been set. + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halo)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halo + endif + call MOM_error(FATAL, "find_col_avg_SpV called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do j=js,je + do i=is,ie ; SpV_x_h_tot(i) = 0.0 ; h_tot(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + h_tot(i) = h_tot(i) + max(h(i,j,k), GV%H_subroundoff) + SpV_x_h_tot(i) = SpV_x_h_tot(i) + tv%SpV_avg(i,j,k)*max(h(i,j,k), GV%H_subroundoff) + enddo ; enddo + do i=is,ie ; SpV_avg(i,j) = SpV_x_h_tot(i) / h_tot(i) ; enddo + enddo + endif + +end subroutine find_col_avg_SpV + + !> Determine the in situ density averaged over a specified distance from the bottom, !! calculating it as the inverse of the mass-weighted average specific volume. subroutine find_rho_bottom(h, dz, pres_int, dz_avg, tv, j, G, GV, US, Rho_bot) From 54b46f6215a4a81c0e212885d15a4ec51f868c1c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 28 Jul 2023 16:59:21 -0400 Subject: [PATCH 439/629] +Non-Boussinesq Flather open boundary conditions Get Flather open boundary conditions working properly in non-Boussinesq mode. This includes calculating the column-average specific volume in step_MOM_dyn_split_RK2 and passing it as a new argument to btstep. Inside of btstep, this is copied over into a wide halo array and then passed on to set_up_BT_OBC and apply_velocity_OBCs, where it is used to determine the free surface height or the vertical column extent (in [Z ~> m]) from eta for use in the Flather radiation open boundary conditions. In addition, there are several places in MOM_barotropic related to the open boundary conditions where the usual G%bathyT needed to be replaced with its wide-halo counterpart, CS%bathyT. Also, a test was added for massless OBC columns in apply_velocity_OBCs, which are then assumed to be dry rather than dividing by zero. A fatal error message that is triggered in the case of Flather open boundary conditions in non-Boussiesq mode was removed. With this change, all Boussinesq answers are bitwise identical, but non-Boussinesq cases with Flather open boundary conditions are now working and giving answers that are qualitatively similar to the Boussinesq cases. --- src/core/MOM_barotropic.F90 | 162 +++++++++++++++++++--------- src/core/MOM_dynamics_split_RK2.F90 | 17 ++- 2 files changed, 125 insertions(+), 54 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index af2ccaa487..4a5dba294a 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -306,6 +306,7 @@ module MOM_barotropic type(group_pass_type) :: pass_ubt_Cor !< Handle for a group halo pass type(group_pass_type) :: pass_ubta_uhbta !< Handle for a group halo pass type(group_pass_type) :: pass_e_anom !< Handle for a group halo pass + type(group_pass_type) :: pass_SpV_avg !< Handle for a group halo pass !>@{ Diagnostic IDs integer :: id_PFu_bt = -1, id_PFv_bt = -1, id_Coru_bt = -1, id_Corv_bt = -1 @@ -422,7 +423,7 @@ module MOM_barotropic subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, & eta_PF_in, U_Cor, V_Cor, accel_layer_u, accel_layer_v, & eta_out, uhbtav, vhbtav, G, GV, US, CS, & - visc_rem_u, visc_rem_v, ADp, OBC, BT_cont, eta_PF_start, & + visc_rem_u, visc_rem_v, SpV_avg, ADp, OBC, BT_cont, eta_PF_start, & taux_bot, tauy_bot, uh0, vh0, u_uh0, v_vh0, etaav) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -472,6 +473,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !! viscosity is applied, in the zonal direction [nondim]. !! Visc_rem_u is between 0 (at the bottom) and 1 (far above). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: visc_rem_v !< Ditto for meridional direction [nondim]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: SpV_avg !< The column average specific volume, used + !! in non-Boussinesq OBC calculations [R-1 ~> m3 kg-1] type(accel_diag_ptrs), pointer :: ADp !< Acceleration diagnostic pointers type(ocean_OBC_type), pointer :: OBC !< The open boundary condition structure. type(BT_cont_type), pointer :: BT_cont !< A structure with elements that describe @@ -614,6 +617,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! from the thickness point [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. ! (See Hallberg, J Comp Phys 1997 for a discussion.) eta_src, & ! The source of eta per barotropic timestep [H ~> m or kg m-2]. + SpV_col_avg, & ! The column average specific volume [R-1 ~> m3 kg-1] dyn_coef_eta, & ! The coefficient relating the changes in eta to the ! dynamic surface pressure under rigid ice ! [L2 T-2 H-1 ~> m s-2 or m4 s-2 kg-1]. @@ -773,10 +777,6 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, apply_OBC_open = open_boundary_query(OBC, apply_open_OBC=.true.) apply_OBCs = open_boundary_query(OBC, apply_specified_OBC=.true.) .or. & apply_OBC_flather .or. apply_OBC_open - - if (apply_OBC_flather .and. .not.GV%Boussinesq) call MOM_error(FATAL, & - "btstep: Flather open boundary conditions have not yet been "// & - "implemented for a non-Boussinesq model.") endif num_cycles = 1 @@ -866,6 +866,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, if (apply_OBC_open) & call create_group_pass(CS%pass_eta_ubt, uhbt_int, vhbt_int, CS%BT_Domain) endif + if (apply_OBC_flather .and. .not.GV%Boussinesq) & + call create_group_pass(CS%pass_SpV_avg, SpV_col_avg, CS%BT_domain) call create_group_pass(CS%pass_ubt_Cor, ubt_Cor, vbt_Cor, G%Domain) ! These passes occur at the end of the routine, as data is being readied to @@ -979,6 +981,22 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, Datv(i,J) = 0.0 ; bt_rem_v(i,J) = 0.0 ; vhbt0(i,J) = 0.0 enddo ; enddo + if (apply_OBCs) then + SpV_col_avg(:,:) = 0.0 + if (apply_OBC_flather .and. .not.GV%Boussinesq) then + ! Copy the column average specific volumes into a wide halo array + !$OMP parallel do default(shared) + do j=js,je ; do i=is,ie + SpV_col_avg(i,j) = Spv_avg(i,j) + enddo ; enddo + if (nonblock_setup) then + call start_group_pass(CS%pass_SpV_avg, CS%BT_domain) + else + call do_group_pass(CS%pass_SpV_avg, CS%BT_domain) + endif + endif + endif + if (CS%linear_wave_drag) then !$OMP parallel do default(shared) do j=CS%jsdw,CS%jedw ; do I=CS%isdw-1,CS%iedw @@ -1125,12 +1143,15 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, ! Set up fields related to the open boundary conditions. if (apply_OBCs) then + if (nonblock_setup .and. apply_OBC_flather .and. .not.GV%Boussinesq) & + call complete_group_pass(CS%pass_SpV_avg, CS%BT_domain) + if (CS%TIDAL_SAL_FLATHER) then - call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) else - call set_up_BT_OBC(OBC, eta, CS%BT_OBC, CS%BT_Domain, G, GV, US, MS, ievf-ie, use_BT_cont, & - integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) + call set_up_BT_OBC(OBC, eta, SpV_col_avg, CS%BT_OBC, CS%BT_Domain, G, GV, US, CS, MS, ievf-ie, & + use_BT_cont, integral_BT_cont, dt, Datu, Datv, BTCL_u, BTCL_v) endif endif @@ -2337,8 +2358,8 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, !$OMP single call apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, & - ubt_trans, vbt_trans, eta, ubt_old, vbt_old, CS%BT_OBC, & - G, MS, GV, US, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & + ubt_trans, vbt_trans, eta, SpV_col_avg, ubt_old, vbt_old, CS%BT_OBC, & + G, MS, GV, US, CS, iev-ie, dtbt, bebt, use_BT_cont, integral_BT_cont, & n*dtbt, Datu, Datv, BTCL_u, BTCL_v, uhbt0, vhbt0, & ubt_int_prev, vbt_int_prev, uhbt_int_prev, vhbt_int_prev) !$OMP end single @@ -2907,8 +2928,8 @@ end subroutine set_dtbt !> The following 4 subroutines apply the open boundary conditions. !! This subroutine applies the open boundary conditions on barotropic !! velocities and mass transports, as developed by Mehmet Ilicak. -subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, & - ubt_old, vbt_old, BT_OBC, G, MS, GV, US, halo, dtbt, bebt, & +subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, eta, SpV_avg, & + ubt_old, vbt_old, BT_OBC, G, MS, GV, US, CS, halo, dtbt, bebt, & use_BT_cont, integral_BT_cont, dt_elapsed, Datu, Datv, & BTCL_u, BTCL_v, uhbt0, vhbt0, ubt_int, vbt_int, uhbt_int, vhbt_int) type(ocean_OBC_type), pointer :: OBC !< An associated pointer to an OBC type. @@ -2928,6 +2949,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! transports [L T-1 ~> m s-1]. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] real, dimension(SZIBW_(MS),SZJW_(MS)), intent(in) :: ubt_old !< The starting value of ubt in a barotropic !! step [L T-1 ~> m s-1]. real, dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: vbt_old !< The starting value of vbt in a barotropic @@ -2937,6 +2959,7 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, !! set by set_up_BT_OBC. 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(barotropic_CS), intent(in) :: CS !< Barotropic control structure integer, intent(in) :: halo !< The extra halo size to use here. real, intent(in) :: dtbt !< The time step [T ~> s]. real, intent(in) :: bebt !< The fractional weighting of the future velocity @@ -2979,14 +3002,14 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, real :: vel_prev ! The previous velocity [L T-1 ~> m s-1]. real :: vel_trans ! The combination of the previous and current velocity ! that does the mass transport [L T-1 ~> m s-1]. - real :: dZ_u ! The total vertical column extent at a u-point [Z ~> m] - real :: dZ_v ! The total vertical column extent at a v-point [Z ~> m] real :: cfl ! The CFL number at the point in question [nondim] real :: u_inlet ! The zonal inflow velocity [L T-1 ~> m s-1] real :: v_inlet ! The meridional inflow velocity [L T-1 ~> m s-1] real :: uhbt_int_new ! The updated time-integrated zonal transport [H L2 ~> m3] real :: vhbt_int_new ! The updated time-integrated meridional transport [H L2 ~> m3] real :: ssh_in ! The inflow sea surface height [Z ~> m] + real :: ssh_1 ! The sea surface height in the interior cell adjacent to the an OBC face [Z ~> m] + real :: ssh_2 ! The sea surface height in the next cell inward from the OBC face [Z ~> m] real :: Idtbt ! The inverse of the barotropic time step [T-1 ~> s-1] integer :: i, j, is, ie, js, je is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo @@ -3005,12 +3028,22 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I-1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal - dZ_u = BT_OBC%dZ_u(I,j) - vel_prev = ubt(I,j) - ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/dZ_u) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i-1,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i-1,j) * SpV_avg(i-1,j) - (CS%bathyT(i-1,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (ssh_in-BT_OBC%SSH_outer_u(I,j))) + vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I-1,j) vel_trans = ubt(I,j) @@ -3019,14 +3052,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_u(I,j))%Flather) then cfl = dtbt * BT_OBC%Cg_u(I,j) * G%IdxCu(I,j) ! CFL u_inlet = cfl*ubt_old(I+1,j) + (1.0-cfl)*ubt_old(I,j) ! Valid for cfl<1 - ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal - - dZ_u = BT_OBC%dZ_u(I,j) - vel_prev = ubt(I,j) - ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & - (BT_OBC%Cg_u(I,j)/dZ_u) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i+1,j) + (0.5-cfl)*(eta(i+1,j)-eta(i+2,j))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) - (CS%bathyT(i+1,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i+2,j) * SpV_avg(i+2,j) - (CS%bathyT(i+2,j) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif - vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + if (BT_OBC%dZ_u(I,j) > 0.0) then + vel_prev = ubt(I,j) + ubt(I,j) = 0.5*((u_inlet + BT_OBC%ubt_outer(I,j)) + & + (BT_OBC%Cg_u(I,j)/BT_OBC%dZ_u(I,j)) * (BT_OBC%SSH_outer_u(I,j)-ssh_in)) + vel_trans = (1.0-bebt)*vel_prev + bebt*ubt(I,j) + else ! This point is now dry. + ubt(I,j) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_u(I,j))%gradient) then ubt(I,j) = ubt(I+1,j) vel_trans = ubt(I,j) @@ -3059,14 +3101,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J-1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl<1 - ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal - - dZ_v = BT_OBC%dZ_v(i,J) - vel_prev = vbt(i,J) - vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/dZ_v) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j) + (0.5-cfl)*(eta(i,j)-eta(i,j-1))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) - (CS%bathyT(i,j) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j-1) * SpV_avg(i,j-1) - (CS%bathyT(i,j-1) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (ssh_in-BT_OBC%SSH_outer_v(i,J))) + vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then vbt(i,J) = vbt(i,J-1) vel_trans = vbt(i,J) @@ -3075,14 +3126,23 @@ subroutine apply_velocity_OBCs(OBC, ubt, vbt, uhbt, vhbt, ubt_trans, vbt_trans, if (OBC%segment(OBC%segnum_v(i,J))%Flather) then cfl = dtbt * BT_OBC%Cg_v(i,J) * G%IdyCv(i,J) ! CFL v_inlet = cfl*vbt_old(i,J+1) + (1.0-cfl)*vbt_old(i,J) ! Valid for cfl <1 - ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal - - dZ_v = BT_OBC%dZ_v(i,J) - vel_prev = vbt(i,J) - vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & - (BT_OBC%Cg_v(i,J)/dZ_v) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) + if (GV%Boussinesq) then + ssh_in = GV%H_to_Z*(eta(i,j+1) + (0.5-cfl)*(eta(i,j+1)-eta(i,j+2))) ! internal + else + ssh_1 = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) - (CS%bathyT(i,j+1) + G%Z_ref) + ssh_2 = GV%H_to_RZ * eta(i,j+2) * SpV_avg(i,j+2) - (CS%bathyT(i,j+2) + G%Z_ref) + ssh_in = ssh_1 + (0.5-cfl)*(ssh_1-ssh_2) ! internal + endif - vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + if (BT_OBC%dZ_v(i,J) > 0.0) then + vel_prev = vbt(i,J) + vbt(i,J) = 0.5*((v_inlet + BT_OBC%vbt_outer(i,J)) + & + (BT_OBC%Cg_v(i,J)/BT_OBC%dZ_v(i,J)) * (BT_OBC%SSH_outer_v(i,J)-ssh_in)) + vel_trans = (1.0-bebt)*vel_prev + bebt*vbt(i,J) + else ! This point is now dry + vbt(i,J) = 0.0 + vel_trans = 0.0 + endif elseif (OBC%segment(OBC%segnum_v(i,J))%gradient) then vbt(i,J) = vbt(i,J+1) vel_trans = vbt(i,J) @@ -3109,13 +3169,14 @@ end subroutine apply_velocity_OBCs !> This subroutine sets up the private structure used to apply the open !! boundary conditions, as developed by Mehmet Ilicak. -subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_BT_cont, & +subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS, halo, use_BT_cont, & integral_BT_cont, dt_baroclinic, Datu, Datv, BTCL_u, BTCL_v, dgeo_de) type(ocean_OBC_type), target, intent(inout) :: OBC !< An associated pointer to an OBC type. type(memory_size_type), intent(in) :: MS !< A type that describes the memory sizes of the !! argument arrays. real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: eta !< The barotropic free surface height anomaly or !! column mass anomaly [H ~> m or kg m-2]. + real, dimension(SZIW_(MS),SZJW_(MS)), intent(in) :: SpV_avg !< The column average specific volume [R-1 ~> m3 kg-1] type(BT_OBC_type), intent(inout) :: BT_OBC !< A structure with the private barotropic arrays !! related to the open boundary conditions, !! set by set_up_BT_OBC. @@ -3123,6 +3184,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(barotropic_CS), intent(in) :: CS !< Barotropic control structure integer, intent(in) :: halo !< The extra halo size to use here. logical, intent(in) :: use_BT_cont !< If true, use the BT_cont_types to calculate !! transports. @@ -3141,7 +3203,7 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B type(local_BT_cont_v_type), dimension(SZIW_(MS),SZJBW_(MS)), intent(in) :: BTCL_v !< Structure of information used !! for a dynamic estimate of the face areas at !! v-points. - real, intent(in), optional :: dgeo_de !< The constant of proportionality between + real, optional, intent(in) :: dgeo_de !< The constant of proportionality between !! geopotential and sea surface height [nondim]. ! Local variables real :: I_dt ! The inverse of the time interval of this call [T-1 ~> s-1]. @@ -3213,15 +3275,15 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%dZ_u(I,j) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) + BT_OBC%dZ_u(I,j) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%dZ_u(I,j) = G%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) + BT_OBC%dZ_u(I,j) = CS%bathyT(i+1,j) + GV%H_to_Z*eta(i+1,j) endif else if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i,j) + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) elseif (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_W) then - BT_OBC%dZ_u(I,j) = GV%H_to_Z*eta(i+1,j) + BT_OBC%dZ_u(I,j) = GV%H_to_RZ * eta(i+1,j) * SpV_avg(i+1,j) endif endif BT_OBC%Cg_u(I,j) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_u(i,j)) @@ -3267,9 +3329,9 @@ subroutine set_up_BT_OBC(OBC, eta, BT_OBC, BT_Domain, G, GV, US, MS, halo, use_B else ! This is assuming Flather as only other option if (GV%Boussinesq) then if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%dZ_v(i,J) = G%bathyT(i,j) + GV%H_to_Z*eta(i,j) + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j) + GV%H_to_Z*eta(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%dZ_v(i,J) = G%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) + BT_OBC%dZ_v(i,J) = CS%bathyT(i,j+1) + GV%H_to_Z*eta(i,j+1) endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index ae9e304736..feb0b7e582 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -50,11 +50,11 @@ module MOM_dynamics_split_RK2 use MOM_hor_index, only : hor_index_type use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS use MOM_hor_visc, only : hor_visc_init, hor_visc_end -use MOM_interface_heights, only : find_eta, thickness_to_dz +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_MEKE_types, only : MEKE_type use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds -use MOM_open_boundary, only : open_boundary_zero_normal_flow +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp use MOM_PressureForce, only : PressureForce, PressureForce_CS use MOM_PressureForce, only : PressureForce_init @@ -344,6 +344,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] @@ -596,6 +597,14 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (.not.BT_cont_BT_thick) & call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif call cpu_clock_end(id_clock_btcalc) if (G%nonblocking_updates) & @@ -625,7 +634,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! The CS%ADp argument here stores the weights for certain integrated diagnostics. call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & - CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, CS%ADp, CS%OBC, CS%BT_cont, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) if (showCallTree) call callTree_leave("btstep()") call cpu_clock_end(id_clock_btstep) @@ -847,7 +856,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! This is the corrector step call to btstep. call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & - CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, CS%ADp, CS%OBC, CS%BT_cont, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) if (CS%id_deta_dt>0) then do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo From 06bc0018c2efca502eaf7e34fa1d2d4564c9c2fd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 29 Jul 2023 05:31:31 -0400 Subject: [PATCH 440/629] +Add segment%dZtot Add the new element dZtot to the OBC_segment_type to hold the total vertical extent of the water column, and use thickness_to_dz in update_OBC_segment_data to convert the layer thicknesses to the vertical layer extents used to set dZtot. This change leads to the cancellation of 6 unit conversion factors. All answers are bitwise identical in Boussinesq mode, but they will change and become less dependent on the Boussinesq reference density in some Boussinesq cases with certain types of open boundary condition. --- src/core/MOM_open_boundary.F90 | 31 +++++++++++++++++++++++-------- 1 file changed, 23 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 86bec85b68..d32e947da1 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -14,6 +14,7 @@ module MOM_open_boundary use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type, hor_index_type use MOM_dyn_horgrid, only : dyn_horgrid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : slasher, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc use MOM_restart, only : register_restart_field, register_restart_pair @@ -189,6 +190,7 @@ module MOM_open_boundary real, allocatable :: Cg(:,:) !< The external gravity wave speed [L T-1 ~> m s-1] !! at OBC-points. real, allocatable :: Htot(:,:) !< The total column thickness [H ~> m or kg m-2] at OBC-points. + real, allocatable :: dZtot(:,:) !< The total column vertical extent [Z ~> m] at OBC-points. real, allocatable :: h(:,:,:) !< The cell thickness [H ~> m or kg m-2] at OBC-points. real, allocatable :: normal_vel(:,:,:) !< The layer velocity normal to the OB !! segment [L T-1 ~> m s-1]. @@ -352,7 +354,7 @@ module MOM_open_boundary real, allocatable :: tres_y(:,:,:,:) !< Array storage of tracer reservoirs for restarts, in unscaled units [conc] logical :: debug !< If true, write verbose checksums for debugging purposes. real :: silly_h !< A silly value of thickness outside of the domain that can be used to test - !! the independence of the OBCs to this external data [H ~> m or kg m-2]. + !! the independence of the OBCs to this external data [Z ~> m]. real :: silly_u !< A silly value of velocity outside of the domain that can be used to test !! the independence of the OBCs to this external data [L T-1 ~> m s-1]. logical :: ramp = .false. !< If True, ramp from zero to the external values for SSH. @@ -3580,6 +3582,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) ! If these are just Flather, change update_OBC_segment_data accordingly allocate(segment%Cg(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%Htot(IsdB:IedB,jsd:jed), source=0.0) + allocate(segment%dZtot(IsdB:IedB,jsd:jed), source=0.0) allocate(segment%h(IsdB:IedB,jsd:jed,OBC%ke), source=0.0) allocate(segment%SSH(IsdB:IedB,jsd:jed), source=0.0) if (segment%radiation) & @@ -3615,6 +3618,7 @@ subroutine allocate_OBC_segment_data(OBC, segment) ! If these are just Flather, change update_OBC_segment_data accordingly allocate(segment%Cg(isd:ied,JsdB:JedB), source=0.0) allocate(segment%Htot(isd:ied,JsdB:JedB), source=0.0) + allocate(segment%dZtot(isd:ied,JsdB:JedB), source=0.0) allocate(segment%h(isd:ied,JsdB:JedB,OBC%ke), source=0.0) allocate(segment%SSH(isd:ied,JsdB:JedB), source=0.0) if (segment%radiation) & @@ -3656,6 +3660,7 @@ subroutine deallocate_OBC_segment_data(segment) if (allocated(segment%Cg)) deallocate(segment%Cg) if (allocated(segment%Htot)) deallocate(segment%Htot) + if (allocated(segment%dZtot)) deallocate(segment%dZtot) if (allocated(segment%h)) deallocate(segment%h) if (allocated(segment%SSH)) deallocate(segment%SSH) if (allocated(segment%rx_norm_rad)) deallocate(segment%rx_norm_rad) @@ -3738,7 +3743,7 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h) if (.not. associated(OBC)) return - silly_h = GV%Z_to_H*OBC%silly_h + silly_h = GV%Z_to_H * OBC%silly_h do n = 1, OBC%number_of_segments do k = 1, GV%ke @@ -3789,6 +3794,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) integer :: ni_buf, nj_buf ! Number of filled values in tmp_buffer integer :: is_obc, ie_obc, js_obc, je_obc ! segment indices within local domain integer :: ishift, jshift ! offsets for staggered locations + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] real, dimension(:), allocatable :: h_stack ! Thicknesses at corner points [H ~> m or kg m-2] integer :: is_obc2, js_obc2 @@ -3822,6 +3828,11 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 endif + if (OBC%number_of_segments >= 1) then + call thickness_to_dz(h, tv, dz, G, GV, US) + call pass_var(dz, G%Domain) + endif + do n = 1, OBC%number_of_segments segment => OBC%segment(n) @@ -3854,11 +3865,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed segment%Htot(I,j) = 0.0 + segment%dZtot(I,j) = 0.0 do k=1,GV%ke segment%h(I,j,k) = h(i+ishift,j,k) segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) + segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) enddo - segment%Cg(I,j) = sqrt(GV%g_prime(1)*segment%Htot(I,j)*GV%H_to_Z) + segment%Cg(I,j) = sqrt(GV%g_prime(1) * segment%dZtot(I,j)) enddo else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) @@ -3866,11 +3879,13 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied segment%Htot(i,J) = 0.0 + segment%dZtot(i,J) = 0.0 do k=1,GV%ke segment%h(i,J,k) = h(i,j+jshift,k) segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) + segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) enddo - segment%Cg(i,J) = sqrt(GV%g_prime(1)*segment%Htot(i,J)*GV%H_to_Z) + segment%Cg(i,J) = sqrt(GV%g_prime(1) * segment%dZtot(i,J)) enddo endif @@ -5623,8 +5638,8 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope do k=nz+1,1,-1 - if (-eta(i,j,k) > segment%Htot(i,j)*GV%H_to_Z + hTolerance) then - eta(i,j,k) = -segment%Htot(i,j)*GV%H_to_Z + if (-eta(i,j,k) > segment%dZtot(i,j) + hTolerance) then + eta(i,j,k) = -segment%dZtot(i,j) contractions = contractions + 1 endif enddo @@ -5642,10 +5657,10 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! The whole column is dilated to accommodate deeper topography than ! the bathymetry would indicate. - if (-eta(i,j,nz+1) < (segment%Htot(i,j) * GV%H_to_Z) - hTolerance) then + if (-eta(i,j,nz+1) < segment%dZtot(i,j) - hTolerance) then dilations = dilations + 1 ! expand bottom-most cell only - eta(i,j,nz+1) = -(segment%Htot(i,j) * GV%H_to_Z) + eta(i,j,nz+1) = -segment%dZtot(i,j) segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo From e2deaecba3adc823dfca50f1edd2cb0c4e95652c Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Thu, 5 Oct 2023 11:32:15 -0400 Subject: [PATCH 441/629] *Patches for nonBous_OBCs to prevent blocking This adds logical tests to determine the global OBC data update patterns to allow for halo updates related to these updates without having the model hang up with inconsistently blocked message passing calls. This commit corrects a bug with some test cases that was introduced with the halo update after the call to thicknesses_to_dz in update_OBC_segment_data two commits previously. --- src/core/MOM_boundary_update.F90 | 2 +- src/core/MOM_open_boundary.F90 | 18 ++++++++++++++++-- .../MOM_state_initialization.F90 | 5 ++++- 3 files changed, 21 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_boundary_update.F90 b/src/core/MOM_boundary_update.F90 index 5a098cdf84..75f69dc779 100644 --- a/src/core/MOM_boundary_update.F90 +++ b/src/core/MOM_boundary_update.F90 @@ -156,7 +156,7 @@ subroutine update_OBC_data(OBC, G, GV, US, tv, h, CS, Time) call shelfwave_set_OBC_data(OBC, CS%shelfwave_OBC_CSp, G, GV, US, h, Time) if (CS%use_dyed_channel) & call dyed_channel_update_flow(OBC, CS%dyed_channel_OBC_CSp, G, GV, US, Time) - if (OBC%needs_IO_for_data .or. OBC%add_tide_constituents) & + if (OBC%any_needs_IO_for_data .or. OBC%add_tide_constituents) & call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) end subroutine update_OBC_data diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index d32e947da1..896a677b02 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -278,7 +278,9 @@ module MOM_open_boundary logical :: update_OBC = .false. !< Is OBC data time-dependent logical :: update_OBC_seg_data = .false. !< Is it the time for OBC segment data update for fields that !! require less frequent update - logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs + logical :: needs_IO_for_data = .false. !< Is any i/o needed for OBCs on the current PE + logical :: any_needs_IO_for_data = .false. !< Is any i/o needed for OBCs globally + logical :: some_need_no_IO_for_data = .false. !< Are there any PEs with OBCs that do not need i/o. logical :: zero_vorticity = .false. !< If True, sets relative vorticity to zero on open boundaries. logical :: freeslip_vorticity = .false. !< If True, sets normal gradient of tangential velocity to zero !! in the relative vorticity on open boundaries. @@ -736,6 +738,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) integer, dimension(1) :: single_pelist type(external_tracers_segments_props), pointer :: obgc_segments_props_list =>NULL() !will be able to dynamically switch between sub-sampling refined grid data or model grid + integer :: IO_needs(3) ! Sums to determine global OBC data use and update patterns. is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1045,6 +1048,15 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) call Set_PElist(saved_pelist) + ! Determine global IO data requirement patterns. + IO_needs(1) = 0 ; if (OBC%needs_IO_for_data) IO_needs(1) = 1 + IO_needs(2) = 0 ; if (OBC%update_OBC) IO_needs(2) = 1 + IO_needs(3) = 0 ; if (.not.OBC%needs_IO_for_data) IO_needs(3) = 1 + call sum_across_PES(IO_needs, 3) + OBC%any_needs_IO_for_data = (IO_needs(1) > 0) + OBC%update_OBC = (IO_needs(2) > 0) + OBC%some_need_no_IO_for_data = (IO_needs(3) > 0) + end subroutine initialize_segment_data !> Return an appropriate dimensional scaling factor for input data based on an OBC segment data @@ -1909,7 +1921,7 @@ logical function open_boundary_query(OBC, apply_open_OBC, apply_specified_OBC, a OBC%Flather_v_BCs_exist_globally if (present(apply_nudged_OBC)) open_boundary_query = OBC%nudged_u_BCs_exist_globally .or. & OBC%nudged_v_BCs_exist_globally - if (present(needs_ext_seg_data)) open_boundary_query = OBC%needs_IO_for_data + if (present(needs_ext_seg_data)) open_boundary_query = OBC%any_needs_IO_for_data end function open_boundary_query @@ -5755,6 +5767,8 @@ subroutine rotate_OBC_config(OBC_in, G_in, OBC, G, turns) OBC%brushcutter_mode = OBC_in%brushcutter_mode OBC%update_OBC = OBC_in%update_OBC OBC%needs_IO_for_data = OBC_in%needs_IO_for_data + OBC%any_needs_IO_for_data = OBC_in%any_needs_IO_for_data + OBC%some_need_no_IO_for_data = OBC_in%some_need_no_IO_for_data OBC%ntr = OBC_in%ntr diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 69d59961ec..4bddc0965a 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -18,6 +18,7 @@ module MOM_state_initialization use MOM_get_input, only : directories use MOM_grid, only : ocean_grid_type, isPointInCell use MOM_interface_heights, only : find_eta, dz_to_thickness, dz_to_thickness_simple +use MOM_interface_heights, only : calc_derived_thermo 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 @@ -607,8 +608,10 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & call initialize_segment_data(G, GV, US, OBC, PF) ! call open_boundary_config(G, US, PF, OBC) ! Call this once to fill boundary arrays from fixed values - if (.not. OBC%needs_IO_for_data) & + if (OBC%some_need_no_IO_for_data) then + call calc_derived_thermo(tv, h, G, GV, US) call update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) + endif call get_param(PF, mdl, "OBC_USER_CONFIG", config, & "A string that sets how the user code is invoked to set open boundary data: \n"//& From 3650339895f4da08394d0730be9c907abfe3c76a Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Sat, 7 Oct 2023 08:13:19 -0400 Subject: [PATCH 442/629] New treatment of ice shelf boundaries (#467) Previously, ice-shelf Dirichlet boundary conditions only allowed u-velocity and v-velocity to be set to the same value (which is enforced by setting the value of parameters u_face_mask or v_face_mask to 3). This functionality is retained here, but now setting u_face_mask or v_face_mask to 5 enforces a Dirichlet boundary for u-velocity only along the respective cell face. Similarly, setting u_face_mask or v_face_mask to 6 enforces the Dirichlet boundary for v-velocity only along the respective cell face. This functionality is required for most ice-sheet modeling configurations, e.g. the idealized MISMIP+ configuration requires setting v-velocity only to 0 along its lateral boundaries, but with free-slip conditions enforced for u-velocity. Adding this capability required changes throughout the ice-shelf code. Further changes were needed for how driving stress and Neummann conditions at computational boundaries are calculated in subroutine calc_shelf_driving_stress, and calls to subroutine apply_boundary_values were eliminated because they were not justified and caused errors. The new boundary treatment was tested by comparing simulated and analytical solutions for 1-D ice shelf flow with free-slip lateral boundary conditions and positive u_velocity enforced at the western boundary. This required the addition of a new parameter ADVECT_SHELF, which if false (as in the 1-D test case), turns off ice-shelf thickness evolution. By default, ADVECT_SHELF=True. The new boundary treatment was also justified in 2-D by correctly simulating the expected MISMIP+ steady-state. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 199 ++++++++++++--------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 2 +- 2 files changed, 120 insertions(+), 81 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index cefe251edd..98e2f3600b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -54,11 +54,14 @@ module MOM_ice_shelf_dynamics !! not vertices. Will represent boundary conditions on computational boundary !! (or permanent boundary between fast-moving and near-stagnant ice !! FOR NOW: 1=interior bdry, 0=no-flow boundary, 2=stress bdry condition, - !! 3=inhomogeneous Dirichlet boundary, 4=flux boundary: at these faces a flux - !! will be specified which will override velocities; a homogeneous velocity - !! condition will be specified (this seems to give the solver less difficulty) + !! 3=inhomogeneous Dirichlet boundary for u and v, 4=flux boundary: at these + !! faces a flux will be specified which will override velocities; a homogeneous + !! velocity condition will be specified (this seems to give the solver less + !! difficulty) 5=inhomogenous Dirichlet boundary for u only. 6=inhomogenous + !! Dirichlet boundary for v only real, pointer, dimension(:,:) :: v_face_mask => NULL() !< A mask for velocity boundary conditions on the C-grid - !! v-face, with valued defined similarly to u_face_mask. + !! v-face, with valued defined similarly to u_face_mask, but 5 is Dirichlet for v + !! and 6 is Dirichlet for u real, pointer, dimension(:,:) :: u_face_mask_bdry => NULL() !< A duplicate copy of u_face_mask? real, pointer, dimension(:,:) :: v_face_mask_bdry => NULL() !< A duplicate copy of v_face_mask? real, pointer, dimension(:,:) :: u_flux_bdry_val => NULL() !< The ice volume flux per unit face length into the cell @@ -118,6 +121,7 @@ module MOM_ice_shelf_dynamics real :: g_Earth !< The gravitational acceleration [L2 Z-1 T-2 ~> m s-2]. real :: density_ice !< A typical density of ice [R ~> kg m-3]. + logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally !! according to Glen's flow law; is constant (for debugging purposes) !! or using observed strain rates and read from a file @@ -438,6 +442,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "CALVE_TO_MASK", CS%calve_to_mask, & "If true, do not allow an ice shelf where prohibited by a mask.", & default=.false.) + call get_param(param_file, mdl, "ADVECT_SHELF", CS%advect_shelf, & + "If true, advect ice shelf and evolve thickness", & + default=.true.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & "If MODEL, compute ice viscosity internally, if OBS read from a file,"//& "if CONSTANT a constant value (for debugging).", & @@ -491,17 +498,33 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! right hand side have not been set up yet. if (.not. G%symmetric) then do j=G%jsd,G%jed ; do i=G%isd,G%ied - if (((i+G%idg_offset) == (G%domain%nihalo+1)).and.(CS%u_face_mask(I-1,j) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + if ((i+G%idg_offset) == (G%domain%nihalo+1)) then + if (CS%u_face_mask(I-1,j) == 3) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 5) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I-1,J) = CS%u_bdry_val(I-1,J) + elseif (CS%u_face_mask(I-1,j) == 6) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I-1,J) = CS%v_bdry_val(I-1,J) + endif endif - if (((j+G%jdg_offset) == (G%domain%njhalo+1)).and.(CS%v_face_mask(i,J-1) == 3)) then - CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) - CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) - CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) - CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + if ((j+G%jdg_offset) == (G%domain%njhalo+1)) then + if (CS%v_face_mask(i,J-1) == 3) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 5) then + CS%v_shelf(I-1,J-1) = CS%v_bdry_val(I-1,J-1) + CS%v_shelf(I,J-1) = CS%v_bdry_val(I,J-1) + elseif (CS%v_face_mask(i,J-1) == 6) then + CS%u_shelf(I-1,J-1) = CS%u_bdry_val(I-1,J-1) + CS%u_shelf(I,J-1) = CS%u_bdry_val(I,J-1) + endif endif enddo ; enddo endif @@ -702,7 +725,9 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled coupled_GL = .false. if (present(ocean_mass) .and. present(coupled_grounding)) coupled_GL = coupled_grounding ! - call ice_shelf_advect(CS, ISS, G, time_step, Time) + if (CS%advect_shelf) then + call ice_shelf_advect(CS, ISS, G, time_step, Time) + endif CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. @@ -864,8 +889,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i intent(out) :: taudx !< Driving x-stress at q-points [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: taudy !< Driving y-stress at q-points [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: u_bdry_cont ! Boundary u-stress contribution [R L3 Z T-2 ~> kg m s-2] + !real, dimension(SZDIB_(G),SZDJB_(G)) :: v_bdry_cont ! Boundary v-stress contribution [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. @@ -889,7 +914,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i rhoi_rhow = CS%density_ice / CS%density_ocean_avg taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 - u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 + !u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 ! need to make these conditional on GL interpolation @@ -959,8 +984,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 @@ -973,11 +998,13 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + !err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu endif if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + !err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_init) err_init = err_tempv endif enddo ; enddo @@ -1013,10 +1040,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo - u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 + !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 @@ -1032,11 +1059,13 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB if (CS%umask(I,J) == 1) then - err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + !err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) + err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu endif if (CS%vmask(I,J) == 1) then - err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + !err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) + err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_max) err_max = err_tempv endif enddo ; enddo @@ -1138,10 +1167,10 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Zu_old, Zv_old, & ! Previous values of Zu and Zv [L T-1 ~> m s-1] DIAGu, DIAGv, & ! Diagonals with units like Ru/Zu [R L2 Z T-1 ~> kg s-1] RHSu, RHSv, & ! Right hand side of the stress balance [R L3 Z T-2 ~> m kg s-2] - ubd, vbd, & ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] Au, Av, & ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] Du, Dv, & ! Velocity changes [L T-1 ~> m s-1] - sum_vec, sum_vec_2 + sum_vec, sum_vec_2 !, & + !ubd, vbd ! Boundary stress contributions [R L3 Z T-2 ~> kg m s-2] real :: beta_k, dot_p1, resid0, cg_halo real :: alpha_k ! A scaling factor for iterative corrections [nondim] real :: resid_scale ! A scaling factor for redimensionalizing the global residuals [m2 L-2 ~> 1] @@ -1163,7 +1192,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 - Du(:,:) = 0 ; Dv(:,:) = 0 ; ubd(:,:) = 0 ; vbd(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 !; ubd(:,:) = 0 ; vbd(:,:) = 0 dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. @@ -1177,11 +1206,11 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) - call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) + !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) - RHSu(:,:) = taudx(:,:) - ubd(:,:) - RHSv(:,:) = taudy(:,:) - vbd(:,:) + RHSu(:,:) = taudx(:,:) !- ubd(:,:) + RHSv(:,:) = taudy(:,:) !- vbd(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) @@ -1792,6 +1821,7 @@ subroutine calve_to_mask(G, h_shelf, area_shelf_h, hmask, calve_mask) end subroutine calve_to_mask +!> Calculate driving stress using cell-centered bed elevation and ice thickness subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -1817,10 +1847,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! "average" ocean depth -- and is needed to find surface elevation ! (it is assumed that base_ice = bed + OD) - real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S, & ! surface elevation [Z ~> m]. - BASE ! basal elevation of shelf/stream [Z ~> m]. - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m]. real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim] @@ -1851,8 +1878,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) rhoi_rhow = rho/rhow ! prelim - go through and calculate S - ! or is this faster? - BASE(:,:) = -CS%bed_elev(:,:) + OD(:,:) S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) ! check whether the ice is floating or grounded @@ -1867,10 +1892,6 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo call pass_var(S, G%domain) - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) - do j=jscq,jecq ; do i=iscq,iecq - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo do j=jsc-1,jec+1 do i=isc-1,iec+1 @@ -1884,7 +1905,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx - if ((i+i_off) == gisc) then ! at left computational bdry + if ((i+i_off) == gisc) then ! at west computational bdry if (ISS%hmask(i+1,j) == 1) then sx = (S(i+1,j)-S(i,j))/dxh else @@ -1927,7 +1948,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) else sy = 0 endif - elseif ((j+j_off) == gjec) then ! at nprth computational bdry + elseif ((j+j_off) == gjec) then ! at north computational bdry if (ISS%hmask(i,j-1) == 1) then sy = (S(i,j)-S(i,j-1))/dyh else @@ -1956,32 +1977,34 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif ! SW vertex - if (ISS%hmask(I-1,J-1) == 1) then + !if (ISS%hmask(I-1,J-1) == 1) then taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif ! SE vertex - if (ISS%hmask(I,J-1) == 1) then + !if (ISS%hmask(I,J-1) == 1) then taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif ! NW vertex - if (ISS%hmask(I-1,J) == 1) then + !if (ISS%hmask(I-1,J) == 1) then taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif ! NE vertex - if (ISS%hmask(I,J) == 1) then + !if (ISS%hmask(I,J) == 1) then taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - endif + !endif + + !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then neumann_val = (.5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) else neumann_val = (.5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2) endif - - if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. (ISS%hmask(i-1,j) == 0) .OR. (ISS%hmask(i-1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off .ne. gisc))) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -1995,19 +2018,22 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) taudx(I-1,J) = taudx(I-1,J) - .5 * dyh * neumann_val endif - if ((CS%u_face_mask_bdry(I,j) == 2) .OR. (ISS%hmask(i+1,j) == 0) .OR. (ISS%hmask(i+1,j) == 2) ) then + if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off .ne. giec))) then ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif - if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. (ISS%hmask(i,j-1) == 0) .OR. (ISS%hmask(i,j-1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off .ne. gjsc))) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif - if ((CS%v_face_mask_bdry(i,J) == 2) .OR. (ISS%hmask(i,j+1) == 0) .OR. (ISS%hmask(i,j+1) == 2) ) then + if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off .ne. gjec))) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val @@ -2017,9 +2043,9 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) enddo enddo - deallocate(Phi) end subroutine calc_shelf_driving_stress +! Not used? Seems to be only set up to work for a specific test case with u_face_mask==3 subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new_sim) type(ice_shelf_dyn_CS),intent(inout) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. @@ -2385,6 +2411,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi if (CS%umask(Itgt,Jtgt) == 1) then u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) + endif + if (CS%vmask(Itgt,Jtgt) == 1) then v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) endif enddo ; enddo @@ -2481,10 +2509,11 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then ! process this cell if any corners have umask set to non-dirichlet bdry. - ! NOTE: vmask not considered, probably should be if ((CS%umask(I-1,J-1) == 3) .OR. (CS%umask(I,J-1) == 3) .OR. & - (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3)) then + (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3) .OR. & + (CS%vmask(I-1,J-1) == 3) .OR. (CS%vmask(I,J-1) == 3) .OR. & + (CS%vmask(I-1,J) == 3) .OR. (CS%vmask(I,J) == 3)) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2972,7 +3001,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: vmask !< A coded mask indicating the nature of the !! meridional flow at the corner point -real, dimension(SZDIB_(G),SZDJB_(G)), & + real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: u_face_mask !< A coded mask for velocities at the C-grid u-face real, dimension(SZDIB_(G),SZDJB_(G)), & intent(out) :: v_face_mask !< A coded mask for velocities at the C-grid v-face @@ -2983,11 +3012,9 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face integer :: i, j, k, iscq, iecq, jscq, jecq, isd, jsd, is, js, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec - integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - i_off = G%idg_offset ; j_off = G%jdg_offset isd = G%isd ; jsd = G%jsd iegq = G%iegB ; jegq = G%jegB gisc = G%Domain%nihalo ; gjsc = G%Domain%njhalo @@ -3002,61 +3029,73 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face is = isd+1 ; js = jsd+1 endif + do j=js,G%jed; do i=is,G%ied + if (hmask(i,j) == 1) then + umask(I-1:I,J-1:J)=1 + vmask(I-1:I,J-1:J)=1 + endif + enddo; enddo + do j=js,G%jed do i=is,G%ied if ((hmask(i,j) == 1) .OR. (hmask(i,j) == 3)) then - umask(I,j) = 1. - vmask(I,j) = 1. - do k=0,1 select case (int(CS%u_face_mask_bdry(I-1+k,j))) + case (5) + umask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 5. case (3) - vmask(I-1+k,J-1) = 3. + umask(I-1+k,J-1:J) = 3. + vmask(I-1+k,J-1:J) = 3. u_face_mask(I-1+k,j) = 3. - umask(I-1+k,J) = 3. - vmask(I-1+k,J) = 3. - vmask(I-1+k,J) = 3. + case (6) + vmask(I-1+k,J-1:J) = 3. + u_face_mask(I-1+k,j) = 6. case (2) u_face_mask(I-1+k,j) = 2. case (4) umask(I-1+k,J-1:J) = 0. - vmask(I-1+k,J-1:J) = 0. u_face_mask(I-1+k,j) = 4. case (0) umask(I-1+k,J-1:J) = 0. - vmask(I-1+k,J-1:J) = 0. u_face_mask(I-1+k,j) = 0. case (1) ! stress free x-boundary umask(I-1+k,J-1:J) = 0. case default + umask(I-1+k,J-1) = max(1. , umask(I-1+k,J-1)) + umask(I-1+k,J) = max(1. , umask(I-1+k,J)) end select enddo do k=0,1 select case (int(CS%v_face_mask_bdry(i,J-1+k))) + case (5) + vmask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 5. case (3) - vmask(I-1,J-1+k) = 3. - umask(I-1,J-1+k) = 3. - vmask(I,J-1+k) = 3. - umask(I,J-1+k) = 3. + vmask(I-1:I,J-1+k) = 3. + umask(I-1:I,J-1+k) = 3. v_face_mask(i,J-1+k) = 3. + case (6) + umask(I-1:I,J-1+k) = 3. + v_face_mask(i,J-1+k) = 6. case (2) v_face_mask(i,J-1+k) = 2. case (4) - umask(I-1:I,J-1+k) = 0. vmask(I-1:I,J-1+k) = 0. v_face_mask(i,J-1+k) = 4. case (0) - umask(I-1:I,J-1+k) = 0. vmask(I-1:I,J-1+k) = 0. v_face_mask(i,J-1+k) = 0. case (1) ! stress free y-boundary vmask(I-1:I,J-1+k) = 0. case default + vmask(I-1,J-1+k) = max(1. , vmask(I-1,J-1+k)) + vmask(I,J-1+k) = max(1. , vmask(I,J-1+k)) end select enddo diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index dce6e53982..20a48730f3 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -351,7 +351,7 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b hmask(i+1,j) = 3.0 h_bdry_val(i+1,j) = h_shelf(i+1,j) thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) - u_face_mask_bdry(i+1,j) = 3.0 + u_face_mask_bdry(i+1,j) = 5.0 u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution endif From c39937240abb3ae965485b70fef13bb07182d690 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 6 Oct 2023 14:14:18 -0400 Subject: [PATCH 443/629] .testing: Codecov token for unit test upload The codecov token was added to the tc* test upload, but not the unit test upload. This patch adds the token to the unit testing. --- .github/workflows/coverage.yml | 4 ++++ .testing/Makefile | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index a54fda32a6..ad15989475 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -28,10 +28,14 @@ jobs: - name: Report unit test coverage to CI (PR) if: github.event_name == 'pull_request' run: make report.cov.unit REQUIRE_COVERAGE_UPLOAD=true + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - name: Report unit test coverage to CI (Push) if: github.event_name != 'pull_request' run: make report.cov.unit + env: + CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - name: Compile ocean-only MOM6 with code coverage run: make -j build/cov/MOM6 diff --git a/.testing/Makefile b/.testing/Makefile index c2ab27741a..b11532f93c 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -698,7 +698,7 @@ build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/std.out .PHONY: report.cov.unit report.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov codecov - ./codecov -R build/unit -f "*.gcov" -Z -n "Unit tests" \ + ./codecov $(CODECOV_TOKEN_ARG) -R build/unit -f "*.gcov" -Z -n "Unit tests" \ > build/unit/codecov.out \ 2> build/unit/codecov.err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ From 23345f0d82c59b9c3c223316d99c79449c1b6031 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 6 Oct 2023 17:37:14 -0400 Subject: [PATCH 444/629] *Fix non-Boussinesq Flather BT_OBC%dZ_v bug Corrected the non-Boussinesq calculation of the total depth used by the v-component of the Flather open boundary condition, making the v-component consistent with the u-component and correcting an oversight with a recent commit. This commit could change answers in some non-Boussinesq cases with Flather open boundary conditions. --- src/core/MOM_barotropic.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 4a5dba294a..21c3e64488 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -3335,9 +3335,9 @@ subroutine set_up_BT_OBC(OBC, eta, SpV_avg, BT_OBC, BT_Domain, G, GV, US, CS, MS endif else if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j) + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j) * SpV_avg(i,j) elseif (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_S) then - BT_OBC%dZ_v(i,J) = GV%H_to_Z*eta(i,j+1) + BT_OBC%dZ_v(i,J) = GV%H_to_RZ * eta(i,j+1) * SpV_avg(i,j+1) endif endif BT_OBC%Cg_v(i,J) = SQRT(dgeo_de_in * GV%g_prime(1) * BT_OBC%dZ_v(i,J)) From 41609c2a233c4817237d24eb5334a637bac7ba2b Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Tue, 10 Oct 2023 17:47:28 -0400 Subject: [PATCH 445/629] Modify quadrature used for ice shelf viscosity (#468) Previously, when ice_viscosity_compute == MODEL, ice shelf viscosity was calculated using 1 quadrature point per cell; however, this quadrature point was not centered in the cell. -Added a routine bilinear_shape_fn_grid_1qp, which is used to instead calculate viscosity for a single cell-centered quadrature point -Added an option to define parameter ice_viscosity_compute = MODEL_QUADRATURE, where viscosity is calculated at the same four quadrature points used during the SSA solution (the typical approach in finite element codes). Note that when using one quadrature point (ice_viscosity_compute == MODEL), array ice_visc(:,:) is the cell-centered ice viscosity. When using four quadrature points (ice_viscosity_compute == MODEL_QUADRATURE), ice_visc(:,:) is the cell-centered ice viscosity divided by the effective stress, Ee, which varies between each quadrature point and is saved in a separate array CS%Ee(:,:,:). In the SSA, ice viscosity is calculated for a cell with indices i,j as ice_visc(i,j) * Ee, where Ee=1 if using one quadrature point for viscosity and Ee=CS%Ee(i,j,k) if using four quad points (where k the current quad point). Also note the post_data call for ice_visc when using four quad points, where Ice_visc is outputted for visualization from a cell as ice_visc(i,j)*Ee_av(i,j), where Ee_av(i,j) is the average Ee in the cell. --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 264 ++++++++++++++++------- 1 file changed, 192 insertions(+), 72 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 98e2f3600b..bb9de629f7 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -82,6 +82,7 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), !! in [R L2 T-1 ~> kg m-1 s-1]. + real, pointer, dimension(:,:,:) :: Ee => NULL() !< Glen's effective strain-rate ** (1-n)/(n) real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, !! often in [Pa-3 s-1] if n_Glen is 3. real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. @@ -273,6 +274,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) + allocate(CS%Ee(isd:ied,jsd:jed,4), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] @@ -446,7 +448,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "If true, advect ice shelf and evolve thickness", & default=.true.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & - "If MODEL, compute ice viscosity internally, if OBS read from a file,"//& + "If MODEL, compute ice viscosity internally at cell centers, if OBS read from a file,"//& + "If MODEL_QUADRATURE, compute at quadrature points (4 per element),"//& "if CONSTANT a constant value (for debugging).", & default="MODEL") @@ -538,6 +541,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%C_basal_friction, G%domain) call pass_var(CS%h_bdry_val, G%domain) call pass_var(CS%thickness_bdry_val, G%domain) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) @@ -762,6 +766,10 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) then ice_visc(:,:) = CS%ice_visc(:,:)*G%IareaT(:,:) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then + ice_visc(:,:) = ice_visc(:,:) * & + 0.25 * (CS%Ee(:,:,1) + CS%Ee(:,:,2) + CS%Ee(:,:,3) + CS%Ee(:,:,4)) + endif call post_data(CS%id_visc_shelf, ice_visc, CS%diag) endif if (CS%id_taub > 0) then @@ -977,6 +985,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call pass_var(CS%ice_visc, G%domain) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied @@ -989,7 +998,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) @@ -1033,6 +1042,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call pass_var(CS%ice_visc, G%domain) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) + ! makes sure basal stress is only applied when it is supposed to be do j=G%jsd,G%jed ; do i=G%isd,G%ied @@ -1047,7 +1058,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) @@ -1219,7 +1230,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) - call CG_action(Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) @@ -1273,7 +1284,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & + call CG_action(CS, Au, Av, Du, Dv, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, is, ie, js, je, rhoi_rhow) @@ -2115,9 +2126,10 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new end subroutine init_boundary_values -subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & +subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmask, H_node, & ice_visc, float_cond, bathyT, basal_trac, G, US, is, ie, js, je, dens_ratio) + type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: uret !< The retarding stresses working at u-points [R L3 Z T-2 ~> kg m s-2]. @@ -2191,9 +2203,12 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt real, dimension(2) :: xquad real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub + real :: Ee xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + Ee=1.0 + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then do iq=1,2 ; do jq=1,2 @@ -2228,11 +2243,13 @@ subroutine CG_action(uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, hmas v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; ;Jtgt = J-2+jphi - if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & + if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * Ee * ice_visc(i,j) * & ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * ice_visc(i,j) * & + if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * Ee * ice_visc(i,j) * & ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) @@ -2352,11 +2369,14 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real, dimension(2) :: xquad real, dimension(2,2) :: Hcell, sub_ground integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt + real :: Ee isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + Ee=1.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2364,46 +2384,52 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - do iq=1,2 ; do jq=1,2 ; do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - ilq = 1 ; if (iq == iphi) ilq = 2 - jlq = 1 ; if (jq == jphi) jlq = 2 + do iq=1,2 ; do jq=1,2 + + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) + do iphi=1,2 ; do jphi=1,2 - if (CS%umask(Itgt,Jtgt) == 1) then + Itgt = I-2+iphi ; Jtgt = J-2+jphi + ilq = 1 ; if (iq == iphi) ilq = 2 + jlq = 1 ; if (jq == jphi) jlq = 2 - ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - vx = 0. - vy = 0. + if (CS%umask(Itgt,Jtgt) == 1) then - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = 0. + vy = 0. - if (float_cond(i,j) == 0) then - uq = xquad(ilq) * xquad(jlq) u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) - endif - endif + 0.25 * Ee * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) - if (CS%vmask(Itgt,Jtgt) == 1) then + if (float_cond(i,j) == 0) then + uq = xquad(ilq) * xquad(jlq) + u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) + endif + endif - vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) - ux = 0. - uy = 0. + if (CS%vmask(Itgt,Jtgt) == 1) then - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) + vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = 0. + uy = 0. - if (float_cond(i,j) == 0) then - vq = xquad(ilq) * xquad(jlq) v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * Ee * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + + if (float_cond(i,j) == 0) then + vq = xquad(ilq) * xquad(jlq) + v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) + endif endif - endif - enddo ; enddo ; enddo ; enddo + enddo ; enddo + enddo ; enddo if (float_cond(i,j) == 1) then Hcell(:,:) = H_node(i-1:i,j-1:j) @@ -2501,11 +2527,14 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt + real :: Ee isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) + Ee=1.0 + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then ! process this cell if any corners have umask set to non-dirichlet bdry. @@ -2552,13 +2581,15 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) + do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (CS%umask(Itgt,Jtgt) == 1) then u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * Ee * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then @@ -2569,7 +2600,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (CS%vmask(Itgt,Jtgt) == 1) then v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & + 0.25 * Ee * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) if (float_cond(i,j) == 0) then @@ -2615,7 +2646,9 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: PhiC => NULL() ! Same as Phi, but 1 quadrature point per cell (rather than 4) + ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve @@ -2638,11 +2671,17 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset - allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) - - do j=jsc,jec ; do i=isc,iec - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo + if (trim(CS%ice_viscosity_compute) == "MODEL") then + allocate(PhiC(1:8,isc:iec,jsc:jec), source=0.0) + do j=jsc,jec ; do i=isc,iec + call bilinear_shape_fn_grid_1qp(G, i, j, PhiC(:,i,j)) + enddo; enddo + elseif (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then + allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) + do j=jsc,jec ; do i=isc,iec + call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) + enddo; enddo + endif n_g = CS%n_glen; eps_min = CS%eps_glen_min CS%ice_visc(:,:) = 1.0e22 @@ -2650,43 +2689,79 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) do j=jsc,jec ; do i=isc,iec if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then - Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * (CS%AGlen_visc(i,j))**(-1./CS%n_glen) - ! Units of Aglen_visc [Pa-3 s-1] - do iq=1,2 ; do jq=1,2 - ux = ( (u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j)) + & - (u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j)) ) - - vx = ( (v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j)) + & - (v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j)) ) - - uy = ( (u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & - (u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - - vy = ( (v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j)) + & - (v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j)) ) - enddo ; enddo if (trim(CS%ice_viscosity_compute) == "CONSTANT") then CS%ice_visc(i,j) = 1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging - elseif (trim(CS%ice_viscosity_compute) == "MODEL") then - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) elseif (trim(CS%ice_viscosity_compute) == "OBS") then if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) = CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file + elseif (trim(CS%ice_viscosity_compute) == "MODEL") then + + Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * & + (CS%AGlen_visc(i,j))**(-1./CS%n_glen) + ! Units of Aglen_visc [Pa-3 s-1] + + ux = u_shlf(I-1,J-1) * PhiC(1,i,j) + & + u_shlf(I,J) * PhiC(7,i,j) + & + u_shlf(I-1,J) * PhiC(5,i,j) + & + u_shlf(I,J-1) * PhiC(3,i,j) + + vx = v_shlf(I-1,J-1) * PhiC(1,i,j) + & + v_shlf(I,J) * PhiC(7,i,j) + & + v_shlf(I-1,J) * PhiC(5,i,j) + & + v_shlf(I,J-1) * PhiC(3,i,j) + + uy = u_shlf(I-1,J-1) * PhiC(2,i,j) + & + u_shlf(I,J) * PhiC(8,i,j) + & + u_shlf(I-1,J) * PhiC(6,i,j) + & + u_shlf(I,J-1) * PhiC(4,i,j) + + vy = v_shlf(I-1,J-1) * PhiC(2,i,j) + & + v_shlf(I,J) * PhiC(8,i,j) + & + v_shlf(I-1,J) * PhiC(6,i,j) + & + v_shlf(I,J-1) * PhiC(4,i,j) + + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + elseif (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then + !in this case, we will compute viscosity at quadrature points within subroutines CG_action + !and apply_boundary_values. CS%ice_visc(i,j) will include everything except the effective strain rate term: + Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * & + (CS%AGlen_visc(i,j))**(-1./CS%n_glen) + CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) + + do iq=1,2 ; do jq=1,2 + + ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) + + vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) + + uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & + u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) + + vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & + v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) + + CS%Ee(i,j,2*(jq-1)+iq) = & + (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + enddo; enddo endif endif enddo ; enddo - deallocate(Phi) + + if (trim(CS%ice_viscosity_compute) == "MODEL") deallocate(PhiC) + if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") deallocate(Phi) end subroutine calc_shelf_visc @@ -2937,6 +3012,50 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) end subroutine bilinear_shape_fn_grid +!> This subroutine calculates the gradients of bilinear basis elements that are centered at the +!! vertices of the cell using a locally orthogoal MOM6 grid. Values are calculated at +!! a sinlge cell-centered quadrature point, which should match the grid cell h-point +subroutine bilinear_shape_fn_grid_1qp(G, i, j, Phi) + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + integer, intent(in) :: i !< The i-index in the grid to work on. + integer, intent(in) :: j !< The j-index in the grid to work on. + real, dimension(8), intent(inout) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1]. + +! This subroutine calculates the gradients of bilinear basis elements that +! that are centered at the vertices of the cell. The values are calculated at +! a cell-cented point of gaussian quadrature. (in 1D: .5 for [0,1]) +! (ordered in same way as vertices) +! +! Phi(2*i-1) gives d(Phi_i)/dx at the quadrature point +! Phi(2*i) gives d(Phi_i)/dy at the quadrature point +! Phi_i is equal to 1 at vertex i, and 0 at vertex k /= i, and bilinear + + real :: a, d ! Interpolated grid spacings [L ~> m] + real :: xexp=0.5, yexp=0.5 ! [nondim] + integer :: node, qpoint, xnode, ynode + + ! d(x)/d(x*) + if (J>1) then + a = 0.5 * (G%dxCv(i,J-1) + G%dxCv(i,J)) + else + a = G%dxCv(i,J) + endif + + ! d(y)/d(y*) + if (I>1) then + d = 0.5 * (G%dyCu(I-1,j) + G%dyCu(I,j)) + else + d = G%dyCu(I,j) + endif + + do node=1,4 + xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) + Phi(2*node-1) = ( d * (2 * xnode - 3) * yexp ) / (a*d) + Phi(2*node) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + enddo +end subroutine bilinear_shape_fn_grid_1qp + subroutine bilinear_shape_functions_subgrid(Phisub, nsub) integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction @@ -3201,6 +3320,7 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%umask, CS%vmask) deallocate(CS%ice_visc, CS%AGlen_visc) + deallocate(CS%Ee) deallocate(CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) From 2ac48a63d81405128688a8cce08c0de0448846af Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Wed, 11 Oct 2023 04:14:12 -0400 Subject: [PATCH 446/629] SSA convergence based on change of norm (#469) Added an option NONLIN_SOLVE_ERR_MODE=3 to check for convergence of the ice shelf SSA solution by testing the change of norm, i.e. 2*abs(|u_{t}|-|u_{t-1}|) / (|u_{t}|+|u_{t-1}|) --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 70 +++++++++++++++++------- 1 file changed, 50 insertions(+), 20 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index bb9de629f7..f4eacbb666 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -160,6 +160,7 @@ module MOM_ice_shelf_dynamics integer :: cg_max_iterations !< The maximum number of iterations that can be used in the CG solver integer :: nonlin_solve_err_mode !< 1: exit vel solve based on nonlin residual !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm + !! 3: exit based on change of norm ! ids for outputting intermediate thickness in advection subroutine (debugging) !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 @@ -436,7 +437,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="m", default=1.e-3, scale=US%m_to_Z) call get_param(param_file, mdl, "NONLIN_SOLVE_ERR_MODE", CS%nonlin_solve_err_mode, & "Choose whether nonlin error in vel solve is based on nonlinear "//& - "residual (1) or relative change since last iteration (2)", default=1) + "residual (1), relative change since last iteration (2), or change in norm (3)", default=1) call get_param(param_file, mdl, "SHELF_MOVING_FRONT", CS%moving_shelf_front, & "Specify whether to advance shelf front (and calve).", & @@ -904,15 +905,17 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice ! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub - real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv + real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale ! locations for finite element calculations [nondim] + integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. ! for GL interpolation nsub = CS%n_sub_regularize @@ -993,17 +996,17 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo + if (CS%nonlin_solve_err_mode == 1) then ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) - Au(:,:) = 0.0 ; Av(:,:) = 0.0 + Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (CS%nonlin_solve_err_mode == 1) then err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then @@ -1019,6 +1022,24 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call max_across_PEs(err_init) + elseif (CS%nonlin_solve_err_mode == 3) then + Normvec=0.0 + ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. + Is_sum = G%isc + (1-G%IsdB) + Ie_sum = G%iecB + (1-G%IsdB) + ! Include the edge if tile is at the western bdry; Should add a test to avoid this if reentrant. + if (G%isc+G%idg_offset==G%isg) Is_sum = G%IscB + (1-G%IsdB) + + Js_sum = G%jsc + (1-G%JsdB) + Je_sum = G%jecB + (1-G%JsdB) + ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. + if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)*u_shlf(I,J) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)*v_shlf(I,J) + enddo; enddo + Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) + Norm = sqrt(Norm) endif u_last(:,:) = u_shlf(:,:) ; v_last(:,:) = v_shlf(:,:) @@ -1051,22 +1072,21 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) enddo ; enddo - !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - - !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) + if (CS%nonlin_solve_err_mode == 1) then + !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - Au(:,:) = 0 ; Av(:,:) = 0 + ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & + ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) - call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & - G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) + Au(:,:) = 0 ; Av(:,:) = 0 - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) - err_max = 0 + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) - if (CS%nonlin_solve_err_mode == 1) then + err_max = 0 do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB if (CS%umask(I,J) == 1) then @@ -1085,7 +1105,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 2) then - max_vel = 0 ; tempu = 0 ; tempv = 0 + err_max=0. ; max_vel = 0 ; tempu = 0 ; tempv = 0 ; err_tempu = 0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB if (CS%umask(I,J) == 1) then err_tempu = ABS(u_last(I,J)-u_shlf(I,J)) @@ -1108,6 +1128,16 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call max_across_PEs(max_vel) call max_across_PEs(err_max) err_init = max_vel + + elseif (CS%nonlin_solve_err_mode == 3) then + PrevNorm=Norm; Norm=0.0; Normvec=0.0 + do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)*u_shlf(I,J) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)*v_shlf(I,J) + enddo; enddo + Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) + Norm = sqrt(Norm) + err_max=2.*abs(Norm-PrevNorm); err_init=Norm+PrevNorm endif write(mesg,*) "ice_shelf_solve_outer: nonlinear fractional residual = ", err_max/err_init From bd4c87ce55469e82e42662ff332378b7c6ded9f0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 7 Jul 2023 09:50:08 -0400 Subject: [PATCH 447/629] *Use thickness_to_dz in dumbbell_initialize_sponges Use thickness_to_dz to convert thicknesses from thickness units to height units in dumbbell_initialize_sponges with the traditional (non-ALE) sponges. Boussinesq answers are identical, but non-Boussinesq answers with an equation of state will change to be less dependent on the value of RHO_0. --- src/user/dumbbell_initialization.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index b2ed47f89b..492cb3ebe8 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -10,6 +10,7 @@ module dumbbell_initialization 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_interface_heights, only : thickness_to_dz 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 @@ -472,10 +473,13 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil 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 + ! Convert thicknesses from thickness units to height units + call thickness_to_dz(h_in, tv, dz, G, GV, US) + do j=G%jsc,G%jec ; do i=G%isc,G%iec eta(i,j,1) = 0.0 do k=2,nz - eta(i,j,k) = eta(i,j,k-1) - GV%H_to_Z * h_in(i,j,k-1) + eta(i,j,k) = eta(i,j,k-1) - dz(i,j,k-1) enddo eta(i,j,nz+1) = -depth_tot(i,j) do k=1,nz From 95d6e93604597fa8f780b395c5089a556672165f Mon Sep 17 00:00:00 2001 From: WenhaoChen89 <96131003+WenhaoChen89@users.noreply.github.com> Date: Thu, 12 Oct 2023 12:18:10 -0400 Subject: [PATCH 448/629] (+*) Fix bugs in tracer index in tracer reservoirs (#480) * Fix nudged OBCs for tracers * Fix index in tracer reservoirs * fix index in the function update_segment_tracer_reservoirs * Fix index bugs in OBC tracer reservoirs * Fix tracer index bugs at open boundaries --- src/core/MOM_open_boundary.F90 | 72 +++++++++++++++++------- src/tracer/MOM_tracer_advect.F90 | 54 ++++++++++-------- src/tracer/MOM_tracer_registry.F90 | 11 +++- src/user/DOME_initialization.F90 | 18 +++--- src/user/dyed_channel_initialization.F90 | 6 +- src/user/dyed_obcs_initialization.F90 | 6 +- 6 files changed, 104 insertions(+), 63 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 896a677b02..c995adb671 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -32,6 +32,7 @@ module MOM_open_boundary use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type +use MOM_string_functions, only : lowercase implicit none ; private @@ -118,6 +119,8 @@ module MOM_open_boundary real :: scale !< A scaling factor for converting the units of input !! data, like [S ppt-1 ~> 1] for salinity. logical :: is_initialized !< reservoir values have been set when True + integer :: ntr_index = -1 !< index of segment tracer in the global tracer registry + integer :: fd_index = -1 !< index of segment tracer in the input fields end type OBC_segment_tracer_type !> Registry type for tracers on segments @@ -4647,8 +4650,8 @@ end subroutine segment_tracer_registry_init !> Register a tracer array that is active on an OBC segment, potentially also specifying how the !! tracer inflow values are specified. -subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & - OBC_scalar, OBC_array, scale) +subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & + OBC_scalar, OBC_array, scale, fd_index) type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(tracer_type), target :: tr_ptr !< A target that can be used to set a pointer to the !! stored value of tr. This target must be @@ -4657,6 +4660,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & !! but it also means that any updates to this !! structure in the calling module will be !! available subsequently to the tracer registry. + integer, intent(in) :: ntr_index !< index of segment tracer in the global tracer registry type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values type(OBC_segment_type), intent(inout) :: segment !< current segment data structure real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer @@ -4667,6 +4671,7 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & real, optional, intent(in) :: scale !< A scaling factor that should be used with any !! data that is read in, to convert it to the internal !! units of this tracer. + integer, optional, intent(in) :: fd_index !< index of segment tracer in the input field ! Local variables real :: rescale ! A multiplicative correction to the scaling factor. @@ -4690,6 +4695,8 @@ subroutine register_segment_tracer(tr_ptr, param_file, GV, segment, & segment%tr_Reg%Tr(ntseg)%Tr => tr_ptr segment%tr_Reg%Tr(ntseg)%name = tr_ptr%name + segment%tr_Reg%Tr(ntseg)%ntr_index = ntr_index + if (present(fd_index)) segment%tr_Reg%Tr(ntseg)%fd_index = fd_index segment%tr_Reg%Tr(ntseg)%scale = 1.0 if (present(scale)) then @@ -4752,7 +4759,7 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values ! Local variables - integer :: n + integer :: n, ntr_id character(len=32) :: name type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list type(tracer_type), pointer :: tr_ptr => NULL() @@ -4767,12 +4774,12 @@ subroutine register_temp_salt_segments(GV, US, OBC, tr_Reg, param_file) call MOM_error(FATAL,"register_temp_salt_segments: tracer array was previously allocated") name = 'temp' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, & + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & OBC_array=segment%temp_segment_data_exists, scale=US%degC_to_C) name = 'salt' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, & + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, & OBC_array=segment%salt_segment_data_exists, scale=US%ppt_to_S) enddo @@ -4825,8 +4832,8 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) type(param_file_type), intent(in) :: param_file !< file to parse for model parameter values character(len=*), intent(in) :: tr_name!< Tracer name ! Local variables - integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf - integer :: i, j, k, n + integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, nz, nf, ntr_id, fd_id + integer :: i, j, k, n, m type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list type(tracer_type), pointer :: tr_ptr => NULL() @@ -4835,8 +4842,13 @@ subroutine register_obgc_segments(GV, OBC, tr_Reg, param_file, tr_name) do n=1, OBC%number_of_segments segment=>OBC%segment(n) if (.not. segment%on_pe) cycle - call tracer_name_lookup(tr_Reg, tr_ptr, tr_name) - call register_segment_tracer(tr_ptr, param_file, GV, segment, OBC_array=.True.) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, tr_name) + ! get the obgc field index + fd_id = -1 + do m=1,segment%num_fields + if (lowercase(segment%field(m)%name) == lowercase(tr_name)) fd_id = m + enddo + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, segment, OBC_array=.True., fd_index=fd_id) enddo end subroutine register_obgc_segments @@ -5336,8 +5348,9 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) real :: fac1 ! The denominator of the expression for tracer updates [nondim] real :: I_scale ! The inverse of the scaling factor for the tracers. ! For salinity the units would be [ppt S-1 ~> 1] - integer :: i, j, k, m, n, ntr, nz + integer :: i, j, k, m, n, ntr, nz, ntr_id, fd_id integer :: ishift, idir, jshift, jdir + real :: resrv_lfac_out, resrv_lfac_in real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs ! 1 if the length scale of reservoir is zero [nondim] real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights @@ -5365,7 +5378,16 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! Can keep this or take it out, either way if (G%mask2dT(I+ishift,j) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + fd_id = segment%tr_reg%Tr(m)%fd_index + if(fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz ! Calculate weights. Both a and u_L are nodim. Adding them together has no meaning. @@ -5374,14 +5396,14 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! When InvLscale_in is 0 and inflow, only nudged data is applied to reservoirs a_out = b_out * max(0.0, sign(1.0, idir*uhr(I,j,k))) a_in = b_in * min(0.0, sign(1.0, idir*uhr(I,j,k))) - u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*segment%field(m)%resrv_lfac_out / & + u_L_out = max(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) - u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*segment%field(m)%resrv_lfac_in / & + u_L_in = min(0.0, (idir*uhr(I,j,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & ((h(i+ishift,j,k) + GV%H_subroundoff)*G%dyCu(I,j))) fac1 = (1.0 - (a_out - a_in)) + ((u_L_out + a_out) - (u_L_in + a_in)) segment%tr_Reg%Tr(m)%tres(I,j,k) = (1.0/fac1) * & ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(I,j,k)+ & - ((u_L_out+a_out)*Reg%Tr(m)%t(I+ishift,j,k) - & + ((u_L_out+a_out)*Reg%Tr(ntr_id)%t(I+ishift,j,k) - & (u_L_in+a_in)*segment%tr_Reg%Tr(m)%t(I,j,k))) if (allocated(OBC%tres_x)) OBC%tres_x(I,j,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(I,j,k) enddo ; endif @@ -5400,20 +5422,28 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! Can keep this or take it out, either way if (G%mask2dT(i,j+jshift) == 0.0) cycle ! Update the reservoir tracer concentration implicitly using a Backward-Euler timestep - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index + fd_id = segment%tr_reg%Tr(m)%fd_index + if(fd_id == -1) then + resrv_lfac_out = 1.0 + resrv_lfac_in = 1.0 + else + resrv_lfac_out = segment%field(fd_id)%resrv_lfac_out + resrv_lfac_in = segment%field(fd_id)%resrv_lfac_in + endif I_scale = 1.0 ; if (segment%tr_Reg%Tr(m)%scale /= 0.0) I_scale = 1.0 / segment%tr_Reg%Tr(m)%scale if (allocated(segment%tr_Reg%Tr(m)%tres)) then ; do k=1,nz a_out = b_out * max(0.0, sign(1.0, jdir*vhr(i,J,k))) a_in = b_in * min(0.0, sign(1.0, jdir*vhr(i,J,k))) - v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*segment%field(m)%resrv_lfac_out / & + v_L_out = max(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_out*resrv_lfac_out / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*segment%field(m)%resrv_lfac_in / & + v_L_in = min(0.0, (jdir*vhr(i,J,k))*segment%Tr_InvLscale_in*resrv_lfac_in / & ((h(i,j+jshift,k) + GV%H_subroundoff)*G%dxCv(i,J))) - fac1 = 1.0 + (v_L_out-v_L_in) fac1 = (1.0 - (a_out - a_in)) + ((v_L_out + a_out) - (v_L_in + a_in)) segment%tr_Reg%Tr(m)%tres(i,J,k) = (1.0/fac1) * & ((1.0-a_out+a_in)*segment%tr_Reg%Tr(m)%tres(i,J,k) + & - ((v_L_out+a_out)*Reg%Tr(m)%t(i,J+jshift,k) - & + ((v_L_out+a_out)*Reg%Tr(ntr_id)%t(i,J+jshift,k) - & (v_L_in+a_in)*segment%tr_Reg%Tr(m)%t(i,J,k))) if (allocated(OBC%tres_y)) OBC%tres_y(i,J,k,m) = I_scale * segment%tr_Reg%Tr(m)%tres(i,J,k) enddo ; endif diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index dde110f959..efe6397de0 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -381,7 +381,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. logical :: usePLMslope - integer :: i, j, m, n, i_up, stencil + integer :: i, j, m, n, i_up, stencil, ntr_id type(OBC_segment_type), pointer :: segment=>NULL() logical, dimension(SZJ_(G),SZK_(GV)) :: domore_u_initial @@ -442,18 +442,19 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if (segment%is_E_or_W) then if (j>=segment%HI%jsd .and. j<=segment%HI%jed) then I = segment%HI%IsdB - do m = 1,ntr ! replace tracers with OBC values + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_W) then - T_tmp(i,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(i+1,m) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i+1,ntr_id) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -586,10 +587,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & (uhr(I,j,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_E)) then uhh(I) = uhr(I,j,k) ! should the reservoir evolve for this case Kate ?? - Nope - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else ; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else ; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif endif @@ -609,10 +611,11 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & if ((uhr(I,j,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (uhr(I,j,k) < 0.0) .and. (G%mask2dT(i+1,j) < 0.5)) then uhh(I) = uhr(I,j,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) - else; flux_x(I,j,m) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif + flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%tres(I,j,k) + else; flux_x(I,j,ntr_id) = uhh(I)*segment%tr_Reg%Tr(m)%OBC_inflow_conc; endif enddo endif endif @@ -754,7 +757,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. logical :: usePLMslope - integer :: i, j, j2, m, n, j_up, stencil + integer :: i, j, j2, m, n, j_up, stencil, ntr_id type(OBC_segment_type), pointer :: segment=>NULL() logical :: domore_v_initial(SZJB_(G)) ! Initial state of domore_v @@ -823,18 +826,19 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if (segment%is_N_or_S) then if (i>=segment%HI%isd .and. i<=segment%HI%ied) then J = segment%HI%JsdB - do m = 1,ntr ! replace tracers with OBC values + do m = 1,segment%tr_Reg%ntseg ! replace tracers with OBC values + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%tres(i,j,k) else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%tres(i,j,k) endif else if (segment%direction == OBC_DIRECTION_S) then - T_tmp(i,m,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id,j) = segment%tr_Reg%Tr(m)%OBC_inflow_conc else - T_tmp(i,m,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc + T_tmp(i,ntr_id,j+1) = segment%tr_Reg%Tr(m)%OBC_inflow_conc endif endif enddo @@ -968,10 +972,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if ((vhr(i,J,k) > 0.0) .and. (segment%direction == OBC_DIRECTION_S) .or. & (vhr(i,J,k) < 0.0) .and. (segment%direction == OBC_DIRECTION_N)) then vhh(i,J) = vhr(i,J,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*OBC%segment(n)%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif enddo @@ -991,10 +996,11 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & if ((vhr(i,J,k) > 0.0) .and. (G%mask2dT(i,j) < 0.5) .or. & (vhr(i,J,k) < 0.0) .and. (G%mask2dT(i,j+1) < 0.5)) then vhh(i,J) = vhr(i,J,k) - do m=1,ntr + do m=1,segment%tr_Reg%ntseg + ntr_id = segment%tr_reg%Tr(m)%ntr_index if (allocated(segment%tr_Reg%Tr(m)%tres)) then - flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) - else ; flux_y(i,m,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif + flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%tres(i,J,k) + else ; flux_y(i,ntr_id,J) = vhh(i,J)*segment%tr_Reg%Tr(m)%OBC_inflow_conc ; endif enddo endif enddo diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c3f5f64edf..1e9b9c22b8 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -848,16 +848,21 @@ end subroutine tracer_Reg_chkinv !> Find a tracer in the tracer registry by name. -subroutine tracer_name_lookup(Reg, tr_ptr, name) +subroutine tracer_name_lookup(Reg, n, tr_ptr, name) type(tracer_registry_type), pointer :: Reg !< pointer to tracer registry type(tracer_type), pointer :: tr_ptr !< target or pointer to the tracer array character(len=32), intent(in) :: name !< tracer name + integer, intent(out) :: n !< index to tracer registery - integer n do n=1,Reg%ntr - if (lowercase(Reg%Tr(n)%name) == lowercase(name)) tr_ptr => Reg%Tr(n) + if (lowercase(Reg%Tr(n)%name) == lowercase(name)) then + tr_ptr => Reg%Tr(n) + return + endif enddo + call MOM_error(FATAL,"MOM cannot find registered tracer: "//name) + end subroutine tracer_name_lookup !> Initialize the tracer registry. diff --git a/src/user/DOME_initialization.F90 b/src/user/DOME_initialization.F90 index 638ecf80db..858ca32f93 100644 --- a/src/user/DOME_initialization.F90 +++ b/src/user/DOME_initialization.F90 @@ -334,7 +334,7 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) ! region of the specified shear profile [nondim] character(len=32) :: name ! The name of a tracer field. character(len=40) :: mdl = "DOME_set_OBC_data" ! This subroutine's name. - integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm + integer :: i, j, k, itt, is, ie, js, je, isd, ied, jsd, jed, m, nz, ntherm, ntr_id integer :: IsdB, IedB, JsdB, JedB type(OBC_segment_type), pointer :: segment => NULL() type(tracer_type), pointer :: tr_ptr => NULL() @@ -434,8 +434,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) if (associated(tv%S)) then ! In this example, all S inflows have values given by S_ref. name = 'salt' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, segment, OBC_scalar=S_ref, scale=US%ppt_to_S) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_scalar=S_ref, scale=US%ppt_to_S) endif if (associated(tv%T)) then ! In this example, the T values are set to be consistent with the layer @@ -459,8 +459,8 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) segment%field(1)%buffer_src(i,j,k) = T0(k) enddo ; enddo ; enddo name = 'temp' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, segment, OBC_array=.true., scale=US%degC_to_C) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, segment, OBC_array=.true., scale=US%degC_to_C) endif ! Set up dye tracers @@ -472,16 +472,16 @@ subroutine DOME_set_OBC_data(OBC, tv, G, GV, US, PF, tr_Reg) else ; segment%field(ntherm+1)%buffer_src(i,j,k) = 1.0 ; endif enddo ; enddo ; enddo name = 'tr_D1' - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, OBC%segment(1), OBC_array=.true.) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_array=.true.) ! All tracers but the first have 0 concentration in their inflows. As 0 is the ! default value for the inflow concentrations, the following calls are unnecessary. do m=2,tr_Reg%ntr if (m < 10) then ; write(name,'("tr_D",I1.1)') m else ; write(name,'("tr_D",I2.2)') m ; endif - call tracer_name_lookup(tr_Reg, tr_ptr, name) - call register_segment_tracer(tr_ptr, PF, GV, OBC%segment(1), OBC_scalar=0.0) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) + call register_segment_tracer(tr_ptr, ntr_id, PF, GV, OBC%segment(1), OBC_scalar=0.0) enddo end subroutine DOME_set_OBC_data diff --git a/src/user/dyed_channel_initialization.F90 b/src/user/dyed_channel_initialization.F90 index aed7142fad..2dde65148b 100644 --- a/src/user/dyed_channel_initialization.F90 +++ b/src/user/dyed_channel_initialization.F90 @@ -93,7 +93,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_channel_set_OBC_tracer_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: m, n + integer :: m, n, ntr_id real :: dye ! Inflow dye concentrations [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() @@ -115,7 +115,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) do m=1,ntr write(name,'("dye_",I2.2)') m write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m - call tracer_name_lookup(tr_Reg, tr_ptr, name) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) do n=1,OBC%number_of_segments if (n == m) then @@ -123,7 +123,7 @@ subroutine dyed_channel_set_OBC_tracer_data(OBC, G, GV, param_file, tr_Reg) else dye = 0.0 endif - call register_segment_tracer(tr_ptr, param_file, GV, & + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & OBC%segment(n), OBC_scalar=dye) enddo enddo diff --git a/src/user/dyed_obcs_initialization.F90 b/src/user/dyed_obcs_initialization.F90 index 6248efab2f..7d1c0635f9 100644 --- a/src/user/dyed_obcs_initialization.F90 +++ b/src/user/dyed_obcs_initialization.F90 @@ -39,7 +39,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) ! Local variables character(len=40) :: mdl = "dyed_obcs_set_OBC_data" ! This subroutine's name. character(len=80) :: name, longname - integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz + integer :: is, ie, js, je, isd, ied, jsd, jed, m, n, nz, ntr_id integer :: IsdB, IedB, JsdB, JedB real :: dye ! Inflow dye concentration [arbitrary] type(tracer_type), pointer :: tr_ptr => NULL() @@ -65,7 +65,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) do m=1,ntr write(name,'("dye_",I2.2)') m write(longname,'("Concentration of dyed_obc Tracer ",I2.2, " on segment ",I2.2)') m, m - call tracer_name_lookup(tr_Reg, tr_ptr, name) + call tracer_name_lookup(tr_Reg, ntr_id, tr_ptr, name) do n=1,OBC%number_of_segments if (n == m) then @@ -73,7 +73,7 @@ subroutine dyed_obcs_set_OBC_data(OBC, G, GV, param_file, tr_Reg) else dye = 0.0 endif - call register_segment_tracer(tr_ptr, param_file, GV, & + call register_segment_tracer(tr_ptr, ntr_id, param_file, GV, & OBC%segment(n), OBC_scalar=dye) enddo enddo From 38aeccd855350d29bf88e210ba01b6e61cb600ac Mon Sep 17 00:00:00 2001 From: Spencer Jones <41342785+cspencerjones@users.noreply.github.com> Date: Thu, 12 Oct 2023 19:14:13 -0500 Subject: [PATCH 449/629] +Add particle code option to advect with uhtr (#492) * +Add particle code option to advect with uhtr The particle code has so far used the same velocity has was used in the dynamics step. I would like to add the option for the particle code to use uhtr/h and vhtr/h, so that the velocities used to advect particles may include the effects of parameterized eddies. To make this work, I have added a flag that controls which velocity to use and moved the particles_run step to take place after uhtr and vhtr are defined. The interfaces in the code and in config_src/external are updated to pass this information to the drifters package. --- .../external/drifters/MOM_particles.F90 | 11 ++++++++--- src/core/MOM.F90 | 19 ++++++++++++++----- 2 files changed, 22 insertions(+), 8 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index fa3840c6c2..b86c720b75 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -28,14 +28,19 @@ subroutine particles_init(parts, Grid, Time, dt, u, v, h) end subroutine particles_init !> The main driver the steps updates particles -subroutine particles_run(parts, time, uo, vo, ho, tv, stagger) +subroutine particles_run(parts, time, uo, vo, ho, tv, use_uh, stagger) ! Arguments type(particles), pointer :: parts !< Container for all types and memory type(time_type), intent(in) :: time !< Model time - real, dimension(:,:,:), intent(in) :: uo !< Ocean zonal velocity [L T-1 ~>m s-1] - real, dimension(:,:,:), intent(in) :: vo !< Ocean meridional velocity [L T-1~> m s-1] + real, dimension(:,:,:), intent(in) :: uo !< If use_uh is false, ocean zonal velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated zonal thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] + real, dimension(:,:,:), intent(in) :: vo !< If use_uh is false, ocean meridional velocity [L T-1 ~>m s-1]. + !! If use_uh is true, accumulated meridional thickness fluxes + !! that are used to advect tracers [H L2 ~> m3 or kg] real, dimension(:,:,:), intent(in) :: ho !< Ocean layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< structure containing pointers to available thermodynamic fields + logical :: use_uh !< Flag for whether u and v are weighted by thickness integer, optional, intent(in) :: stagger !< Flag for whether velocities are staggered end subroutine particles_run diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 25f4f27ee7..2af9ad40e1 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -360,6 +360,7 @@ module MOM !! higher values use more appropriate expressions that differ at !! roundoff for non-Boussinesq cases. logical :: use_particles !< Turns on the particles package + logical :: use_uh_particles !< particles are advected by uh/h logical :: use_dbclient !< Turns on the database client used for ML inference/analysis character(len=10) :: particle_type !< Particle types include: surface(default), profiling and sail drone. @@ -1266,10 +1267,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & enddo; enddo endif - if (CS%use_particles .and. CS%do_dynamics) then ! Run particles whether or not stepping is split - call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, CS%tv) ! Run the particles model - endif - if ((CS%thickness_diffuse .or. CS%interface_filter) .and. & .not.CS%thickness_diffuse_first) then @@ -1331,6 +1328,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif call disable_averaging(CS%diag) + if (CS%use_particles .and. CS%do_dynamics .and. CS%use_uh_particles) then + !Run particles using thickness-weighted velocity + call particles_run(CS%particles, Time_local, CS%uhtr, CS%vhtr, CS%h, & + CS%tv, CS%use_uh_particles) + elseif (CS%use_particles .and. CS%do_dynamics) then + !Run particles using unweighted velocity + call particles_run(CS%particles, Time_local, CS%u, CS%v, CS%h, & + CS%tv, CS%use_uh_particles) + endif + + ! Advance the dynamics time by dt. CS%t_dyn_rel_adv = CS%t_dyn_rel_adv + dt CS%n_dyn_steps_in_adv = CS%n_dyn_steps_in_adv + 1 @@ -2440,7 +2448,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_PARTICLES", CS%use_particles, & "If true, use the particles package.", default=.false.) - + call get_param(param_file, "MOM", "USE_UH_PARTICLES", CS%use_uh_particles, & + "If true, use the uh velocity in the particles package.",default=.false.) CS%ensemble_ocean=.false. call get_param(param_file, "MOM", "ENSEMBLE_OCEAN", CS%ensemble_ocean, & "If False, The model is being run in serial mode as a single realization. "//& From 89506fab00d2f73a57f498e4b7fbd8edfbfe1378 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Fri, 13 Oct 2023 00:09:37 -0400 Subject: [PATCH 450/629] Ice shelf Coulomb friction law (#470) * Added ice shelf Coulomb friction law (Schoof 2005, Gagliardini et al 2007) needed for MISMIP+ experiments (Asay-Davis et al 2016). --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 72 +++++++++++++++++++----- 1 file changed, 57 insertions(+), 15 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index f4eacbb666..81a4c7e21b 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -98,11 +98,12 @@ module MOM_ice_shelf_dynamics !! the same as G%bathyT+Z_ref, when below sea-level. !! Sign convention: positive below sea-level, negative above. - real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area integrated nonlinear part of "linearized" - !! basal stress (Pa) [R L2 T-2 ~> Pa]. + real, pointer, dimension(:,:) :: basal_traction => NULL() !< The area-integrated taub_beta field + !! (m2 Pa s m-1, or kg s-1) related to the nonlinear part + !! of "linearized" basal stress (Pa) [R L3 T-1 ~> kg s-1] !! The exact form depends on basal law exponent and/or whether flow is "hybridized" a la Goldberg 2011 real, pointer, dimension(:,:) :: C_basal_friction => NULL()!< Coefficient in sliding law tau_b = C u^(n_basal_fric), - !! units= Pa (m yr-1)-(n_basal_fric) + !! units= Pa (m s-1)^(n_basal_fric) real, pointer, dimension(:,:) :: OD_rt => NULL() !< A running total for calculating OD_av [Z ~> m]. real, pointer, dimension(:,:) :: ground_frac_rt => NULL() !< A running total for calculating ground_frac. real, pointer, dimension(:,:) :: OD_av => NULL() !< The time average open ocean depth [Z ~> m]. @@ -144,6 +145,10 @@ module MOM_ice_shelf_dynamics real :: n_glen !< Nonlinearity exponent in Glen's Law [nondim] real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] + logical :: CoulombFriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007) + real :: CF_MinN !< Minimum Coulomb friction effective pressure [R L2 T-2 ~> Pa] + real :: CF_PostPeak !< Coulomb friction post peak exponent [nondim] + real :: CF_Max !< Coulomb friction maximum coefficient [nondim] real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean !! circulation or thermodynamics. It is used to estimate the !! gravitational driving force at the shelf front (until we think of @@ -277,7 +282,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) allocate(CS%Ee(isd:ied,jsd:jed,4), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] - allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L2 T-2 ~> Pa] + allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] allocate(CS%OD_av(isd:ied,jsd:jed), source=0.0) allocate(CS%ground_frac(isd:ied,jsd:jed), source=0.0) @@ -423,6 +428,19 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call get_param(param_file, mdl, "BASAL_FRICTION_EXP", CS%n_basal_fric, & "Exponent in sliding law \tau_b = C u^(n_basal_fric)", & units="none", fail_if_missing=.true.) + call get_param(param_file, mdl, "USE_COULOMB_FRICTION", CS%CoulombFriction, & + "Use Coulomb Friction Law", & + units="none", default=.false., fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_MinN", CS%CF_MinN, & + "Minimum Coulomb friction effective pressure", & + units="Pa", default=1.0, scale=US%Pa_to_RL2_T2, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_PostPeak", CS%CF_PostPeak, & + "Coulomb friction post peak exponent", & + units="none", default=1.0, fail_if_missing=.false.) + call get_param(param_file, mdl, "CF_Max", CS%CF_Max, & + "Coulomb friction maximum coefficient", & + units="none", default=0.5, fail_if_missing=.false.) + call get_param(param_file, mdl, "DENSITY_ICE", CS%density_ice, & "A typical density of ice.", units="kg m-3", default=917.0, scale=US%kg_m3_to_R) call get_param(param_file, mdl, "CONJUGATE_GRADIENT_TOLERANCE", CS%cg_tolerance, & @@ -624,7 +642,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & 'vi-viscosity', 'Pa m s', conversion=US%RL2_T2_to_Pa*US%Z_to_m*US%T_to_s) !vertically integrated viscosity CS%id_taub = register_diag_field('ice_shelf_model','taub_beta',CS%diag%axesT1, Time, & - 'taub', 'MPa', conversion=1e-6*US%RL2_T2_to_Pa) + 'taub', 'MPa s m-1', conversion=1e-6*US%RL2_T2_to_Pa/(365.0*86400.0*US%L_T_to_m_s)) CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) endif @@ -720,7 +738,8 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled real, dimension(SZDIB_(G),SZDJB_(G)) :: taud_x, taud_y ! Pa] real, dimension(SZDI_(G),SZDJ_(G)) :: ice_visc !< area-averaged vertically integrated ice viscosity !! [R L2 Z T-1 ~> Pa s m] - real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged basal traction [R L2 T-2 ~> Pa] + real, dimension(SZDI_(G),SZDJ_(G)) :: basal_tr !< area-averaged taub_beta field related to basal traction, + !! [R L1 T-1 ~> Pa s m-1] integer :: iters logical :: update_ice_vel, coupled_GL @@ -2198,8 +2217,8 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater, nondimensional @@ -2373,8 +2392,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are @@ -2533,8 +2552,8 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, !! flow law. The exact form and units depend on the !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< A field related to the nonlinear part of the - !! "linearized" basal stress [R Z T-1 ~> kg m-2 s-1]. + intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear + !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: float_cond !< An array indicating where the ice @@ -2814,6 +2833,10 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) integer :: i, j, iscq, iecq, jscq, jecq, isd, jsd, ied, jed, iegq, jegq integer :: giec, gjec, gisc, gjsc, isc, jsc, iec, jec, is, js real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] + real :: alpha !Coulomb coefficient [nondim] + real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] + real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R L2 T-2 ~> Pa] + real :: fB !for Coulomb Friction [(L T-1)^CS%CF_PostPeak ~> (m s-1)^CS%CF_PostPeak] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2825,15 +2848,34 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) eps_min = CS%eps_glen_min + if (CS%CoulombFriction) then + if (CS%CF_PostPeak.ne.1.0) THEN + alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] + else + alpha = 1.0 + endif + endif do j=jsd+1,jed do i=isd+1,ied if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) -! CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * (US%L_T_to_m_s*unorm)**(CS%n_basal_fric-1) + unorm = US%L_T_to_m_s*sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) + + !Coulomb friction (Schoof 2005, Gagliardini et al 2007) + if (CS%CoulombFriction) then + !Effective pressure + Hf = max(CS%density_ocean_avg * CS%bed_elev(i,j)/CS%density_ice, 0.0) + fN = max(CS%density_ice * CS%g_Earth * (ISS%h_shelf(i,j) - Hf),CS%CF_MinN) + + fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * & + unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric) + else + !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric .ne. 1) + CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * unorm**(CS%n_basal_fric-1) + endif endif enddo enddo From 0c491ce12f74a1823d10b13823088cca1f81c010 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Fri, 13 Oct 2023 10:09:06 -0800 Subject: [PATCH 451/629] +REMAP_AUX needs at least one more halo update. (#496) * +REMAP_AUX needs at least one more halo update. - This one is for CS%u_av, CS%v_av, which need to be updated coming into step_MOM_dyn_split_RK2. * +Next stab at fixing REMAP_AUX fallout. - This fixes the Bering ORLANSKI OBCs for differing processor counts. - This is either the wrong way to do group_pass for OBLIQUE OBC's or there is more wrong with them. * Adding a group pass, still not solving the problem - Problem is in tangential_vel at tile boundaries. It matches right at the boundary, but needs some halo points to match too. * +Fixing oblique OBCs - Without this, u_av and v_av don't update a wide enough halo to get answers to reproduce across different processor counts with oblique OBCs. * Fixed an oopsie with OBC * Getting rid of extra exchange (that didn't help) --- src/core/MOM_dynamics_split_RK2.F90 | 16 +++++++++++----- src/core/MOM_open_boundary.F90 | 20 +++++++++++++++++--- 2 files changed, 28 insertions(+), 8 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index feb0b7e582..c506d12139 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -388,7 +388,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s logical :: showCallTree, sym integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz - integer :: cont_stencil + integer :: cont_stencil, obc_stencil 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 @@ -451,19 +451,23 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !--- begin set up for group halo pass cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif call cpu_clock_begin(id_clock_pass) call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_uv, u, v, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=2) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=2) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass @@ -1203,7 +1207,9 @@ subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old, h_new, ALE_CSp, OBC, d if (CS%store_CAu) then call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%u_av, CS%v_av, OBC, dzRegrid) + call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%CAu_pred, CS%CAv_pred, OBC, dzRegrid) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) endif call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%diffu, CS%diffv, OBC, dzRegrid) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index c995adb671..13ce524006 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -9,6 +9,7 @@ module MOM_open_boundary use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type, log_param @@ -373,6 +374,7 @@ module MOM_open_boundary !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. + type(group_pass_type) :: pass_oblique !< Structure for group halo pass end type ocean_OBC_type !> Control structure for open boundaries that read from files. @@ -1886,9 +1888,13 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & To_All+Scalar_Pair) if (OBC%oblique_BCs_exist_globally) then - call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) - call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) - call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) + call create_group_pass(OBC%pass_oblique, OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + call do_group_pass(OBC%pass_oblique, G%Domain) endif if (allocated(OBC%tres_x) .and. allocated(OBC%tres_y)) then do m=1,OBC%ntr @@ -5628,6 +5634,14 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) enddo endif enddo ; endif ; endif + if (OBC%radiation_BCs_exist_globally) call pass_vector(OBC%rx_normal, OBC%ry_normal, G%Domain, & + To_All+Scalar_Pair) + if (OBC%oblique_BCs_exist_globally) then + call do_group_pass(OBC%pass_oblique, G%Domain) +! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) +! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) + endif end subroutine remap_OBC_fields From 3720b99205799216fb958608688f0283fde5a3c9 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 13 Oct 2023 14:39:50 -0600 Subject: [PATCH 452/629] Comment all omega_w2x entries --- src/core/MOM_forcing_type.F90 | 40 +++++++++---------- .../vertical/MOM_vert_friction.F90 | 36 ++++++++--------- src/user/MOM_wave_interface.F90 | 2 +- 3 files changed, 39 insertions(+), 39 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index dbac78e154..200bbd7845 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -67,7 +67,7 @@ module MOM_forcing_type ! surface stress components and turbulent velocity scale real, pointer, dimension(:,:) :: & - omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect + !omega_w2x => NULL(), & !< the counter-clockwise angle of the wind stress with respect 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 @@ -227,8 +227,8 @@ module MOM_forcing_type 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] - omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect + net_mass_src => NULL() !< The net mass source to the ocean [R Z T-1 ~> kg m-2 s-1] + !omega_w2x => NULL() !< the counter-clockwise angle of the wind stress with respect !! to the horizontal abscissa (x-coordinate) at tracer points [rad]. ! applied surface pressure from other component models (e.g., atmos, sea ice, land ice) @@ -365,7 +365,7 @@ module MOM_forcing_type integer :: id_taux = -1 integer :: id_tauy = -1 integer :: id_ustar = -1 - integer :: id_omega_w2x = -1 + !integer :: id_omega_w2x = -1 integer :: id_tau_mag = -1 integer :: id_psurf = -1 integer :: id_TKE_tidal = -1 @@ -1331,8 +1331,8 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, 'Surface friction velocity = [(gustiness + tau_magnitude)/rho0]^(1/2)', & 'm s-1', conversion=US%Z_to_m*US%s_to_T) - handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & - 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') + !handles%id_omega_w2x = register_diag_field('ocean_model', 'omega_w2x', diag%axesT1, Time, & + ! 'Counter-clockwise angle of the wind stress from the horizontal axis.', 'rad') if (present(use_berg_fluxes)) then if (use_berg_fluxes) then @@ -2170,11 +2170,11 @@ subroutine copy_common_forcing_fields(forces, fluxes, G, skip_pres) fluxes%ustar(i,j) = forces%ustar(i,j) enddo ; enddo endif - if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then - do j=js,je ; do i=is,ie - fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) - enddo ; enddo - endif + !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + ! do j=js,je ; do i=is,ie + ! fluxes%omega_w2x(i,j) = forces%omega_w2x(i,j) + ! 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) @@ -2311,11 +2311,11 @@ subroutine copy_back_forcing_fields(fluxes, forces, G) forces%ustar(i,j) = fluxes%ustar(i,j) enddo ; enddo endif - if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then - do j=js,je ; do i=is,ie - forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) - enddo ; enddo - endif + !if (associated(forces%omega_w2x) .and. associated(fluxes%omega_w2x)) then + ! do j=js,je ; do i=is,ie + ! forces%omega_w2x(i,j) = fluxes%omega_w2x(i,j) + ! 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) @@ -2964,8 +2964,8 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h if ((handles%id_ustar > 0) .and. associated(fluxes%ustar)) & call post_data(handles%id_ustar, fluxes%ustar, diag) - if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & - call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) + !if ((handles%id_omega_w2x > 0) .and. associated(fluxes%omega_w2x)) & + ! call post_data(handles%id_omega_w2x, fluxes%omega_w2x, diag) if ((handles%id_ustar_berg > 0) .and. associated(fluxes%ustar_berg)) & call post_data(handles%id_ustar_berg, fluxes%ustar_berg, diag) @@ -3292,7 +3292,7 @@ end subroutine myAlloc subroutine deallocate_forcing_type(fluxes) type(forcing), intent(inout) :: fluxes !< Forcing fields structure - if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) + !if (associated(fluxes%omega_w2x)) deallocate(fluxes%omega_w2x) 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) @@ -3352,7 +3352,7 @@ end subroutine deallocate_forcing_type subroutine deallocate_mech_forcing(forces) type(mech_forcing), intent(inout) :: forces !< Forcing fields structure - if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) + !if (associated(forces%omega_w2x)) deallocate(forces%omega_w2x) if (associated(forces%taux)) deallocate(forces%taux) if (associated(forces%tauy)) deallocate(forces%tauy) if (associated(forces%ustar)) deallocate(forces%ustar) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index f513f50158..f1485a4953 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -220,8 +220,8 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB real, dimension(SZI_(G),SZJB_(G)) :: ustar2_v !< ustar squared at v-pts [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJ_(G)) :: taux_u !< zonal wind stress at u-pts [R L Z T-2 ~> Pa] real, dimension(SZI_(G),SZJB_(G)) :: tauy_v !< meridional wind stress at v-pts [R L Z T-2 ~> Pa] - real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u !< angle between wind and x-axis at u-pts [rad] - real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v !< angle between wind and y-axis at v-pts [rad] + !real, dimension(SZIB_(G),SZJ_(G)) :: omega_w2x_u !< angle between wind and x-axis at u-pts [rad] + !real, dimension(SZI_(G),SZJB_(G)) :: omega_w2x_v !< angle between wind and y-axis at v-pts [rad] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tau_u !< kinematic zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: tau_v !< kinematic mer. mtm flux at v-pts [L2 T-2 ~> m2 s-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: tauxDG_u !< downgradient zonal mtm flux at u-pts [L2 T-2 ~> m2 s-2] @@ -270,8 +270,8 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB hbl_v(:,:) = 0. kbl_u(:,:) = 0 kbl_v(:,:) = 0 - omega_w2x_u(:,:) = 0.0 - omega_w2x_v(:,:) = 0.0 + !omega_w2x_u(:,:) = 0.0 + !omega_w2x_v(:,:) = 0.0 tauxDG_u(:,:,:) = 0.0 tauyDG_v(:,:,:) = 0.0 do j = js,je @@ -283,7 +283,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB tauy = ( G%mask2dCv(i ,j )*tauy_v(i ,j ) + G%mask2dCv(i ,j-1)*tauy_v(i ,j-1) & + G%mask2dCv(i+1,j )*tauy_v(i+1,j ) + G%mask2dCv(i+1,j-1)*tauy_v(i+1,j-1) ) / tmp ustar2_u(I,j) = sqrt( taux_u(I,j)*taux_u(I,j) + tauy*tauy ) - omega_w2x_u(I,j) = atan2( tauy , taux_u(I,j) ) + !omega_w2x_u(I,j) = atan2( tauy , taux_u(I,j) ) tauxDG_u(I,j,1) = taux_u(I,j) depth = 0.0 do k = 1, nz @@ -305,7 +305,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB taux = ( G%mask2dCu(i ,j) * taux_u(i ,j) + G%mask2dCu(i ,j+1) * taux_u(i ,j+1) & + G%mask2dCu(i-1,j) * taux_u(i-1,j) + G%mask2dCu(i-1,j+1) * taux_u(i-1,j+1)) / tmp ustar2_v(i,J) = sqrt(tauy_v(i,J)*tauy_v(i,J) + taux*taux) - omega_w2x_v(i,J) = atan2( tauy_v(i,J), taux ) + !omega_w2x_v(i,J) = atan2( tauy_v(i,J), taux ) tauyDG_v(i,J,1) = tauy_v(i,J) depth = 0.0 do k = 1, nz @@ -377,7 +377,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB do I = Isq,Ieq if( (G%mask2dCu(I,j) > 0.5) ) then ! SURFACE - tauyDG_u(I,j,1) = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) + tauyDG_u(I,j,1) = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) tau_u(I,j,1) = ustar2_u(I,j) Omega_tau2w_u(I,j,1) = 0.0 Omega_tau2s_u(I,j,1) = 0.0 @@ -386,7 +386,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB kp1 = MIN(k+1 , nz) tau_u(I,j,k+1) = sqrt( tauxDG_u(I,j,k+1)*tauxDG_u(I,j,k+1) + tauyDG_u(I,j,k+1)*tauyDG_u(I,j,k+1)) Omega_tau2x = atan2( tauyDG_u(I,j,k+1) , tauxDG_u(I,j,k+1) ) - omega_tmp = Omega_tau2x - omega_w2x_u(I,j) + omega_tmp = Omega_tau2x !- omega_w2x_u(I,j) if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi Omega_tau2w_u(I,j,k+1) = omega_tmp @@ -399,7 +399,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB do i = is, ie if( (G%mask2dCv(i,J) > 0.5) ) then ! SURFACE - tauxDG_v(i,J,1) = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) + tauxDG_v(i,J,1) = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) tau_v(i,J,1) = ustar2_v(i,J) Omega_tau2w_v(i,J,1) = 0.0 Omega_tau2s_v(i,J,1) = 0.0 @@ -408,7 +408,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB kp1 = MIN(k+1 , nz) tau_v(i,J,k+1) = sqrt ( tauxDG_v(i,J,k+1)*tauxDG_v(i,J,k+1) + tauyDG_v(i,J,k+1)*tauyDG_v(i,J,k+1) ) omega_tau2x = atan2( tauyDG_v(i,J,k+1) , tauxDG_v(i,J,k+1) ) - omega_tmp = omega_tau2x - omega_w2x_v(i,J) + omega_tmp = omega_tau2x !- omega_w2x_v(i,J) if ( (omega_tmp > pi ) ) omega_tmp = omega_tmp - 2.*pi if ( (omega_tmp < (0.-pi)) ) omega_tmp = omega_tmp + 2.*pi Omega_tau2w_v(i,J,k+1) = omega_tmp @@ -440,8 +440,8 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) ! rotate to wind coordinates - Wind_x = ustar2_u(I,j) * cos(omega_w2x_u(I,j)) - Wind_y = ustar2_u(I,j) * sin(omega_w2x_u(I,j)) + Wind_x = ustar2_u(I,j) !* cos(omega_w2x_u(I,j)) + Wind_y = ustar2_u(I,j) !* sin(omega_w2x_u(I,j)) tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) omega_w2s = atan2(tauNL_CG, tauNL_DG) @@ -465,7 +465,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB Omega_tau2s_u(I,j,k+1) = atan2(tauNL_CG , (tau_u(I,j,k+1)+tauNL_DG)) tau_u(I,j,k+1) = sqrt((tauxDG_u(I,j,k+1) + tauNL_X)**2 + (tauyDG_u(I,j,k+1) + tauNL_Y)**2) omega_tau2x = atan2((tauyDG_u(I,j,k+1) + tauNL_Y), (tauxDG_u(I,j,k+1) + tauNL_X)) - omega_tau2w = omega_tau2x - omega_w2x_u(I,j) + omega_tau2w = omega_tau2x !- omega_w2x_u(I,j) if (omega_tau2w >= pi ) omega_tau2w = omega_tau2w - 2.*pi if (omega_tau2w <= (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi Omega_tau2w_u(I,j,k+1) = omega_tau2w @@ -499,8 +499,8 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) ! rotate into wind coordinate - Wind_x = ustar2_v(i,J) * cos(omega_w2x_v(i,J)) - Wind_y = ustar2_v(i,J) * sin(omega_w2x_v(i,J)) + Wind_x = ustar2_v(i,J) !* cos(omega_w2x_v(i,J)) + Wind_y = ustar2_v(i,J) !* sin(omega_w2x_v(i,J)) tauNL_DG = (Wind_x * cos_tmp + Wind_y * sin_tmp) tauNL_CG = (Wind_y * cos_tmp - Wind_x * sin_tmp) omega_w2s = atan2(tauNL_CG , tauNL_DG) @@ -521,8 +521,8 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB ! diagnostics Omega_tau2s_v(i,J,k+1) = atan2(tauNL_CG, tau_v(i,J,k+1) + tauNL_DG) tau_v(i,J,k+1) = sqrt((tauxDG_v(i,J,k+1) + tauNL_X)**2 + (tauyDG_v(i,J,k+1) + tauNL_Y)**2) - omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X)) - omega_tau2w = omega_tau2x - omega_w2x_v(i,J) + !omega_tau2x = atan2((tauyDG_v(i,J,k+1) + tauNL_Y) , (tauxDG_v(i,J,k+1) + tauNL_X)) + !omega_tau2w = omega_tau2x - omega_w2x_v(i,J) if (omega_tau2w > pi) omega_tau2w = omega_tau2w - 2.*pi if (omega_tau2w .le. (0.-pi) ) omega_tau2w = omega_tau2w + 2.*pi Omega_tau2w_v(i,J,k+1) = omega_tau2w @@ -546,7 +546,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB if (CS%id_FPtau2s_v > 0) call post_data(CS%id_FPtau2s_v, omega_tau2s_v, CS%diag) if (CS%id_FPtau2w_u > 0) call post_data(CS%id_FPtau2w_u, omega_tau2w_u, CS%diag) if (CS%id_FPtau2w_v > 0) call post_data(CS%id_FPtau2w_v, omega_tau2w_v, CS%diag) - if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) + !if (CS%id_FPw2x > 0) call post_data(CS%id_FPw2x, forces%omega_w2x , CS%diag) end subroutine vertFPmix diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 02da5a0007..8ab82231e4 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -707,7 +707,7 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) enddo do jj=G%jsc,G%jec do ii=G%isc,G%iec - CS%Omega_w2x(ii,jj) = forces%omega_w2x(ii,jj) + !CS%Omega_w2x(ii,jj) = forces%omega_w2x(ii,jj) do b=1,CS%NumBands CS%UStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%UStkb(ii,jj,b) CS%VStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%VStkb(ii,jj,b) From 3d07e5bebf762b8d060c2df955838be9db7a07d6 Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Fri, 13 Oct 2023 14:50:08 -0600 Subject: [PATCH 453/629] Comment omega_w2x entries in nuopc_cap --- config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) 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 d59d63c439..4815cd40e2 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -298,7 +298,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & cfc=CS%use_CFC, hevap=CS%enthalpy_cpl) - call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) + !call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -704,7 +704,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) call safe_alloc_ptr(forces%p_surf,isd,ied,jsd,jed) call safe_alloc_ptr(forces%p_surf_full,isd,ied,jsd,jed) - call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) + !call safe_alloc_ptr(forces%omega_w2x,isd,ied,jsd,jed) if (CS%rigid_sea_ice) then call safe_alloc_ptr(forces%rigidity_ice_u,IsdB,IedB,jsd,jed) @@ -865,7 +865,7 @@ subroutine convert_IOB_to_forces(IOB, forces, index_bounds, Time, G, US, CS) 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)) - forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) + !forces%omega_w2x(i,j) = atan(tauy_at_h(i,j), taux_at_h(i,j)) enddo ; enddo call pass_vector(forces%taux, forces%tauy, G%Domain, halo=1) else ! C-grid wind stresses. From ead68d4984de1e64f30388a692a3fe60ce851744 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 12 Jun 2023 06:35:01 -0400 Subject: [PATCH 454/629] +Refactored diapyc_energy_req_test Refactored diapyc_energy_req_test and diapyc_energy_req_calc to remove the dependence on the Boussinesq reference density when in non-Boussinesq mode. This includes changes to the scaled units of the Kd_int argument to diapyc_energy_req_calc and the Kd argument to diapyc_energy_req_calc and the addition of a new argument to diapyc_energy_req_calc. A call to thickness_to_dz is used for the thickness unit conversions. There are 5 new internal variables, and changes to the units of several others. These routines are not actively used in MOM6 solutions, but instead they are used for testing and debugging new code, so there are no changes to solutions, but the results of these routines can differ in fully non-Boussinesq mode. --- .../vertical/MOM_diapyc_energy_req.F90 | 120 +++++++++++------- 1 file changed, 77 insertions(+), 43 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index bbc4c9bf96..32b0423cd9 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -6,13 +6,14 @@ module MOM_diapyc_energy_req !! \author By Robert Hallberg, May 2015 use MOM_diag_mediator, only : diag_ctrl, Time_type, post_data, register_diag_field +use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_grid, only : ocean_grid_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs -use MOM_verticalGrid, only : verticalGrid_type -use MOM_EOS, only : calculate_specific_vol_derivs, calculate_density +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz +use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs +use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -59,20 +60,25 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(diapyc_energy_req_CS), pointer :: CS !< This module's control structure. real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke+1), & - optional, intent(in) :: Kd_int !< Interface diffusivities [Z2 T-1 ~> m2 s-1]. + optional, intent(in) :: Kd_int !< Interface diffusivities [H Z T-1 ~> m2 s-1 or kg m-1 s-1] ! Local variables real, dimension(GV%ke) :: & T0, S0, & ! T0 & S0 are columns of initial temperatures and salinities [C ~> degC] and [S ~> ppt]. - h_col ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + h_col, & ! h_col is a column of thicknesses h at tracer points [H ~> m or kg m-2]. + dz_col ! dz_col is a column of vertical distances across layers at tracer points [Z ~> m] + real, dimension( G%isd:G%ied,GV%ke) :: & + dz_2d ! A 2-d slice of the vertical distance across layers [Z ~> m] real, dimension(GV%ke+1) :: & - Kd, & ! A column of diapycnal diffusivities at interfaces [Z2 T-1 ~> m2 s-1]. + Kd, & ! A column of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. h_top, h_bot ! Distances from the top or bottom [H ~> m or kg m-2]. + real :: dz_h_int ! The ratio of the vertical distances across the layers surrounding an interface + ! over the layer thicknesses [H Z-1 ~> nonodim or kg m-3] real :: ustar ! The local friction velocity [Z T-1 ~> m s-1] real :: absf ! The absolute value of the Coriolis parameter [T-1 ~> s-1] real :: htot ! The sum of the thicknesses [H ~> m or kg m-2]. real :: energy_Kd ! The energy used by diapycnal mixing [R Z L2 T-3 ~> W m-2]. - real :: tmp1 ! A temporary array [H Z ~> m2 or kg m-1] + real :: tmp1 ! A temporary array [H2 ~> m2 or kg2 m-6] integer :: i, j, k, is, ie, js, je, nz logical :: may_print is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -84,36 +90,56 @@ subroutine diapyc_energy_req_test(h_3d, dt, tv, G, GV, US, CS, Kd_int) "Module must be initialized before it is used.") !$OMP do - do j=js,je ; do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then - if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then - do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo - else - htot = 0.0 ; h_top(1) = 0.0 + do j=js,je + call thickness_to_dz(h_3d, tv, dz_2d, j, G, GV) + + do i=is,ie ; if (G%mask2dT(i,j) > 0.0) then + do k=1,nz T0(k) = tv%T(i,j,k) ; S0(k) = tv%S(i,j,k) h_col(k) = h_3d(i,j,k) - h_top(K+1) = h_top(K) + h_col(k) - enddo - htot = h_top(nz+1) - h_bot(nz+1) = 0.0 - do k=nz,1,-1 - h_bot(K) = h_bot(K+1) + h_col(k) + dz_col(k) = dz_2d(i,k) enddo - ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? - absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & - (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) - Kd(1) = 0.0 ; Kd(nz+1) = 0.0 - do K=2,nz - tmp1 = h_top(K) * h_bot(K) * GV%H_to_Z - Kd(K) = CS%test_Kh_scaling * & - ustar * CS%VonKar * (tmp1*ustar) / (absf*tmp1 + htot*ustar) - enddo - endif - may_print = is_root_PE() .and. (i==ie) .and. (j==je) - call diapyc_energy_req_calc(h_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & - may_print=may_print, CS=CS) - endif ; enddo ; enddo + if (present(Kd_int) .and. .not.CS%use_test_Kh_profile) then + do k=1,nz+1 ; Kd(K) = CS%test_Kh_scaling*Kd_int(i,j,K) ; enddo + else + htot = 0.0 ; h_top(1) = 0.0 + do k=1,nz + h_top(K+1) = h_top(K) + h_col(k) + enddo + htot = h_top(nz+1) + + h_bot(nz+1) = 0.0 + do k=nz,1,-1 + h_bot(K) = h_bot(K+1) + h_col(k) + enddo + + ustar = 0.01*US%m_to_Z*US%T_to_s ! Change this to being an input parameter? + absf = 0.25*((abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J))) + & + (abs(G%CoriolisBu(I-1,J-1)) + abs(G%CoriolisBu(I,J)))) + Kd(1) = 0.0 ; Kd(nz+1) = 0.0 + if (GV%Boussinesq) then + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (absf*GV%H_to_Z*tmp1 + htot*ustar) + enddo + else + do K=2,nz + tmp1 = h_top(K) * h_bot(K) + dz_h_int = (dz_2d(j,k-1) + dz_2d(j,k) + GV%dz_subroundoff) / & + (h_3d(i,j,k-1) + h_3d(i,j,k) + GV%H_subroundoff) + Kd(K) = CS%test_Kh_scaling * & + ustar * CS%VonKar * (tmp1*ustar) / (dz_h_int*absf*tmp1 + htot*ustar) + enddo + endif + endif + may_print = is_root_PE() .and. (i==ie) .and. (j==je) + call diapyc_energy_req_calc(h_col, dz_col, T0, S0, Kd, energy_Kd, dt, tv, G, GV, US, & + may_print=may_print, CS=CS) + endif ; enddo + enddo end subroutine diapyc_energy_req_test @@ -123,17 +149,19 @@ end subroutine diapyc_energy_req_test !! 4 different ways, all of which should be equivalent, but reports only one. !! The various estimates are taken because they will later be used as templates !! for other bits of code -subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & +subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv, & G, GV, US, may_print, CS) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(GV%ke), intent(in) :: h_in !< Layer thickness before entrainment, - !! [H ~> m or kg m-2]. + !! [H ~> m or kg m-2] + real, dimension(GV%ke), intent(in) :: dz_in !< Vertical distance across layers before + !! entrainment [Z ~> m] real, dimension(GV%ke), intent(in) :: T_in !< The layer temperatures [C ~> degC]. real, dimension(GV%ke), intent(in) :: S_in !< The layer salinities [S ~> ppt]. real, dimension(GV%ke+1), intent(in) :: Kd !< The interfaces diapycnal diffusivities - !! [Z2 T-1 ~> m2 s-1]. + !! [H Z T-1 ~> m2 s-1 or kg m-1 s-1]. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. real, intent(out) :: energy_Kd !< The column-integrated rate of energy !! consumption by diapycnal diffusion [R Z L2 T-3 ~> W m-2]. @@ -210,8 +238,10 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & ! in the denominator of b1 in an upward-oriented tridiagonal solver. c1_a, & ! c1_a is used by a downward-oriented tridiagonal solver [nondim]. c1_b, & ! c1_b is used by an upward-oriented tridiagonal solver [nondim]. - h_tr ! h_tr is h at tracer points with a h_neglect added to + h_tr, & ! h_tr is h at tracer points with a h_neglect added to ! ensure positive definiteness [H ~> m or kg m-2]. + dz_tr ! dz_tr is dz at tracer points with dz_neglect added to + ! ensure positive definiteness [Z ~> m] real, dimension(GV%ke+1) :: & pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! The hydrostatic interface pressure, which is used to relate @@ -251,6 +281,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & real :: ColHt_cor ! The correction to PE_chg that is made due to a net ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. + real :: dztot ! A running sum of vertical distances across layers [Z ~> m] real :: dTe_t2 ! Temporary arrays with integrated temperature changes [C H ~> degC m or degC kg m-2] real :: dSe_t2 ! Temporary arrays with integrated salinity changes [S H ~> ppt m or ppt kg m-2] real :: dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [C ~> degC]. @@ -298,11 +329,13 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & dPEb_dKd(:) = 0.0 ; dPEb_dKd_est(:) = 0.0 ; dPEb_dKd_err(:) = 0.0 dPEb_dKd_err_norm(:) = 0.0 ; dPEb_dKd_trunc(:) = 0.0 - htot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 + htot = 0.0 ; dztot = 0.0 ; pres(1) = 0.0 ; pres_Z(1) = 0.0 ; Z_int(1) = 0.0 do k=1,nz T0(k) = T_in(k) ; S0(k) = S_in(k) h_tr(k) = h_in(k) + dz_tr(k) = dz_in(k) htot = htot + h_tr(k) + dztot = dztot + dz_tr(k) pres(K+1) = pres(K) + (GV%g_Earth * GV%H_to_RZ) * h_tr(k) pres_Z(K+1) = pres(K+1) p_lay(k) = 0.5*(pres(K) + pres(K+1)) @@ -310,13 +343,14 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & enddo do k=1,nz h_tr(k) = max(h_tr(k), 1e-15*htot) + dz_tr(k) = max(dz_tr(k), 1e-15*dztot) enddo ! Introduce a diffusive flux variable, Kddt_h(K) = ea(k) = eb(k-1) Kddt_h(1) = 0.0 ; Kddt_h(nz+1) = 0.0 do K=2,nz - Kddt_h(K) = min((GV%Z_to_H**2*dt)*Kd(k) / (0.5*(h_tr(k-1) + h_tr(k))), 1e3*htot) + Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) enddo ! Solve the tridiagonal equations for new temperatures. @@ -962,7 +996,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(T0(k-1) + T0(k)), 0.5*(S0(k-1) + S0(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (T0(k-1) - T0(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (S0(k-1) - S0(k)) ) enddo @@ -973,7 +1007,7 @@ subroutine diapyc_energy_req_calc(h_in, T_in, S_in, Kd, energy_Kd, dt, tv, & do K=2,nz call calculate_density(0.5*(Tf(k-1) + Tf(k)), 0.5*(Sf(k-1) + Sf(k)), & pres(K), rho_here, tv%eqn_of_state) - N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*GV%H_to_Z*(h_tr(k-1) + h_tr(k)))) * & + N2(K) = ((US%L_to_Z**2*GV%g_Earth) * rho_here / (0.5*(dz_tr(k-1) + dz_tr(k)))) * & ( 0.5*(dSV_dT(k-1) + dSV_dT(k)) * (Tf(k-1) - Tf(k)) + & 0.5*(dSV_dS(k-1) + dSV_dS(k)) * (Sf(k-1) - Sf(k)) ) enddo From 43a4fa9d48194abd6d56af43db67186d9db59389 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 7 Oct 2023 08:36:03 -0400 Subject: [PATCH 455/629] Refactor diapyc_energy_req_calc and find_PE_chg Modified the MOM_diapyc_energy_req.F90 version of find_PE_chg to align more closely with the version in MOM_energetic_PBL.F90, including making PE_chg into a mandatory argument, changing the name of the ColHt_cor argument to PE_ColHt_cor, and modifying some variable descriptions in units. Also removed find_PE_chg_orig from MOM_diapyc_energy_req.F90 and the old_PE_calc code that calls it. Extra values were also added to Te, Te_a and Te_b and the equivalent salinity variables so that the logical branches at (K==2) and (K=nz) could be simplied out of diapyc_energy_req_calc. Because old_PE_calc had been hard-coded to .false., all answers are bitwise identical. --- .../vertical/MOM_diapyc_energy_req.F90 | 548 ++++-------------- 1 file changed, 121 insertions(+), 427 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 index 32b0423cd9..7ca432fea4 100644 --- a/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 +++ b/src/parameterizations/vertical/MOM_diapyc_energy_req.F90 @@ -185,11 +185,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dSV_dT, & ! Partial derivative of specific volume with temperature [R-1 C-1 ~> m3 kg-1 degC-1]. dSV_dS, & ! Partial derivative of specific volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. T0, S0, & ! Initial temperatures and salinities [C ~> degC] and [S ~> ppt]. - Te, Se, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] - Te_a, Se_a, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] - Te_b, Se_b, & ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] Tf, Sf, & ! New final values of the temperatures and salinities [C ~> degC] and [S ~> ppt]. - dTe, dSe, & ! Running (1-way) estimates of temperature and salinity change [C ~> degC] and [S ~> ppt]. Th_a, & ! An effective temperature times a thickness in the layer above, including implicit ! mixing effects with other yet higher layers [C H ~> degC m or degC kg m-2]. Sh_a, & ! An effective salinity times a thickness in the layer above, including implicit @@ -242,6 +238,14 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! ensure positive definiteness [H ~> m or kg m-2]. dz_tr ! dz_tr is dz at tracer points with dz_neglect added to ! ensure positive definiteness [Z ~> m] + ! Note that the following arrays have extra (ficticious) layers above or below the + ! water column for code convenience + real, dimension(0:GV%ke+1) :: & + Te, Se ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(0:GV%ke) :: & + Te_a, Se_a ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] + real, dimension(GV%ke+1) :: & + Te_b, Se_b ! Running incomplete estimates of the new temperatures and salinities [C ~> degC] and [S ~> ppt] real, dimension(GV%ke+1) :: & pres, & ! Interface pressures [R L2 T-2 ~> Pa]. pres_Z, & ! The hydrostatic interface pressure, which is used to relate @@ -268,10 +272,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv real :: dKd ! The change in the value of Kddt_h [H ~> m or kg m-2]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. - real :: dTe_term ! A diffusivity-independent term related to the temperature - ! change in the layer below the interface [C H ~> degC m or degC kg m-2]. - real :: dSe_term ! A diffusivity-independent term related to the salinity - ! change in the layer below the interface [S H ~> ppt m or ppt kg m-2]. real :: Kddt_h_guess ! A guess of the final value of Kddt_h [H ~> m or kg m-2]. real :: dMass ! The mass per unit area within a layer [R Z ~> kg m-2]. real :: dPres ! The hydrostatic pressure change across a layer [R L2 T-2 ~> Pa]. @@ -282,10 +282,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! change in the column height [R L2 Z T-2 ~> J m-2]. real :: htot ! A running sum of thicknesses [H ~> m or kg m-2]. real :: dztot ! A running sum of vertical distances across layers [Z ~> m] - real :: dTe_t2 ! Temporary arrays with integrated temperature changes [C H ~> degC m or degC kg m-2] - real :: dSe_t2 ! Temporary arrays with integrated salinity changes [S H ~> ppt m or ppt kg m-2] - real :: dT_km1_t2, dT_k_t2 ! Temporary arrays describing temperature changes [C ~> degC]. - real :: dS_km1_t2, dS_k_t2 ! Temporary arrays describing salinity changes [S ~> ppt]. logical :: do_print ! The following are a bunch of diagnostic arrays for debugging purposes. @@ -313,7 +309,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv integer :: k, nz, itt, k_cent logical :: surface_BL, bottom_BL, central, halves, debug - logical :: old_PE_calc nz = GV%ke h_neglect = GV%H_subroundoff @@ -353,6 +348,13 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv Kddt_h(K) = min(dt * Kd(k) / (0.5*(dz_tr(k-1) + dz_tr(k))), 1e3*dztot) enddo + ! Zero out the temperature and salinity estimates in the extra (ficticious) layers. + ! The actual values set here are irrelevant (so long as they are not NaNs) because they + ! are always multiplied by a zero value of Kddt_h reflecting the no-flux boundary condition. + Te(0) = 0.0 ; Se(0) = 0.0 ; Te(nz+1) = 0.0 ; Se(nz+1) = 0.0 + Te_a(0) = 0.0 ; Se_a(0) = 0.0 + Te_b(nz+1) = 0.0 ; Se_b(nz+1) = 0.0 + ! Solve the tridiagonal equations for new temperatures. call calculate_specific_vol_derivs(T0, S0, p_lay, dSV_dT, dSV_dS, tv%eqn_of_state) @@ -371,7 +373,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv PE_chg_k(:,:) = 0.0 ; ColHt_cor_k(:,:) = 0.0 if (surface_BL) then ! This version is appropriate for a surface boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -387,71 +388,32 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==2) then - dT_km1_t2 = (T0(k)-T0(k-1)) - dS_km1_t2 = (S0(k)-S0(k-1)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K-1) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dSe_t2 = Kddt_h(K-1) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - dT_km1_t2 = (T0(k)-T0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((T0(k-2) - T0(k-1)) + dTe(k-2)) - dS_km1_t2 = (S0(k)-S0(k-1)) - & - (Kddt_h(K-1) / hp_a(k-1)) * ((S0(k-2) - S0(k-1)) + dSe(k-2)) - endif - dTe_term = dTe_t2 + hp_a(k-1) * (T0(k-1)-T0(k)) - dSe_term = dSe_t2 + hp_a(k-1) * (S0(k-1)-S0(k)) - else - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) - endif - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg_k(k,1), dPEa_dKd(k)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & - ColHt_cor=ColHt_cor_k(K,1)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,1), dPEc_dKd=dPEa_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,1)) if (debug) then do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k), hp_a(k-1), & - dTe_term, dSe_term, dT_km1_t2, dS_km1_t2, & - dT_to_dPE(k), dS_to_dPE(k), dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), & - pres_Z(K), dT_to_dColHt(k), dS_to_dColHt(k), & - dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg(itt)) enddo ! Compare with a 4th-order finite difference estimate. dPEa_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -468,17 +430,8 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_a(k-1) + Kddt_h(K)) c1_a(K) = Kddt_h(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) - endif - if (old_PE_calc) then - dTe(k-1) = b1 * ( Kddt_h(K)*(T0(k)-T0(k-1)) + dTe_t2 ) - dSe(k-1) = b1 * ( Kddt_h(K)*(S0(k)-S0(k-1)) + dSe_t2 ) - endif + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -491,10 +444,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_a(nz)) Tf(nz) = b1 * (h_tr(nz) * T0(nz) + Kddt_h(nz) * Te(nz-1)) Sf(nz) = b1 * (h_tr(nz) * S0(nz) + Kddt_h(nz) * Se(nz-1)) - if (old_PE_calc) then - dTe(nz) = b1 * Kddt_h(nz) * ((T0(nz-1)-T0(nz)) + dTe(nz-1)) - dSe(nz) = b1 * Kddt_h(nz) * ((S0(nz-1)-S0(nz)) + dSe(nz-1)) - endif do k=nz-1,1,-1 Tf(k) = Te(k) + c1_a(K+1)*Tf(k+1) @@ -517,7 +466,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv endif if (bottom_BL) then ! This version is appropriate for a bottom boundary layer. - old_PE_calc = .false. ! Set up values appropriate for no diffusivity. do k=1,nz @@ -533,71 +481,32 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! on how much energy is available. ! Precalculate some temporary expressions that are independent of Kddt_h_guess. - if (old_PE_calc) then - if (K==nz) then - dT_k_t2 = (T0(k-1)-T0(k)) - dS_k_t2 = (S0(k-1)-S0(k)) - dTe_t2 = 0.0 ; dSe_t2 = 0.0 - else - dTe_t2 = Kddt_h(K+1) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dSe_t2 = Kddt_h(K+1) * ((S0(k+1) - S0(k)) + dSe(k+1)) - dT_k_t2 = (T0(k-1)-T0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((T0(k+1) - T0(k)) + dTe(k+1)) - dS_k_t2 = (S0(k-1)-S0(k)) - & - (Kddt_h(k+1)/ hp_b(k)) * ((S0(k+1) - S0(k)) + dSe(k+1)) - endif - dTe_term = dTe_t2 + hp_b(k) * (T0(k)-T0(k-1)) - dSe_term = dSe_t2 + hp_b(k) * (S0(k)-S0(k-1)) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1) - endif - endif + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1) ! Find the energy change due to a guess at the strength of diffusion at interface K. Kddt_h_guess = Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & - ColHt_cor=ColHt_cor_k(K,2)) - endif + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & + dT_to_dColHt_b(k), dS_to_dColHt_b(k), & + PE_chg=PE_chg_k(K,2), dPEc_dKd=dPEb_dKd(K), & + PE_ColHt_cor=ColHt_cor_k(K,2)) if (debug) then ! Compare with a 4th-order finite difference estimate. do itt=1,5 Kddt_h_guess = (1.0+0.01*(itt-3))*Kddt_h(K) - if (old_PE_calc) then - call find_PE_chg_orig(Kddt_h_guess, h_tr(k-1), hp_b(k), & - dTe_term, dSe_term, dT_k_t2, dS_k_t2, & - dT_to_dPE(k-1), dS_to_dPE(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt(k-1), dS_to_dColHt(k-1), & + call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & + Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & + dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & + pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & PE_chg=PE_chg(itt)) - else - call find_PE_chg(0.0, Kddt_h_guess, hp_a(k-1), hp_b(k), & - Th_a(k-1), Sh_a(k-1), Th_b(k), Sh_b(k), & - dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & - pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & - dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_chg(itt)) - endif enddo dPEb_dKd_est(k) = (4.0*(PE_chg(4)-Pe_chg(2))/(0.02*Kddt_h(K)) - & @@ -614,17 +523,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_b(k) + Kddt_h(K)) c1_b(K) = Kddt_h(K) * b1 - if (k==nz) then - Te(nz) = b1* (h_tr(nz)*T0(nz)) - Se(nz) = b1* (h_tr(nz)*S0(nz)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(k+1) * Se(k+1)) - endif - if (old_PE_calc) then - dTe(k) = b1 * ( Kddt_h(K)*(T0(k-1)-T0(k)) + dTe_t2 ) - dSe(k) = b1 * ( Kddt_h(K)*(S0(k-1)-S0(k)) + dSe_t2 ) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kddt_h(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kddt_h(K+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -637,10 +538,6 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_b(1)) Tf(1) = b1 * (h_tr(1) * T0(1) + Kddt_h(2) * Te(2)) Sf(1) = b1 * (h_tr(1) * S0(1) + Kddt_h(2) * Se(2)) - if (old_PE_calc) then - dTe(1) = b1 * Kddt_h(2) * ((T0(2)-T0(1)) + dTe(2)) - dSe(1) = b1 * Kddt_h(2) * ((S0(2)-S0(1)) + dSe(2)) - endif do k=2,nz Tf(k) = Te(k) + c1_b(K)*Tf(k-1) @@ -678,12 +575,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) Kddt_h_a(K) = 0.0 ; if (K < K_cent) Kddt_h_a(K) = Kddt_h(K) @@ -694,19 +588,15 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_change ColHt_cor_k(K,3) = ColHt_cor b1 = 1.0 / (hp_a(k-1) + Kddt_h_a(K)) c1_a(K) = Kddt_h_a(K) * b1 - if (k==2) then - Te_a(1) = b1*(h_tr(1)*T0(1)) - Se_a(1) = b1*(h_tr(1)*S0(1)) - else - Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) - Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) - endif + + Te_a(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kddt_h_a(K-1) * Te_a(k-2)) + Se_a(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kddt_h_a(K-1) * Se_a(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kddt_h_a(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -720,18 +610,13 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). -! if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) -! else -! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) -! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) -! endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) +! Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) +! Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) Kddt_h_b(K) = 0.0 ; if (K > K_cent) Kddt_h_b(K) = Kddt_h(K) dKd = Kddt_h_b(K) @@ -741,19 +626,15 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor b1 = 1.0 / (hp_b(k) + Kddt_h_b(K)) c1_b(K) = Kddt_h_b(K) * b1 - if (k==nz) then - Te_b(k) = b1 * (h_tr(k)*T0(k)) - Se_b(k) = b1 * (h_tr(k)*S0(k)) - else - Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) - Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(k+1) * Se_b(k+1)) - endif + + Te_b(k) = b1 * (h_tr(k) * T0(k) + Kddt_h_b(K+1) * Te_b(k+1)) + Se_b(k) = b1 * (h_tr(k) * S0(k) + Kddt_h_b(K+1) * Se_b(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kddt_h_b(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -768,18 +649,11 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = 0.0 ! This might need to be changed - it is the already applied value of Kddt_h(K). - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(k+1) * Se_b(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kddt_h(K-1) * Te_a(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kddt_h(K-1) * Se_a(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kddt_h(K+1) * Te_b(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kddt_h(K+1) * Se_b(k+1) dKd = Kddt_h(K) @@ -788,7 +662,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,3) = PE_chg_k(K,3) + PE_change ColHt_cor_k(K,3) = ColHt_cor_k(K,3) + ColHt_cor @@ -854,16 +728,12 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv enddo ! Calculate the dependencies on layers above. - Kddt_h_a(1) = 0.0 do K=2,nz ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) dKd = 0.5 * Kddt_h(K) - Kd_so_far(K) @@ -873,7 +743,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_change ColHt_cor_k(K,4) = ColHt_cor @@ -882,13 +752,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_a(k-1) + Kd_so_far(K)) c1_a(K) = Kd_so_far(K) * b1 - if (k==2) then - Te(1) = b1*(h_tr(1)*T0(1)) - Se(1) = b1*(h_tr(1)*S0(1)) - else - Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) - Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) - endif + + Te(k-1) = b1 * (h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2)) + Se(k-1) = b1 * (h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2)) hp_a(k) = h_tr(k) + (hp_a(k-1) * b1) * Kd_so_far(K) dT_to_dPE_a(k) = dT_to_dPE(k) + c1_a(K)*dT_to_dPE_a(k-1) @@ -901,18 +767,11 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv do K=nz,2,-1 ! Loop over interior interfaces. ! First calculate some terms that are independent of the change in Kddt_h(K). Kd0 = Kd_so_far(K) - if (K<=2) then - Th_a(k-1) = h_tr(k-1) * T0(k-1) ; Sh_a(k-1) = h_tr(k-1) * S0(k-1) - else - Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) - Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) - endif - if (K>=nz) then - Th_b(k) = h_tr(k) * T0(k) ; Sh_b(k) = h_tr(k) * S0(k) - else - Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) - Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) - endif + + Th_a(k-1) = h_tr(k-1) * T0(k-1) + Kd_so_far(K-1) * Te(k-2) + Sh_a(k-1) = h_tr(k-1) * S0(k-1) + Kd_so_far(K-1) * Se(k-2) + Th_b(k) = h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1) + Sh_b(k) = h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1) dKd = Kddt_h(K) - Kd_so_far(K) @@ -921,7 +780,7 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv dT_to_dPE_a(k-1), dS_to_dPE_a(k-1), dT_to_dPE_b(k), dS_to_dPE_b(k), & pres_Z(K), dT_to_dColHt_a(k-1), dS_to_dColHt_a(k-1), & dT_to_dColHt_b(k), dS_to_dColHt_b(k), & - PE_chg=PE_change, ColHt_cor=ColHt_cor) + PE_chg=PE_change, PE_ColHt_cor=ColHt_cor) PE_chg_k(K,4) = PE_chg_k(K,4) + PE_change ColHt_cor_k(K,4) = ColHt_cor_k(K,4) + ColHt_cor @@ -931,13 +790,9 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv b1 = 1.0 / (hp_b(k) + Kd_so_far(K)) c1_b(K) = Kd_so_far(K) * b1 - if (k==nz) then - Te(k) = b1 * (h_tr(k)*T0(k)) - Se(k) = b1 * (h_tr(k)*S0(k)) - else - Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) - Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) - endif + + Te(k) = b1 * (h_tr(k) * T0(k) + Kd_so_far(K+1) * Te(k+1)) + Se(k) = b1 * (h_tr(k) * S0(k) + Kd_so_far(k+1) * Se(k+1)) hp_b(k-1) = h_tr(k-1) + (hp_b(k) * b1) * Kd_so_far(K) dT_to_dPE_b(k-1) = dT_to_dPE(k-1) + c1_b(K)*dT_to_dPE_b(k) @@ -1018,11 +873,11 @@ subroutine diapyc_energy_req_calc(h_in, dz_in, T_in, S_in, Kd, energy_Kd, dt, tv end subroutine diapyc_energy_req_calc !> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep. +!! for several changes in an interface's diapycnal diffusivity times a timestep. subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & dT_to_dPE_a, dS_to_dPE_a, dT_to_dPE_b, dS_to_dPE_b, & pres_Z, dT_to_dColHt_a, dS_to_dColHt_a, dT_to_dColHt_b, dS_to_dColHt_b, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, ColHt_cor) + PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0, PE_ColHt_cor) real, intent(in) :: Kddt_h0 !< The previously used diffusivity at an interface times !! the time step and divided by the average of the !! thicknesses around the interface [H ~> m or kg m-2]. @@ -1050,22 +905,22 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! below, including implicit mixing effects with other !! yet lower layers [S H ~> ppt m or ppt kg m-2]. real, intent(in) :: dT_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_a !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. real, intent(in) :: dT_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. + !! a layer's temperature change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. real, intent(in) :: dS_to_dPE_b !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate + !! a layer's salinity change to the change in column potential + !! energy, including all implicit diffusive changes in the + !! salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. + real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which relates !! the changes in column thickness to the energy that is radiated !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. real, intent(in) :: dT_to_dColHt_a !< A factor (mass_lay*dSColHtc_vol/dT) relating @@ -1085,8 +940,8 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! height, including all implicit diffusive changes !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. + real, intent(out) :: PE_chg !< The change in column potential energy from applying + !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could @@ -1094,17 +949,18 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & !! present interface [R Z L2 T-2 ~> J m-2]. real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: ColHt_cor !< The correction to PE_chg that is made due to a net + real, optional, intent(out) :: PE_ColHt_cor !< The correction to PE_chg that is made due to a net !! change in the column height [R Z L2 T-2 ~> J m-2]. + ! Local variables real :: hps ! The sum of the two effective pivot thicknesses [H ~> m or kg m-2]. real :: bdt1 ! A product of the two pivot thicknesses plus a diffusive term [H2 ~> m2 or kg2 m-4]. real :: dT_c ! The core term in the expressions for the temperature changes [C H2 ~> degC m2 or degC kg2 m-4]. - real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> psu m2 or psu kg2 m-4]. + real :: dS_c ! The core term in the expressions for the salinity changes [S H2 ~> ppt m2 or ppt kg2 m-4]. real :: PEc_core ! The diffusivity-independent core term in the expressions - ! for the potential energy changes [R L2 T-2 ~> J m-3]. + ! for the potential energy changes [H3 R Z L2 T-2 ~> J m or J kg3 m-8]. real :: ColHt_core ! The diffusivity-independent core term in the expressions - ! for the column height changes [R L2 T-2 ~> J m-3]. + ! for the column height changes [H3 Z ~> m4 or kg3 m-5]. real :: ColHt_chg ! The change in the column height [Z ~> m]. real :: y1_3 ! A local temporary term in [H-3 ~> m-3 or m6 kg-3]. real :: y1_4 ! A local temporary term in [H-4 ~> m-4 or m8 kg-4]. @@ -1112,7 +968,7 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ! The expression for the change in potential energy used here is derived ! from the expression for the final estimates of the changes in temperature ! and salinities, and then extensively manipulated to get it into its most - ! succint form. The derivation is not necessarily obvious, but it demonstrably + ! succinct form. The derivation is not necessarily obvious, but it demonstrably ! works by comparison with separate calculations of the energy changes after ! the tridiagonal solver for the final changes in temperature and salinity are ! applied. @@ -1126,18 +982,14 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & ColHt_core = hp_b * (dT_to_dColHt_a * dT_c + dS_to_dColHt_a * dS_c) - & hp_a * (dT_to_dColHt_b * dT_c + dS_to_dColHt_b * dS_c) - if (present(PE_chg)) then - ! Find the change in column potential energy due to the change in the - ! diffusivity at this interface by dKddt_h. - y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - PE_chg = PEc_core * y1_3 - ColHt_chg = ColHt_core * y1_3 - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - if (present(ColHt_cor)) ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) - elseif (present(ColHt_cor)) then - y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) - ColHt_cor = -pres_Z * min(ColHt_core * y1_3, 0.0) - endif + ! Find the change in column potential energy due to the change in the + ! diffusivity at this interface by dKddt_h. + y1_3 = dKddt_h / (bdt1 * (bdt1 + dKddt_h * hps)) + PE_chg = PEc_core * y1_3 + ColHt_chg = ColHt_core * y1_3 + if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg + + if (present(PE_ColHt_cor)) PE_ColHt_cor = -pres_Z * min(ColHt_chg, 0.0) if (present(dPEc_dKd)) then ! Find the derivative of the potential energy change with dKddt_h. @@ -1166,164 +1018,6 @@ subroutine find_PE_chg(Kddt_h0, dKddt_h, hp_a, hp_b, Th_a, Sh_a, Th_b, Sh_b, & end subroutine find_PE_chg -!> This subroutine calculates the change in potential energy and or derivatives -!! for several changes in an interfaces's diapycnal diffusivity times a timestep -!! using the original form used in the first version of ePBL. -subroutine find_PE_chg_orig(Kddt_h, h_k, b_den_1, dTe_term, dSe_term, & - dT_km1_t2, dS_km1_t2, dT_to_dPE_k, dS_to_dPE_k, & - dT_to_dPEa, dS_to_dPEa, pres_Z, dT_to_dColHt_k, & - dS_to_dColHt_k, dT_to_dColHta, dS_to_dColHta, & - PE_chg, dPEc_dKd, dPE_max, dPEc_dKd_0) - real, intent(in) :: Kddt_h !< The diffusivity at an interface times the time step and - !! divided by the average of the thicknesses around the - !! interface [H ~> m or kg m-2]. - real, intent(in) :: h_k !< The thickness of the layer below the interface [H ~> m or kg m-2]. - real, intent(in) :: b_den_1 !< The first term in the denominator of the pivot - !! for the tridiagonal solver, given by h_k plus a term that - !! is a fraction (determined from the tridiagonal solver) of - !! Kddt_h for the interface above [H ~> m or kg m-2]. - real, intent(in) :: dTe_term !< A diffusivity-independent term related to the temperature change - !! in the layer below the interface [C H ~> degC m or degC kg m-2]. - real, intent(in) :: dSe_term !< A diffusivity-independent term related to the salinity change - !! in the layer below the interface [S H ~> ppt m or ppt kg m-2]. - real, intent(in) :: dT_km1_t2 !< A diffusivity-independent term related to the - !! temperature change in the layer above the interface [C ~> degC]. - real, intent(in) :: dS_km1_t2 !< A diffusivity-independent term related to the - !! salinity change in the layer above the interface [S ~> ppt]. - real, intent(in) :: pres_Z !< The hydrostatic interface pressure, which is used to relate - !! the changes in column thickness to the energy that is radiated - !! as gravity waves and unavailable to drive mixing [R L2 T-2 ~> J m-3]. - real, intent(in) :: dT_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers below [R Z L2 T-2 C-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPE_k !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers below [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dT) relating - !! a layer's temperature change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the temperatures of all the layers above [R Z L2 T-2 C-1 ~> J m-2 degC-1]. - real, intent(in) :: dS_to_dPEa !< A factor (pres_lay*mass_lay*dSpec_vol/dS) relating - !! a layer's salinity change to the change in column - !! potential energy, including all implicit diffusive changes - !! in the salinities of all the layers above [R Z L2 T-2 S-1 ~> J m-2 ppt-1]. - real, intent(in) :: dT_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers below [Z C-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHt_k !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers below [Z S-1 ~> m ppt-1]. - real, intent(in) :: dT_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dT) relating - !! a layer's temperature change to the change in column - !! height, including all implicit diffusive changes - !! in the temperatures of all the layers above [Z C-1 ~> m degC-1]. - real, intent(in) :: dS_to_dColHta !< A factor (mass_lay*dSColHtc_vol/dS) relating - !! a layer's salinity change to the change in column - !! height, including all implicit diffusive changes - !! in the salinities of all the layers above [Z S-1 ~> m ppt-1]. - - real, optional, intent(out) :: PE_chg !< The change in column potential energy from applying - !! Kddt_h at the present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd !< The partial derivative of PE_chg with Kddt_h, - !! [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - real, optional, intent(out) :: dPE_max !< The maximum change in column potential energy that could - !! be realized by applying a huge value of Kddt_h at the - !! present interface [R Z L2 T-2 ~> J m-2]. - real, optional, intent(out) :: dPEc_dKd_0 !< The partial derivative of PE_chg with Kddt_h in the - !! limit where Kddt_h = 0 [R Z L2 T-2 H-1 ~> J m-3 or J kg-1]. - -! This subroutine determines the total potential energy change due to mixing -! at an interface, including all of the implicit effects of the prescribed -! mixing at interfaces above. Everything here is derived by careful manipulation -! of the robust tridiagonal solvers used for tracers by MOM6. The results are -! positive for mixing in a stably stratified environment. -! The comments describing these arguments are for a downward mixing pass, but -! this routine can also be used for an upward pass with the sense of direction -! reversed. - - real :: b1 ! b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - real :: b1Kd ! Temporary array [nondim] - real :: ColHt_chg ! The change in column thickness [Z ~> m]. - real :: dColHt_max ! The change in column thickness for infinite diffusivity [Z ~> m]. - real :: dColHt_dKd ! The partial derivative of column thickness with Kddt_h [Z H-1 ~> nondim or m3 kg-1] - real :: dT_k, dT_km1 ! Temperature changes in layers k and k-1 [C ~> degC] - real :: dS_k, dS_km1 ! Salinity changes in layers k and k-1 [S ~> ppt] - real :: I_Kr_denom ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: dKr_dKd ! Temporary array [H-2 ~> m-2 or m4 kg-2] - real :: ddT_k_dKd, ddT_km1_dKd ! Temporary arrays indicating the temperature changes - ! per unit change in Kddt_h [C H-1 ~> degC m-1 or degC m2 kg-1] - real :: ddS_k_dKd, ddS_km1_dKd ! Temporary arrays indicating the salinity changes - ! per unit change in Kddt_h [S H-1 ~> ppt m-1 or ppt m2 kg-1] - - b1 = 1.0 / (b_den_1 + Kddt_h) - b1Kd = Kddt_h*b1 - - ! Start with the temperature change in layer k-1 due to the diffusivity at - ! interface K without considering the effects of changes in layer k. - - ! Calculate the change in PE due to the diffusion at interface K - ! if Kddt_h(K+1) = 0. - I_Kr_denom = 1.0 / (h_k*b_den_1 + (b_den_1 + h_k)*Kddt_h) - - dT_k = (Kddt_h*I_Kr_denom) * dTe_term - dS_k = (Kddt_h*I_Kr_denom) * dSe_term - - if (present(PE_chg)) then - ! Find the change in energy due to diffusion with strength Kddt_h at this interface. - ! Increment the temperature changes in layer k-1 due the changes in layer k. - dT_km1 = b1Kd * ( dT_k + dT_km1_t2 ) - dS_km1 = b1Kd * ( dS_k + dS_km1_t2 ) - - PE_chg = (dT_to_dPE_k * dT_k + dT_to_dPEa * dT_km1) + & - (dS_to_dPE_k * dS_k + dS_to_dPEa * dS_km1) - ColHt_chg = (dT_to_dColHt_k * dT_k + dT_to_dColHta * dT_km1) + & - (dS_to_dColHt_k * dS_k + dS_to_dColHta * dS_km1) - if (ColHt_chg < 0.0) PE_chg = PE_chg - pres_Z * ColHt_chg - endif - - if (present(dPEc_dKd)) then - ! Find the derivatives of the temperature and salinity changes with Kddt_h. - dKr_dKd = (h_k*b_den_1) * I_Kr_denom**2 - - ddT_k_dKd = dKr_dKd * dTe_term - ddS_k_dKd = dKr_dKd * dSe_term - ddT_km1_dKd = (b1**2 * b_den_1) * ( dT_k + dT_km1_t2 ) + b1Kd * ddT_k_dKd - ddS_km1_dKd = (b1**2 * b_den_1) * ( dS_k + dS_km1_t2 ) + b1Kd * ddS_k_dKd - - ! Calculate the partial derivative of Pe_chg with Kddt_h. - dPEc_dKd = (dT_to_dPE_k * ddT_k_dKd + dT_to_dPEa * ddT_km1_dKd) + & - (dS_to_dPE_k * ddS_k_dKd + dS_to_dPEa * ddS_km1_dKd) - dColHt_dKd = (dT_to_dColHt_k * ddT_k_dKd + dT_to_dColHta * ddT_km1_dKd) + & - (dS_to_dColHt_k * ddS_k_dKd + dS_to_dColHta * ddS_km1_dKd) - if (dColHt_dKd < 0.0) dPEc_dKd = dPEc_dKd - pres_Z * dColHt_dKd - endif - - if (present(dPE_max)) then - ! This expression is the limit of PE_chg for infinite Kddt_h. - dPE_max = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) + & - ((dT_to_dPE_k + dT_to_dPEa) * dTe_term + & - (dS_to_dPE_k + dS_to_dPEa) * dSe_term) / (b_den_1 + h_k) - dColHt_max = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) + & - ((dT_to_dColHt_k + dT_to_dColHta) * dTe_term + & - (dS_to_dColHt_k + dS_to_dColHta) * dSe_term) / (b_den_1 + h_k) - if (dColHt_max < 0.0) dPE_max = dPE_max - pres_Z*dColHt_max - endif - - if (present(dPEc_dKd_0)) then - ! This expression is the limit of dPEc_dKd for Kddt_h = 0. - dPEc_dKd_0 = (dT_to_dPEa * dT_km1_t2 + dS_to_dPEa * dS_km1_t2) / (b_den_1) + & - (dT_to_dPE_k * dTe_term + dS_to_dPE_k * dSe_term) / (h_k*b_den_1) - dColHt_dKd = (dT_to_dColHta * dT_km1_t2 + dS_to_dColHta * dS_km1_t2) / (b_den_1) + & - (dT_to_dColHt_k * dTe_term + dS_to_dColHt_k * dSe_term) / (h_k*b_den_1) - if (dColHt_dKd < 0.0) dPEc_dKd_0 = dPEc_dKd_0 - pres_Z*dColHt_dKd - endif - -end subroutine find_PE_chg_orig - !> Initialize parameters and allocate memory associated with the diapycnal energy requirement module. subroutine diapyc_energy_req_init(Time, G, GV, US, param_file, diag, CS) type(time_type), intent(in) :: Time !< model time From 475590dbc4d736fd45a29748577351f2eb58fc57 Mon Sep 17 00:00:00 2001 From: Pavel Perezhogin <35234405+Pperezhogin@users.noreply.github.com> Date: Thu, 19 Oct 2023 16:30:23 -0400 Subject: [PATCH 456/629] Acceleration of Zanna-Bolton-2020 parameterization and new features required for NW2 (#484) * Update of Zanna-Bolton-2020 closure: code optimization and features required in NW2 configuration * Resolving compilation errors and doxygen by Alistair * Remove force sync for clock * Change naming of functions according to MOM_Zanna_bolton module --- .../lateral/MOM_Zanna_Bolton.F90 | 1509 +++++++++-------- .../lateral/MOM_hor_visc.F90 | 47 +- 2 files changed, 837 insertions(+), 719 deletions(-) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index 500e4a508c..b49d123377 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -1,23 +1,26 @@ -! > Calculates Zanna and Bolton 2020 parameterization +!> Calculates Zanna and Bolton 2020 parameterization +!! Implemented by Perezhogin P.A. Contact: pperezhogin@gmail.com module MOM_Zanna_Bolton +! This file is part of MOM6. See LICENSE.md for the license. 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 : create_group_pass, do_group_pass, group_pass_type, & + start_group_pass, complete_group_pass 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 +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_MODULE, CLOCK_ROUTINE implicit none ; private #include -public Zanna_Bolton_2020, ZB_2020_init +public ZB2020_lateral_stress, ZB2020_init, ZB2020_end, ZB2020_copy_gradient_and_thickness !> Control structure for Zanna-Bolton-2020 parameterization. type, public :: ZB2020_CS ; private @@ -31,50 +34,86 @@ module MOM_Zanna_Bolton 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] + real :: Klower_R_diss !< Attenuation of + !! the ZB parameterization in the regions of + !! geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019) + !! Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))) + !! R_diss=-1: attenuation is not used; typical value R_diss=1.0 [nondim] + integer :: Klower_shear !< Type of expression for shear in Klower formula + !! 0: sqrt(sh_xx**2 + sh_xy**2) + !! 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + integer :: Marching_halo !< The number of filter iterations per a single MPI + !! exchange + + real, dimension(:,:,:), allocatable :: & + sh_xx, & !< Horizontal tension (du/dx - dv/dy) in h (CENTER) + !! points including metric terms [T-1 ~> s-1] + sh_xy, & !< Horizontal shearing strain (du/dy + dv/dx) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + vort_xy, & !< Vertical vorticity (dv/dx - du/dy) in q (CORNER) + !! points including metric terms [T-1 ~> s-1] + hq !< Thickness in CORNER points [H ~> m or kg m-2] + + real, dimension(:,:,:), allocatable :: & + Txx, & !< Subgrid stress xx component in h [L2 T-2 ~> m2 s-2] + Tyy, & !< Subgrid stress yy component in h [L2 T-2 ~> m2 s-2] + Txy !< Subgrid stress xy component in q [L2 T-2 ~> m2 s-2] + + real, dimension(:,:), allocatable :: & + kappa_h, & !< Scaling coefficient in h points [L2 ~> m2] + kappa_q !< Scaling coefficient in q points [L2 ~> m2] + + real, allocatable :: & + ICoriolis_h(:,:), & !< Inverse Coriolis parameter at h points [T ~> s] + c_diss(:,:,:) !< Attenuation parameter at h points + !! (Klower 2018, Juricke2019,2020) [nondim] + + real, dimension(:,:), allocatable :: & + maskw_h, & !< Mask of land point at h points multiplied by filter weight [nondim] + maskw_q !< Same mask but for q points [nondim] 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_11 = -1 - integer :: id_S_22 = -1 - integer :: id_S_12 = -1 + integer :: id_Txx = -1 + integer :: id_Tyy = -1 + integer :: id_Txy = -1 + integer :: id_cdiss = -1 + !>@} + + !>@{ CPU time clock IDs + integer :: id_clock_module + integer :: id_clock_copy + integer :: id_clock_cdiss + integer :: id_clock_stress + integer :: id_clock_divergence + integer :: id_clock_mpi + integer :: id_clock_filter + integer :: id_clock_post + integer :: id_clock_source + !>@} + + !>@{ MPI group passes + type(group_pass_type) :: & + pass_Tq, pass_Th, & !< handles for halo passes of Txy and Txx, Tyy + pass_xx, pass_xy !< handles for halo passes of sh_xx and sh_xy, vort_xy + integer :: Stress_halo = -1, & !< The halo size in filter of the stress tensor + HPF_halo = -1 !< The halo size in filter of the velocity gradient !>@} end type ZB2020_CS contains -!> Read parameters and register output fields -!! used in Zanna_Bolton_2020(). -subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) +!> Read parameters, allocate and precompute arrays, +!! register diagnosicts used in Zanna_Bolton_2020(). +subroutine ZB2020_init(Time, G, GV, US, param_file, diag, CS, use_ZB2020) 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Parameter file parser structure. @@ -82,10 +121,19 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. logical, intent(out) :: use_ZB2020 !< If true, turns on ZB scheme. + real :: subroundoff_Cor ! A negligible parameter which avoids division by zero + ! but small compared to Coriolis parameter [T-1 ~> s-1] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + ! This include declares and sets the variable "version". #include "version_variable.h" character(len=40) :: mdl = "MOM_Zanna_Bolton" ! This module's name. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "USE_ZB2020", use_ZB2020, & @@ -95,7 +143,7 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) 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) + "typically 0.5-2.5", units="nondim", default=0.5) call get_param(param_file, mdl, "ZB_TRACE_MODE", CS%ZB_type, & "Select how to compute the trace part of ZB model:\n" //& @@ -108,59 +156,31 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) "\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) - ! 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, "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, "DT", CS%dt, & - "The (baroclinic) dynamics time step.", units="s", scale=US%s_to_T, & - fail_if_missing=.true.) + call get_param(param_file, mdl, "ZB_KLOWER_R_DISS", CS%Klower_R_diss, & + "Attenuation of " //& + "the ZB parameterization in the regions of " //& + "geostrophically-unbalanced flows (Klower 2018, Juricke2020,2019). " //& + "Subgrid stress is multiplied by 1/(1+(shear/(f*R_diss))):\n" //& + "\t R_diss=-1. - attenuation is not used\n\t R_diss= 1. - typical value", & + units="nondim", default=-1.) + + call get_param(param_file, mdl, "ZB_KLOWER_SHEAR", CS%Klower_shear, & + "Type of expression for shear in Klower formula:\n" //& + "\t 0: sqrt(sh_xx**2 + sh_xy**2)\n" //& + "\t 1: sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2)", & + default=1, do_not_log=.not.CS%Klower_R_diss>0) + + call get_param(param_file, mdl, "ZB_MARCHING_HALO", CS%Marching_halo, & + "The number of filter iterations per single MPI " //& + "exchange", default=4, do_not_log=(CS%Stress_iter==0).and.(CS%HPF_iter==0)) ! Register fields for output from this module. CS%diag => diag @@ -173,726 +193,832 @@ subroutine ZB_2020_init(Time, GV, US, param_file, diag, CS, use_ZB2020) '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_maskT = register_diag_field('ocean_model', 'maskT', diag%axesTL, Time, & - 'Mask of wet points in T (CENTER) points', '1', conversion=1.) + CS%id_Txx = register_diag_field('ocean_model', 'Txx', diag%axesTL, Time, & + 'Diagonal term (Txx) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Tyy = register_diag_field('ocean_model', 'Tyy', diag%axesTL, Time, & + 'Diagonal term (Tyy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + CS%id_Txy = register_diag_field('ocean_model', 'Txy', diag%axesBL, Time, & + 'Off-diagonal term (Txy) in the ZB stress tensor', 'm2 s-2', conversion=US%L_T_to_m_s**2) + + if (CS%Klower_R_diss > 0) then + CS%id_cdiss = register_diag_field('ocean_model', 'c_diss', diag%axesTL, Time, & + 'Klower (2018) attenuation coefficient', 'nondim') + endif + + ! Clock IDs + ! Only module is measured with syncronization. While smaller + ! parts are measured without - because these are nested clocks. + CS%id_clock_module = cpu_clock_id('(Ocean Zanna-Bolton-2020)', grain=CLOCK_MODULE) + CS%id_clock_copy = cpu_clock_id('(ZB2020 copy fields)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_cdiss = cpu_clock_id('(ZB2020 compute c_diss)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_stress = cpu_clock_id('(ZB2020 compute stress)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_divergence = cpu_clock_id('(ZB2020 compute divergence)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_mpi = cpu_clock_id('(ZB2020 filter MPI exchanges)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_filter = cpu_clock_id('(ZB2020 filter no MPI)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_post = cpu_clock_id('(ZB2020 post data)', grain=CLOCK_ROUTINE, sync=.false.) + CS%id_clock_source = cpu_clock_id('(ZB2020 compute energy source)', grain=CLOCK_ROUTINE, sync=.false.) + + ! Allocate memory + ! We set the stress tensor and velocity gradient tensor to zero + ! with full halo because they potentially may be filtered + ! with marching halo algorithm + allocate(CS%sh_xx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%sh_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%vort_xy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%hq(SZIB_(G),SZJB_(G),SZK_(GV))) + + allocate(CS%Txx(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Tyy(SZI_(G),SZJ_(G),SZK_(GV)), source=0.) + allocate(CS%Txy(SZIB_(G),SZJB_(G),SZK_(GV)), source=0.) + allocate(CS%kappa_h(SZI_(G),SZJ_(G))) + allocate(CS%kappa_q(SZIB_(G),SZJB_(G))) + + ! Precomputing the scaling coefficient + ! Mask is included to automatically satisfy B.C. + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%kappa_h(i,j) = -CS%amplitude * G%areaT(i,j) * G%mask2dT(i,j) + enddo; enddo + + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + CS%kappa_q(I,J) = -CS%amplitude * G%areaBu(I,J) * G%mask2dBu(I,J) + enddo; enddo + + if (CS%Klower_R_diss > 0) then + allocate(CS%ICoriolis_h(SZI_(G),SZJ_(G))) + allocate(CS%c_diss(SZI_(G),SZJ_(G),SZK_(GV))) + + subroundoff_Cor = 1e-30 * US%T_to_s + ! Precomputing 1/(f * R_diss) + do j=js-1,je+1 ; do i=is-1,ie+1 + CS%ICoriolis_h(i,j) = 1. / ((abs(0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1)))) + subroundoff_Cor) & + * CS%Klower_R_diss) + enddo; enddo + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + ! Include 1/16. factor to the mask for filter implementation + allocate(CS%maskw_h(SZI_(G),SZJ_(G))); CS%maskw_h(:,:) = G%mask2dT(:,:) * 0.0625 + allocate(CS%maskw_q(SZIB_(G),SZJB_(G))); CS%maskw_q(:,:) = G%mask2dBu(:,:) * 0.0625 + endif + + ! Initialize MPI group passes + if (CS%Stress_iter > 0) then + ! reduce size of halo exchange accordingly to + ! Marching halo, number of iterations and the array size + ! But let exchange width be at least 1 + CS%Stress_halo = max(min(CS%Marching_halo, CS%Stress_iter, & + G%Domain%nihalo, G%Domain%njhalo), 1) + + call create_group_pass(CS%pass_Tq, CS%Txy, G%Domain, halo=CS%Stress_halo, & + position=CORNER) + call create_group_pass(CS%pass_Th, CS%Txx, G%Domain, halo=CS%Stress_halo) + call create_group_pass(CS%pass_Th, CS%Tyy, G%Domain, halo=CS%Stress_halo) + endif + + if (CS%HPF_iter > 0) then + ! The minimum halo size is 2 because it is requirement for the + ! outputs of function filter_velocity_gradients + CS%HPF_halo = max(min(CS%Marching_halo, CS%HPF_iter, & + G%Domain%nihalo, G%Domain%njhalo), 2) + + call create_group_pass(CS%pass_xx, CS%sh_xx, G%Domain, halo=CS%HPF_halo) + call create_group_pass(CS%pass_xy, CS%sh_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + call create_group_pass(CS%pass_xy, CS%vort_xy, G%Domain, halo=CS%HPF_halo, & + position=CORNER) + endif + +end subroutine ZB2020_init - CS%id_maskq = register_diag_field('ocean_model', 'maskq', diag%axesBL, Time, & - 'Mask of wet points in q (CORNER) points', '1', conversion=1.) +!> Deallocate any variables allocated in ZB_2020_init +subroutine ZB2020_end(CS) + type(ZB2020_CS), intent(inout) :: CS !< ZB2020 control structure. - ! action of filter on momentum flux - 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) + deallocate(CS%sh_xx) + deallocate(CS%sh_xy) + deallocate(CS%vort_xy) + deallocate(CS%hq) - 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) + deallocate(CS%Txx) + deallocate(CS%Tyy) + deallocate(CS%Txy) + deallocate(CS%kappa_h) + deallocate(CS%kappa_q) - 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) + if (CS%Klower_R_diss > 0) then + deallocate(CS%ICoriolis_h) + deallocate(CS%c_diss) + endif + + if (CS%Stress_iter > 0 .or. CS%HPF_iter > 0) then + deallocate(CS%maskw_h) + deallocate(CS%maskw_q) + endif + +end subroutine ZB2020_end + +!> Save precomputed velocity gradients and thickness +!! from the horizontal eddy viscosity module +!! We save as much halo for velocity gradients as possible +!! In symmetric (preferable) memory model: halo 2 for sh_xx +!! and halo 1 for sh_xy and vort_xy +!! We apply zero boundary conditions to velocity gradients +!! which is required for filtering operations +subroutine ZB2020_copy_gradient_and_thickness(sh_xx, sh_xy, vort_xy, hq, & + G, GV, CS, k) + 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(inout) :: CS !< ZB2020 control structure. + + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: sh_xy !< horizontal shearing strain (du/dy + dv/dx) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: vort_xy !< Vertical vorticity (dv/dx - du/dy) + !! including metric terms [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: hq !< harmonic mean of the harmonic means + !! of the u- & v point thicknesses [H ~> m or kg m-2] + + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: sh_xx !< horizontal tension (du/dx - dv/dy) + !! including metric terms [T-1 ~> s-1] + + integer, intent(in) :: k !< The vertical index of the layer to be passed. + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + integer :: i, j + + call cpu_clock_begin(CS%id_clock_copy) + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + + do J=js-1,Jeq ; do I=is-1,Ieq + CS%hq(I,J,k) = hq(I,J) + enddo; enddo + + ! No physical B.C. is required for + ! sh_xx in ZB2020. However, filtering + ! may require BC + do j=Jsq-1,je+2 ; do i=Isq-1,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j) * G%mask2dT(i,j) + enddo ; enddo + + ! We multiply by mask to remove + ! implicit dependence on CS%no_slip + ! flag in hor_visc module + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo + + do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + CS%vort_xy(I,J,k) = vort_xy(I,J) * G%mask2dBu(I,J) + enddo; enddo -end subroutine ZB_2020_init + call cpu_clock_end(CS%id_clock_copy) + +end subroutine ZB2020_copy_gradient_and_thickness !> Baroclinic Zanna-Bolton-2020 parameterization, see !! eq. 6 in https://laurezanna.github.io/files/Zanna-Bolton-2020.pdf -!! 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) -!! Update of the governing equations: -!! (du/dt, dv/dt) = k_BC * div(S) -!! 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. +!! We compute the lateral stress tensor according to ZB2020 model +!! and update the acceleration due to eddy viscosity (diffu, diffv) +!! as follows: +!! diffu = diffu + ZB2020u +!! diffv = diffv + ZB2020v +subroutine ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS, & + dx2h, dy2h, dx2q, dy2q) + 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(inout) :: 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]. + 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) :: 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] + intent(inout) :: diffu !< Zonal acceleration due to eddy viscosity. + !! It is updated with ZB closure [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] - - ! Arrays defined in h (CENTER) points - real, dimension(SZI_(G),SZJ_(G)) :: & - 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, & ! 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, & ! 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, & ! 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] + intent(inout) :: diffv !< Meridional acceleration due to eddy viscosity. + !! It is updated with ZB closure [L T-2 ~> m s-2] - 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 :: 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, dimension(SZI_(G),SZJ_(G)), intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] - 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 :: k_bc ! Constant in from of the parameterization [L2 ~> m2] - ! Related to the amplitude as follows: - ! k_bc = - amplitude * grid_cell_area < 0 + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n - ! Line 407 of MOM_hor_visc.F90 + call cpu_clock_begin(CS%id_clock_module) + 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 + ! Compute attenuation if specified + call compute_c_diss(G, GV, CS) - fx(:,:,:) = 0. - fy(:,:,:) = 0. + ! Sharpen velocity gradients if specified + call filter_velocity_gradients(G, GV, CS) - ! 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 + ! Compute the stress tensor given the + ! (optionally sharpened) velocity gradients + call compute_stress(G, GV, CS) - ! 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 + ! Smooth the stress tensor if specified + call filter_stress(G, GV, CS) - if (CS%ssd_iter > -1) then - 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 + ! Update the acceleration due to eddy viscosity (diffu, diffv) + ! with the ZB2020 lateral parameterization + call compute_stress_divergence(u, v, h, diffu, diffv, & + dx2h, dy2h, dx2q, dy2q, & + G, GV, CS) - 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 + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_Txx>0) call post_data(CS%id_Txx, CS%Txx, CS%diag) + if (CS%id_Tyy>0) call post_data(CS%id_Tyy, CS%Tyy, CS%diag) + if (CS%id_Txy>0) call post_data(CS%id_Txy, CS%Txy, CS%diag) - do k=1,nz + if (CS%id_cdiss>0) call post_data(CS%id_cdiss, CS%c_diss, CS%diag) + call cpu_clock_end(CS%id_clock_post) - sh_xx(:,:) = 0. - sh_xy(:,:) = 0. - vort_xy(:,:) = 0. - 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 - 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 + call cpu_clock_end(CS%id_clock_module) - ! 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 +end subroutine ZB2020_lateral_stress - ! 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 +!> Compute the attenuation parameter similarly +!! to Klower2018, Juricke2019,2020: c_diss = 1/(1+(shear/(f*R_diss))) +!! where shear = sqrt(sh_xx**2 + sh_xy**2) or shear = sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) +!! In symmetric memory model, components of velocity gradient tensor +!! should have halo 1 and zero boundary conditions. The result: c_diss having halo 1. +subroutine compute_c_diss(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(inout) :: CS !< ZB2020 control structure. - ! 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 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - call compute_masks(G, GV, h, mask_T, mask_q, k) - 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 + real :: shear ! Shear in Klower2018 formula at h points [T-1 ~> s-1] - 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 + if (.not. CS%Klower_R_diss > 0) & + return - ! 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 - 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 + call cpu_clock_begin(CS%id_clock_cdiss) - 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 + 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%ssd_iter > -1) then - 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 k=1,nz - do J=js-1,Jeq ; do I=is-1,Ieq - ssd_12(I,J) = sh_xy(I,J) * ssd_12_coef(I,J) + ! sqrt(sh_xx**2 + sh_xy**2) + if (CS%Klower_shear == 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + (CS%sh_xy(I-1,J-1,k)**2 + CS%sh_xy(I,J ,k)**2) & + + (CS%sh_xy(I-1,J ,k)**2 + CS%sh_xy(I,J-1,k)**2) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(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) - endif + ! sqrt(sh_xx**2 + sh_xy**2 + vort_xy**2) + elseif (CS%Klower_shear == 1) then + do j=js-1,je+1 ; do i=is-1,ie+1 + shear = sqrt(CS%sh_xx(i,j,k)**2 + 0.25 * ( & + ((CS%sh_xy(I-1,J-1,k)**2 + CS%vort_xy(I-1,J-1,k)**2) & + + (CS%sh_xy(I,J,k)**2 + CS%vort_xy(I,J,k)**2)) & + + ((CS%sh_xy(I-1,J,k)**2 + CS%vort_xy(I-1,J,k)**2) & + + (CS%sh_xy(I,J-1,k)**2 + CS%vort_xy(I,J-1,k)**2)) & + )) + CS%c_diss(i,j,k) = 1. / (1. + shear * CS%ICoriolis_h(i,j)) + enddo; enddo 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) + enddo ! end of k loop - 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 cpu_clock_end(CS%id_clock_cdiss) - 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) +end subroutine compute_c_diss - ! 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 +!> Compute stress tensor T = +!! (Txx, Txy; +!! Txy, Tyy) +!! Which consists of the deviatoric and trace components, respectively: +!! T = (-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) +!! This stress tensor is multiplied by precomputed kappa=-CS%amplitude * G%area: +!! T -> T * kappa +!! The sign of the stress tensor is such that (neglecting h): +!! (du/dt, dv/dt) = div(T) +!! In symmetric memory model: sh_xy and vort_xy should have halo 1 +!! and zero B.C.; sh_xx should have halo 2 and zero B.C. +!! Result: Txx, Tyy, Txy with halo 1 and zero B.C. +subroutine compute_stress(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(inout) :: CS !< ZB2020 control structure. + + real :: & + vort_xy_h, & ! Vorticity interpolated to h point [T-1 ~> s-1] + sh_xy_h ! Shearing strain interpolated to h point [T-1 ~> s-1] + + real :: & + sh_xx_q ! Horizontal tension interpolated to q point [T-1 ~> s-1] + + ! Local variables + real :: sum_sq ! 1/2*(vort_xy^2 + sh_xy^2 + sh_xx^2) in h point [T-2 ~> s-2] + real :: vort_sh ! vort_xy*sh_xy in h point [T-2 ~> s-2] - ! 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 + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - ! 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 + logical :: sum_sq_flag ! Flag to compute trace + logical :: vort_sh_scheme_0, vort_sh_scheme_1 ! Flags to compute diagonal trace-free part - ! 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 + call cpu_clock_begin(CS%id_clock_stress) - ! Form S_11 and S_22 tensors - ! 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 - 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 + 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%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 + sum_sq = 0. + vort_sh = 0. + + sum_sq_flag = CS%ZB_type /= 1 + vort_sh_scheme_0 = CS%ZB_type /= 2 .and. CS%ZB_cons == 0 + vort_sh_scheme_1 = CS%ZB_type /= 2 .and. CS%ZB_cons == 1 + + do k=1,nz + + ! compute Txx, Tyy tensor + do j=js-1,je+1 ; do i=is-1,ie+1 + ! It is assumed that B.C. is applied to sh_xy and vort_xy + sh_xy_h = 0.25 * ( (CS%sh_xy(I-1,J-1,k) + CS%sh_xy(I,J,k)) & + + (CS%sh_xy(I-1,J,k) + CS%sh_xy(I,J-1,k)) ) + + vort_xy_h = 0.25 * ( (CS%vort_xy(I-1,J-1,k) + CS%vort_xy(I,J,k)) & + + (CS%vort_xy(I-1,J,k) + CS%vort_xy(I,J-1,k)) ) + + if (sum_sq_flag) then + sum_sq = 0.5 * & + ((vort_xy_h * vort_xy_h & + + sh_xy_h * sh_xy_h) & + + CS%sh_xx(i,j,k) * CS%sh_xx(i,j,k) & + ) endif - 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) - 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_type == 2) then - vort_sh = 0. - else - vort_sh = vort_xy(I,J) * sh_xx_corner(I,J) + if (vort_sh_scheme_0) & + vort_sh = vort_xy_h * sh_xy_h + + if (vort_sh_scheme_1) then + ! It is assumed that B.C. is applied to sh_xy and vort_xy + vort_sh = 0.25 * ( & + ((G%areaBu(I-1,J-1) * CS%vort_xy(I-1,J-1,k)) * CS%sh_xy(I-1,J-1,k) + & + (G%areaBu(I ,J ) * CS%vort_xy(I ,J ,k)) * CS%sh_xy(I ,J ,k)) + & + ((G%areaBu(I-1,J ) * CS%vort_xy(I-1,J ,k)) * CS%sh_xy(I-1,J ,k) + & + (G%areaBu(I ,J-1) * CS%vort_xy(I ,J-1,k)) * CS%sh_xy(I ,J-1,k)) & + ) * G%IareaT(i,j) endif - k_bc = - CS%amplitude * G%areaBu(i,j) - S_12(I,J) = k_bc * vort_sh + + ! B.C. is already applied in kappa_h + CS%Txx(i,j,k) = CS%kappa_h(i,j) * (- vort_sh + sum_sq) + CS%Tyy(i,j,k) = CS%kappa_h(i,j) * (+ vort_sh + sum_sq) + 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) + ! Here we assume that Txy is initialized to zero + if (CS%ZB_type /= 2) then + do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + sh_xx_q = 0.25 * ( (CS%sh_xx(i+1,j+1,k) + CS%sh_xx(i,j,k)) & + + (CS%sh_xx(i+1,j,k) + CS%sh_xx(i,j+1,k))) + ! B.C. is already applied in kappa_q + CS%Txy(I,J,k) = CS%kappa_q(I,J) * (CS%vort_xy(I,J,k) * sh_xx_q) - if (CS%ssd_iter>-1) then - 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 + enddo ! end of k loop - 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 + call cpu_clock_end(CS%id_clock_stress) + +end subroutine compute_stress + +!> Compute the divergence of subgrid stress +!! weighted with thickness, i.e. +!! (fx,fy) = 1/h Div(h * [Txx, Txy; Txy, Tyy]) +!! and update the acceleration due to eddy viscosity as +!! diffu = diffu + dx; diffv = diffv + dy +!! Optionally, before computing the divergence, we attenuate the stress +!! according to the Klower formula. +!! In symmetric memory model: Txx, Tyy, Txy, c_diss should have halo 1 +!! with applied zero B.C. +subroutine compute_stress_divergence(u, v, h, diffu, diffv, dx2h, dy2h, dx2q, dy2q, 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(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: diffu !< 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) :: diffv !< Meridional acceleration due to convergence + !! of along-coordinate stress tensor [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dx2h !< dx^2 at h points [L2 ~> m2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: dy2h !< dy^2 at h points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dx2q !< dx^2 at q points [L2 ~> m2] + real, dimension(SZIB_(G),SZJB_(G)), & + intent(in) :: dy2q !< dy^2 at q points [L2 ~> m2] + + ! Local variables + real, dimension(SZI_(G),SZJ_(G)) :: & + Mxx, & ! Subgrid stress Txx multiplied by thickness and dy^2 [H L4 T-2 ~> m5 s-2] + Myy ! Subgrid stress Tyy multiplied by thickness and dx^2 [H L4 T-2 ~> m5 s-2] + + real, dimension(SZIB_(G),SZJB_(G)) :: & + Mxy ! Subgrid stress Txy multiplied by thickness [H L2 T-2 ~> m3 s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + 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 for ZB model + !! [L T-2 ~> m s-2] + + real :: h_u ! Thickness interpolated to u points [H ~> m or kg m-2]. + real :: h_v ! Thickness interpolated to v points [H ~> m or kg m-2]. + real :: fx ! Zonal acceleration [L T-2 ~> m s-2] + real :: fy ! Meridional acceleration [L T-2 ~> m s-2] + + real :: h_neglect ! Thickness so small it can be lost in + ! roundoff and so neglected [H ~> m or kg m-2] + + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k + logical :: save_ZB2020u, save_ZB2020v ! Save the acceleration due to ZB2020 model + + call cpu_clock_begin(CS%id_clock_divergence) + + save_ZB2020u = (CS%id_ZB2020u > 0) .or. (CS%id_KE_ZB2020 > 0) + save_ZB2020v = (CS%id_ZB2020v > 0) .or. (CS%id_KE_ZB2020 > 0) + + 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_S_12>0) then + h_neglect = GV%H_subroundoff + + do k=1,nz + if (CS%Klower_R_diss > 0) then do J=js-1,Jeq ; do I=is-1,Ieq - S_12_3d(I,J,k) = S_12(I,J) - enddo; enddo + Mxy(I,J) = (CS%Txy(I,J,k) * & + (0.25 * ( (CS%c_diss(i,j ,k) + CS%c_diss(i+1,j+1,k)) & + + (CS%c_diss(i,j+1,k) + CS%c_diss(i+1,j ,k))) & + ) & + ) * CS%hq(I,J,k) + enddo ; enddo + else + do J=js-1,Jeq ; do I=is-1,Ieq + Mxy(I,J) = CS%Txy(I,J,k) * CS%hq(I,J,k) + enddo ; enddo 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 - 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 + if (CS%Klower_R_diss > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k) * CS%c_diss(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + Mxx(i,j) = ((CS%Txx(i,j,k)) * h(i,j,k)) * dy2h(i,j) + Myy(i,j) = ((CS%Tyy(i,j,k)) * h(i,j,k)) * dx2h(i,j) + enddo ; enddo + endif ! 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) + h_u = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i+1,j)*h(i+1,j,k)) + h_neglect + fx = -((G%IdyCu(I,j)*(Mxx(i,j) - & + Mxx(i+1,j)) + & + G%IdxCu(I,j)*(dx2q(I,J-1)*Mxy(I,J-1) - & + dx2q(I,J) *Mxy(I,J))) * & + G%IareaCu(I,j)) / h_u + diffu(I,j,k) = diffu(I,j,k) + fx + if (save_ZB2020u) & + ZB2020u(I,j,k) = fx 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) + h_v = 0.5 * (G%mask2dT(i,j)*h(i,j,k) + G%mask2dT(i,j+1)*h(i,j+1,k)) + h_neglect + fy = -((G%IdyCv(i,J)*(dy2q(I-1,J)*Mxy(I-1,J) - & + dy2q(I,J) *Mxy(I,J)) + & ! NOTE this plus + G%IdxCv(i,J)*(Myy(i,j) - & + Myy(i,j+1))) * & + G%IareaCv(i,J)) / h_v + diffv(i,J,k) = diffv(i,J,k) + fy + if (save_ZB2020v) & + ZB2020v(i,J,k) = fy enddo ; enddo enddo ! end of k loop - 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_11>0) call post_data(CS%id_S_11, S_11_3d, 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 - -!> 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 - 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] + call cpu_clock_end(CS%id_clock_divergence) - 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] + call cpu_clock_begin(CS%id_clock_post) + if (CS%id_ZB2020u>0) call post_data(CS%id_ZB2020u, ZB2020u, CS%diag) + if (CS%id_ZB2020v>0) call post_data(CS%id_ZB2020v, ZB2020v, CS%diag) + call cpu_clock_end(CS%id_clock_post) - integer :: i_highpass, i_lowpass - integer :: i, j - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + call compute_energy_source(u, v, h, ZB2020u, ZB2020v, G, GV, 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 +end subroutine compute_stress_divergence - if (n_lowpass==0) then - return - endif +!> Filtering of the velocity gradients sh_xx, sh_xy, vort_xy. +!! Here instead of smoothing we do sharpening, i.e. +!! return (initial - smoothed) fields. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input array sh_xx should have halo 2 with +!! applied zero B.C. The arrays sh_xy and vort_xy should have +!! halo 1 with applied B.C. The output have the same halo and B.C. +subroutine filter_velocity_gradients(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(inout) :: CS !< ZB2020 control structure. - ! Total operator is I - (I-G^n_lowpass)^n_highpass - if (present(q)) then - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q(I,J) * mask_q(I,J) - enddo ; enddo + real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & + sh_xx ! Copy of CS%sh_xx [T-1 ~> s-1] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)) :: & + sh_xy, vort_xy ! Copy of CS%sh_xy and CS%vort_xy [T-1 ~> s-1] - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_before, max_before, q=q) - endif + integer :: xx_halo, xy_halo, vort_halo ! currently available halo for gradient components + integer :: xx_iter, xy_iter, vort_iter ! remaining number of iterations + integer :: niter ! required number of iterations - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q1(I,J) = q(I,J) - enddo ; enddo + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: i, j, k, n - ! 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 i_lowpass=1,ABS(n_lowpass) - call smooth_Tq(G, mask_T, mask_q, q=q2) - enddo - ! q1 -> (I-G^n_lowpass)*q1 - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q1(I,J) = q1(I,J) - q2(I,J) - enddo ; enddo - enddo + niter = CS%HPF_iter - if (n_lowpass>0) then - ! q -> q - ((I-G^n_lowpass)^n_highpass)*q - 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 - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - q(I,J) = q1(I,J) - enddo ; enddo - endif + if (niter == 0) return - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_after, max_after, q=q) - if (max_after > max_before .OR. min_after < min_before) then - 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 + 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 (present(T)) then - call pass_var(T, G%Domain) - 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 (.not. G%symmetric) & + call do_group_pass(CS%pass_xx, G%Domain, & + clock=CS%id_clock_mpi) - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_before, max_before, T=T) - endif + ! This is just copy of the array + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + ! Halo of size 2 is valid + do j=js-2,je+2; do i=is-2,ie+2 + sh_xx(i,j,k) = CS%sh_xx(i,j,k) + enddo; enddo + ! Only halo of size 1 is valid + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + sh_xy(I,J,k) = CS%sh_xy(I,J,k) + vort_xy(I,J,k) = CS%vort_xy(I,J,k) + enddo; enddo + enddo + call cpu_clock_end(CS%id_clock_filter) - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T1(i,j) = T(i,j) - enddo ; enddo + xx_halo = 2; xy_halo = 1; vort_halo = 1; + xx_iter = niter; xy_iter = niter; vort_iter = niter; - 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 - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T1(i,j) = T1(i,j) - T2(i,j) - enddo ; enddo - enddo + do while & + (xx_iter > 0 .or. xy_iter > 0 .or. & ! filter iterations remain to be done + xx_halo < 2 .or. xy_halo < 1) ! there is no halo for VG tensor - if (n_lowpass>0) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T(i,j) - T1(i,j) - enddo ; enddo - else - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - T(i,j) = T1(i,j) - enddo ; enddo + ! ---------- filtering sh_xx --------- + if (xx_halo < 2) then + call complete_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) + xx_halo = CS%HPF_halo endif - if (n_highpass==1 .AND. n_lowpass>0) then - call min_max(G, min_after, max_after, T=T) - if (max_after > max_before .OR. min_after < min_before) then - 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 - -!> 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 (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] + call filter_hq(G, GV, CS, xx_halo, xx_iter, h=CS%sh_xx) - real, dimension(SZI_(G),SZJ_(G)) :: Tim ! intermediate T-field [arbitrary] - real, dimension(SZIB_(G),SZJB_(G)) :: qim ! intermediate q-field [arbitrary] + if (xx_halo < 2) & + call start_group_pass(CS%pass_xx, G%Domain, clock=CS%id_clock_mpi) - 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] + ! ------ filtering sh_xy, vort_xy ---- + if (xy_halo < 1) then + call complete_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) + xy_halo = CS%HPF_halo; vort_halo = CS%HPF_halo + endif - integer :: i, j - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq + call filter_hq(G, GV, CS, xy_halo, xy_iter, q=CS%sh_xy) + call filter_hq(G, GV, CS, vort_halo, vort_iter, q=CS%vort_xy) - 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 (xy_halo < 1) & + call start_group_pass(CS%pass_xy, G%Domain, clock=CS%id_clock_mpi) - wside = 1. / 8. - wcorner = 1. / 16. - wcenter = 1. - (wside*4. + wcorner*4.) + enddo - if (present(q)) then - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - do J = Jsq-1, Jeq+1; do I = Isq-1, Ieq+1 - qim(I,J) = q(I,J) * mask_q(I,J) + ! We implement sharpening by computing residual + ! B.C. are already applied to all fields + call cpu_clock_begin(CS%id_clock_filter) + do k=1,nz + do j=js-2,je+2; do i=is-2,ie+2 + CS%sh_xx(i,j,k) = sh_xx(i,j,k) - CS%sh_xx(i,j,k) 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)) & - + (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 - call pass_var(q, G%Domain, position=CORNER, complete=.true.) - endif - - if (present(T)) then - call pass_var(T, G%Domain) - do j = js-1, je+1; do i = is-1, ie+1 - Tim(i,j) = T(i,j) * mask_T(i,j) + do J=Jsq-1,Jeq+1; do I=Isq-1,Ieq+1 + CS%sh_xy(I,J,k) = sh_xy(I,J,k) - CS%sh_xy(I,J,k) + CS%vort_xy(I,J,k) = vort_xy(I,J,k) - CS%vort_xy(I,J,k) 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)) & - + (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 - call pass_var(T, G%Domain) - endif + enddo + call cpu_clock_end(CS%id_clock_filter) -end subroutine smooth_Tq + if (.not. G%symmetric) & + call do_group_pass(CS%pass_xy, G%Domain, & + clock=CS%id_clock_mpi) -!> 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] +end subroutine filter_velocity_gradients - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq +!> Filtering of the stress tensor Txx, Tyy, Txy. +!! The algorithm: marching halo with non-blocking grouped MPI +!! exchanges. The input arrays (Txx, Tyy, Txy) must have halo 1 +!! with zero B.C. applied. The output have the same halo and B.C. +subroutine filter_stress(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(inout) :: CS !< ZB2020 control structure. - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB + integer :: Txx_halo, Tyy_halo, Txy_halo ! currently available halo for stress components + integer :: Txx_iter, Tyy_iter, Txy_iter ! remaining number of iterations + integer :: niter ! required number of iterations - if (present(q)) then - min_val = minval(q(Isq:Ieq, Jsq:Jeq)) - max_val = maxval(q(Isq:Ieq, Jsq:Jeq)) - endif + niter = CS%Stress_iter - if (present(T)) then - min_val = minval(T(is:ie, js:je)) - max_val = maxval(T(is:ie, js:je)) - endif + if (niter == 0) return - 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 - 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 (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 + Txx_halo = 1; Tyy_halo = 1; Txy_halo = 1; ! these are required halo for Txx, Tyy, Txy + Txx_iter = niter; Tyy_iter = niter; Txy_iter = niter; + + do while & + (Txx_iter > 0 .or. Txy_iter > 0 .or. & ! filter iterations remain to be done + Txx_halo < 1 .or. Txy_halo < 1) ! there is no halo for Txx or Txy + + ! ---------- filtering Txy ----------- + if (Txy_halo < 1) then + call complete_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + Txy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txy_halo, Txy_iter, q=CS%Txy) + + if (Txy_halo < 1) & + call start_group_pass(CS%pass_Tq, G%Domain, clock=CS%id_clock_mpi) + + ! ------- filtering Txx, Tyy --------- + if (Txx_halo < 1) then + call complete_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) + Txx_halo = CS%Stress_halo; Tyy_halo = CS%Stress_halo + endif + + call filter_hq(G, GV, CS, Txx_halo, Txx_iter, h=CS%Txx) + call filter_hq(G, GV, CS, Tyy_halo, Tyy_iter, h=CS%Tyy) + + if (Txx_halo < 1) & + call start_group_pass(CS%pass_Th, G%Domain, clock=CS%id_clock_mpi) - hmin = GV%Angstrom_H * 2. - - 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. +end subroutine filter_stress + +!> Wrapper for filter_3D function. The border indices for q and h +!! arrays are substituted. +subroutine filter_hq(G, GV, CS, current_halo, remaining_iterations, q, h) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ZB2020_CS), intent(in) :: CS !< ZB2020 control structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), optional, & + intent(inout) :: h !< Input/output array in h points [arbitrary] + real, dimension(SZIB_(G),SZJB_(G),SZK_(GV)), optional, & + intent(inout) :: q !< Input/output array in q points [arbitrary] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + + logical :: direction ! The direction of the first 1D filter + + direction = (MOD(G%first_direction,2) == 0) + + call cpu_clock_begin(CS%id_clock_filter) + + if (present(h)) then + call filter_3D(h, CS%maskw_h, & + G%isd, G%ied, G%jsd, G%jed, & + G%isc, G%iec, G%jsc, G%jec, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + if (present(q)) then + call filter_3D(q, CS%maskw_q, & + G%IsdB, G%IedB, G%JsdB, G%JedB, & + G%IscB, G%IecB, G%JscB, G%JecB, GV%ke, & + current_halo, remaining_iterations, & + direction) + endif + + call cpu_clock_end(CS%id_clock_filter) +end subroutine filter_hq + +!> Spatial lateral filter applied to 3D array. The lateral filter is given +!! by the convolutional kernel: +!! [1 2 1] +!! C = |2 4 2| * 1/16 +!! [1 2 1] +!! The fast algorithm decomposes the 2D filter into two 1D filters as follows: +!! [1] +!! C = |2| * [1 2 1] * 1/16 +!! [1] +!! The input array must have zero B.C. applied. B.C. is applied for output array. +!! Note that maskw contains both land mask and 1/16 factor. +!! Filter implements marching halo. The available halo is specified and as many +!! filter iterations as possible and as needed are performed. +subroutine filter_3D(x, maskw, isd, ied, jsd, jed, is, ie, js, je, nz, & + current_halo, remaining_iterations, & + direction) + integer, intent(in) :: isd !< Indices of array size + integer, intent(in) :: ied !< Indices of array size + integer, intent(in) :: jsd !< Indices of array size + integer, intent(in) :: jed !< Indices of array size + integer, intent(in) :: is !< Indices of owned points + integer, intent(in) :: ie !< Indices of owned points + integer, intent(in) :: js !< Indices of owned points + integer, intent(in) :: je !< Indices of owned points + integer, intent(in) :: nz !< Vertical array size + real, dimension(isd:ied,jsd:jed,nz), & + intent(inout) :: x !< Input/output array [arbitrary] + real, dimension(isd:ied,jsd:jed), & + intent(in) :: maskw !< Mask array of land points divided by 16 [nondim] + integer, intent(inout) :: current_halo !< Currently available halo points + integer, intent(inout) :: remaining_iterations !< The number of iterations to perform + logical, intent(in) :: direction !< The direction of the first 1D filter + + real, parameter :: weight = 2. ! Filter weight [nondim] + integer :: i, j, k, iter, niter, halo + + real :: tmp(isd:ied, jsd:jed) ! Array with temporary results [arbitrary] + + ! Do as many iterations as needed and possible + niter = min(current_halo, remaining_iterations) + if (niter == 0) return ! nothing to do + + ! Update remaining iterations + remaining_iterations = remaining_iterations - niter + ! Update halo information + current_halo = current_halo - niter + + do k=1,Nz + halo = niter-1 + & + current_halo ! Save as many halo points as possible + do iter=1,niter + + if (direction) then + do j = js-halo, je+halo; do i = is-halo-1, ie+halo+1 + tmp(i,j) = weight * x(i,j,k) + (x(i,j-1,k) + x(i,j+1,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i-1,j) + tmp(i+1,j))) * maskw(i,j) + enddo; enddo else - mask_T(i,j) = 1. + do j = js-halo-1, je+halo+1; do i = is-halo, ie+halo + tmp(i,j) = weight * x(i,j,k) + (x(i-1,j,k) + x(i+1,j,k)) + enddo; enddo + + do j = js-halo, je+halo; do i = is-halo, ie+halo; + x(i,j,k) = (weight * tmp(i,j) + (tmp(i,j-1) + tmp(i,j+1))) * maskw(i,j) + enddo; enddo endif - mask_T(i,j) = mask_T(i,j) * G%mask2dT(i,j) + + halo = halo - 1 enddo enddo - call pass_var(mask_T, G%Domain) -end subroutine compute_masks +end subroutine filter_3D !> Computes the 3D energy source term for the ZB2020 scheme !! similarly to MOM_diagnostics.F90, specifically 1125 line. @@ -906,7 +1032,7 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) 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) :: 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 @@ -922,11 +1048,6 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) 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] - - 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, @@ -937,14 +1058,14 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k - 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 cpu_clock_begin(CS%id_clock_source) call create_group_pass(pass_KE_uv, KE_u, KE_v, G%Domain, To_North+To_East) + 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 + 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. @@ -963,14 +1084,14 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) 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) + call cpu_clock_end(CS%id_clock_source) + call cpu_clock_begin(CS%id_clock_post) call post_data(CS%id_KE_ZB2020, KE_term, CS%diag) + call cpu_clock_end(CS%id_clock_post) endif end subroutine compute_energy_source diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 2d1c38abf9..732044c34e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -23,7 +23,8 @@ 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 +use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end, & + ZB2020_CS, ZB2020_copy_gradient_and_thickness implicit none ; private @@ -250,7 +251,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !! related to Mesoscale Eddy Kinetic Energy. type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(hor_visc_CS), intent(in) :: CS !< Horizontal viscosity control structure + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure @@ -334,16 +335,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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 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 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] @@ -1217,6 +1208,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + ! Pass the velocity gradients and thickness to ZB2020 + if (CS%use_ZB2020) then + call ZB2020_copy_gradient_and_thickness( & + sh_xx, sh_xy, vort_xy, & + hq, & + G, GV, CS%ZB2020, k) + endif + if (CS%Laplacian) then if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then if (CS%use_QG_Leith_visc) then @@ -1622,18 +1621,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ! end of k loop - 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 - 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) @@ -1703,6 +1690,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%id_diffv_visc_rem > 0) call post_product_v(CS%id_diffv_visc_rem, diffv, ADp%visc_rem_v, G, nz, CS%diag) endif + if (CS%use_ZB2020) then + call ZB2020_lateral_stress(u, v, h, diffu, diffv, G, GV, CS%ZB2020, & + CS%dx2h, CS%dy2h, CS%dx2q, CS%dy2q) + endif + end subroutine horizontal_viscosity !> Allocates space for and calculates static variables used by horizontal_viscosity(). @@ -1777,7 +1769,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, CS%use_ZB2020) + call ZB2020_init(Time, G, GV, US, param_file, diag, CS%ZB2020, CS%use_ZB2020) CS%initialized = .true. @@ -2691,6 +2683,11 @@ subroutine hor_visc_end(CS) DEALLOC_(CS%n1n1_m_n2n2_h) DEALLOC_(CS%n1n1_m_n2n2_q) endif + + if (CS%use_ZB2020) then + call ZB2020_end(CS%ZB2020) + endif + end subroutine hor_visc_end !> \namespace mom_hor_visc !! From ac66061e14a670b0112f1790b53046fcca4a9276 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Mon, 23 Oct 2023 14:40:51 -0400 Subject: [PATCH 457/629] Ice-shelf solo driver and MISMIP+ updates (#471) - Several edits to the ice shelf solo driver so that it works with the rest of the current MOM6 - Added capability to initialize a surface mass balance (SMB) that is held contstant over time when running from the ice-shelf solo driver (see new subroutine initialize_ice_SMB). This is required for MISMIP+. A constant SMB can also be used from the MOM driver for coupled ice-shelf/ocean experiments (e.g. MISOMIP). - The new, constant SMB is passed into solo_step_ice_shelf, where change_thickness_using_precip is called - Added capability to save both non-time-stamped and time-stamped restart files when using the ice shelf solo driver. This is useful for debugging. - slight reorganization to when ice shelf post_data calls are made - Added safety checks to diag_mediator_end() so that it works with the ice shelf solo-driver, which now calls it instead of (now removed) solo_ice_shelf_diag_mediator_end() routine. Removed the runtime parameter SAVE_BOTH_RESTARTS from the ice shelf solo-driver, which is no longer needed. --- .../ice_solo_driver/ice_shelf_driver.F90 | 48 +++++++++++--- config_src/drivers/solo_driver/MOM_driver.F90 | 6 +- src/framework/MOM_diag_mediator.F90 | 64 +++++++++++-------- src/ice_shelf/MOM_ice_shelf.F90 | 20 ++++-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 49 +++++++++++++- 6 files changed, 141 insertions(+), 48 deletions(-) diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index 8ea0867d03..f91595bd51 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -24,7 +24,7 @@ program Shelf_main use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_debugging, only : MOM_debugging_init - use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init + use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init, set_axes_info use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var @@ -54,6 +54,8 @@ program Shelf_main use MOM_verticalGrid, only : verticalGrid_type, verticalGridInit, verticalGridEnd use MOM_write_cputime, only : write_cputime, MOM_write_cputime_init use MOM_write_cputime, only : write_cputime_start_clock, write_cputime_CS + use MOM_forcing_type, only : forcing + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_ice_shelf, only : initialize_ice_shelf, ice_shelf_end, ice_shelf_CS use MOM_ice_shelf, only : ice_shelf_save_restart, solo_step_ice_shelf @@ -75,7 +77,9 @@ program Shelf_main ! CPU time limit. nmax is determined by evaluating the CPU time used between successive calls to ! write_cputime. Initially it is set to be very large. integer :: nmax=2000000000 - + ! A structure containing pointers to the thermodynamic forcing fields + ! at the ocean surface. + type(forcing) :: fluxes ! A structure containing several relevant directory paths. type(directories) :: dirs @@ -104,7 +108,7 @@ program Shelf_main real :: time_step ! The time step [T ~> s] ! A pointer to a structure containing metrics and related information. - type(ocean_grid_type), pointer :: ocn_grid + type(ocean_grid_type), pointer :: ocn_grid => NULL() type(dyn_horgrid_type), pointer :: dG => NULL() ! A dynamic version of the horizontal grid type(hor_index_type), pointer :: HI => NULL() ! A hor_index_type for array extents @@ -114,7 +118,7 @@ program Shelf_main type(ocean_OBC_type), pointer :: OBC => NULL() ! A pointer to a structure containing dimensional unit scaling factors. - type(unit_scale_type), pointer :: US + type(unit_scale_type), pointer :: US => NULL() type(diag_ctrl), pointer :: & diag => NULL() ! A pointer to the diagnostic regulatory structure @@ -138,8 +142,9 @@ program Shelf_main integer :: yr, mon, day, hr, mins, sec ! Temp variables for writing the date. type(param_file_type) :: param_file ! The structure indicating the file(s) ! containing all run-time parameters. + real :: smb !A constant surface mass balance that can be specified in the param_file character(len=9) :: month - character(len=16) :: calendar = 'julian' + character(len=16) :: calendar = 'noleap' integer :: calendar_type=-1 integer :: unit, io_status, ierr @@ -184,6 +189,8 @@ program Shelf_main endif endif + ! Get the names of the I/O directories and initialization file. + ! Also calls the subroutine that opens run-time parameter files. call Get_MOM_Input(param_file, dirs) ! Read ocean_solo restart, which can override settings from the namelist. @@ -252,8 +259,11 @@ program Shelf_main ! Set up the ocean model domain and grid; the ice model grid is set in initialize_ice_shelf, ! but the grids have strong commonalities in this configuration, and the ocean grid is required ! to set up the diag mediator control structure. - call MOM_domains_init(ocn_grid%domain, param_file) + allocate(ocn_grid) + call MOM_domains_init(ocn_grid%domain, param_file) !, domain_name='MOM') + allocate(HI) call hor_index_init(ocn_grid%Domain, HI, param_file) + allocate(dG) call create_dyn_horgrid(dG, HI) call clone_MOM_domain(ocn_grid%Domain, dG%Domain) @@ -266,11 +276,16 @@ program Shelf_main ! Initialize the diag mediator. The ocean's vertical grid is not really used here, but at ! present the interface to diag_mediator_init assumes the presence of ocean-specific information. call verticalGridInit(param_file, GV, US) + allocate(diag) call diag_mediator_init(ocn_grid, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) call callTree_waypoint("returned from diag_mediator_init()") - call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag) + call set_axes_info(ocn_grid, GV, US, param_file, diag) + + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + + call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) ! This is the end of the code that is the counterpart of MOM_initialization. call callTree_waypoint("End of ice shelf initialization.") @@ -378,7 +393,7 @@ program Shelf_main ! This call steps the model over a time time_step. Time1 = Master_Time ; Time = Master_Time - call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time) + call solo_step_ice_shelf(ice_shelf_CSp, Time_step_shelf, ns_ice, Time, fluxes_in=fluxes) ! Time = Time + Time_step_shelf ! This is here to enable fractional-second time steps. @@ -412,6 +427,20 @@ program Shelf_main if (BTEST(Restart_control,0)) then call ice_shelf_save_restart(ice_shelf_CSp, Time, dirs%restart_output_dir) endif + ! Write ice shelf solo restart file. + if (is_root_pe())then + call open_ASCII_file(unit, trim(dirs%restart_output_dir)//'shelf.res') + write(unit, '(i6,8x,a)') calendar_type, & + '(Calendar: no_calendar=0, thirty_day_months=1, julian=2, gregorian=3, noleap=4)' + + call get_date(Start_time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Model start time: year, month, day, hour, minute, second' + call get_date(Time, yr, mon, day, hr, mins, sec) + write(unit, '(6i6,8x,a)') yr, mon, day, hr, mins, sec, & + 'Current model time: year, month, day, hour, minute, second' + call close_file(unit) + endif restart_time = restart_time + restint endif @@ -456,12 +485,11 @@ program Shelf_main endif call callTree_waypoint("End Shelf_main") + call ice_shelf_end(ice_shelf_CSp) call diag_mediator_end(Time, diag, end_diag_manager=.true.) if (cpu_steps > 0) call write_cputime(Time, ns-1, write_CPU_CSp, call_end=.true.) call cpu_clock_end(termClock) call io_infra_end ; call MOM_infra_end - call ice_shelf_end(ice_shelf_CSp) - end program Shelf_main diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 84c2eec5b5..0e355f8638 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -49,6 +49,7 @@ program MOM6 use MOM_ice_shelf, only : shelf_calc_flux, add_shelf_forces, ice_shelf_save_restart use MOM_ice_shelf, only : initialize_ice_shelf_fluxes, initialize_ice_shelf_forces use MOM_ice_shelf, only : ice_shelf_query + use MOM_ice_shelf_initialize, only : initialize_ice_SMB use MOM_interpolate, only : time_interp_external_init use MOM_io, only : file_exists, open_ASCII_file, close_file use MOM_io, only : check_nml_error, io_infra_init, io_infra_end @@ -134,7 +135,7 @@ program MOM6 real :: dtdia ! The diabatic timestep [T ~> s] real :: t_elapsed_seg ! The elapsed time in this run segment [T ~> s] integer :: n, ns, n_max, nts, n_last_thermo - logical :: diabatic_first, single_step_call + logical :: diabatic_first, single_step_call, initialize_smb type(time_type) :: Time2, time_chg ! Temporary time variables integer :: Restart_control ! An integer that is bit-tested to determine whether @@ -302,6 +303,9 @@ program MOM6 call initialize_ice_shelf_forces(ice_shelf_CSp, grid, US, forces) call ice_shelf_query(ice_shelf_CSp, grid, data_override_shelf_fluxes=override_shelf_fluxes) if (override_shelf_fluxes) call data_override_init(Ocean_Domain_in=grid%domain%mpp_domain) + call get_param(param_file, mod_name, "INITIALIZE_ICE_SHEET_SMB", & + initialize_smb, "Read in a constant SMB for the ice sheet", default=.false.) + if (initialize_smb) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, grid, US, param_file) endif diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 61290cb579..2c71a93e42 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -3539,37 +3539,45 @@ subroutine diag_mediator_end(time, diag_CS, end_diag_manager) enddo call diag_grid_storage_end(diag_cs%diag_grid_temp) - deallocate(diag_cs%mask3dTL) - deallocate(diag_cs%mask3dBL) - deallocate(diag_cs%mask3dCuL) - deallocate(diag_cs%mask3dCvL) - deallocate(diag_cs%mask3dTi) - deallocate(diag_cs%mask3dBi) - deallocate(diag_cs%mask3dCui) - deallocate(diag_cs%mask3dCvi) + if (associated(diag_cs%mask3dTL)) deallocate(diag_cs%mask3dTL) + if (associated(diag_cs%mask3dBL)) deallocate(diag_cs%mask3dBL) + if (associated(diag_cs%mask3dCuL)) deallocate(diag_cs%mask3dCuL) + if (associated(diag_cs%mask3dCvL)) deallocate(diag_cs%mask3dCvL) + if (associated(diag_cs%mask3dTi)) deallocate(diag_cs%mask3dTi) + if (associated(diag_cs%mask3dBi)) deallocate(diag_cs%mask3dBi) + if (associated(diag_cs%mask3dCui)) deallocate(diag_cs%mask3dCui) + if (associated(diag_cs%mask3dCvi)) deallocate(diag_cs%mask3dCvi) do dl=2,MAX_DSAMP_LEV - deallocate(diag_cs%dsamp(dl)%mask2dT) - deallocate(diag_cs%dsamp(dl)%mask2dBu) - deallocate(diag_cs%dsamp(dl)%mask2dCu) - deallocate(diag_cs%dsamp(dl)%mask2dCv) - deallocate(diag_cs%dsamp(dl)%mask3dTL) - deallocate(diag_cs%dsamp(dl)%mask3dBL) - deallocate(diag_cs%dsamp(dl)%mask3dCuL) - deallocate(diag_cs%dsamp(dl)%mask3dCvL) - deallocate(diag_cs%dsamp(dl)%mask3dTi) - deallocate(diag_cs%dsamp(dl)%mask3dBi) - deallocate(diag_cs%dsamp(dl)%mask3dCui) - deallocate(diag_cs%dsamp(dl)%mask3dCvi) + if (associated(diag_cs%dsamp(dl)%mask2dT)) deallocate(diag_cs%dsamp(dl)%mask2dT) + if (associated(diag_cs%dsamp(dl)%mask2dBu)) deallocate(diag_cs%dsamp(dl)%mask2dBu) + if (associated(diag_cs%dsamp(dl)%mask2dCu)) deallocate(diag_cs%dsamp(dl)%mask2dCu) + if (associated(diag_cs%dsamp(dl)%mask2dCv)) deallocate(diag_cs%dsamp(dl)%mask2dCv) + if (associated(diag_cs%dsamp(dl)%mask3dTL)) deallocate(diag_cs%dsamp(dl)%mask3dTL) + if (associated(diag_cs%dsamp(dl)%mask3dBL)) deallocate(diag_cs%dsamp(dl)%mask3dBL) + if (associated(diag_cs%dsamp(dl)%mask3dCuL)) deallocate(diag_cs%dsamp(dl)%mask3dCuL) + if (associated(diag_cs%dsamp(dl)%mask3dCvL)) deallocate(diag_cs%dsamp(dl)%mask3dCvL) + if (associated(diag_cs%dsamp(dl)%mask3dTi)) deallocate(diag_cs%dsamp(dl)%mask3dTi) + if (associated(diag_cs%dsamp(dl)%mask3dBi)) deallocate(diag_cs%dsamp(dl)%mask3dBi) + if (associated(diag_cs%dsamp(dl)%mask3dCui)) deallocate(diag_cs%dsamp(dl)%mask3dCui) + if (associated(diag_cs%dsamp(dl)%mask3dCvi)) deallocate(diag_cs%dsamp(dl)%mask3dCvi) do i=1,diag_cs%num_diag_coords - deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) - deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCuL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBL(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesTi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCui(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesCvi(i)%dsamp(dl)%mask3d) + if (associated(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d)) & + deallocate(diag_cs%dsamp(dl)%remap_axesBi(i)%dsamp(dl)%mask3d) enddo enddo diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index f5a85da95a..7176e3ccdf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1873,7 +1873,8 @@ subroutine initialize_ice_shelf_fluxes(CS, ocn_grid, US, fluxes_in) tau_mag=.true.) else call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: allocating fluxes in solo mode.") - call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., press=.true., tau_mag=.true.) + call allocate_forcing_type(CS%Grid_in, fluxes_in, ustar=.true., shelf=.true., & + press=.true., shelf_sfc_accumulation = CS%active_shelf_dynamics, tau_mag=.true.) endif if (CS%rotate_index) then allocate(fluxes) @@ -2178,13 +2179,14 @@ subroutine ice_shelf_end(CS) end subroutine ice_shelf_end !> This routine is for stepping a stand-alone ice shelf model without an ocean. -subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in) +subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in, fluxes_in) type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(time_type), intent(in) :: time_interval !< The time interval for this update [s]. integer, intent(inout) :: nsteps !< The running number of ice shelf steps. type(time_type), intent(inout) :: Time !< The current model time real, optional, intent(in) :: min_time_step_in !< The minimum permitted time step [T ~> s]. - + type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any + !! possible thermodynamic or mass-flux forcing fields. type(ocean_grid_type), pointer :: G => NULL() ! A pointer to the ocean's grid structure type(unit_scale_type), pointer :: US => NULL() ! Pointer to a structure containing ! various unit conversion factors @@ -2192,6 +2194,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in !! the ice-shelf state real :: remaining_time ! The remaining time in this call [T ~> s] real :: time_step ! The internal time step during this call [T ~> s] + real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. @@ -2205,6 +2208,7 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec remaining_time = US%s_to_T*time_type_to_real(time_interval) + full_time_step = remaining_time if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -2228,6 +2232,8 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) endif + call change_thickness_using_precip(CS, ISS, G, US, fluxes_in, time_step, Time) + remaining_time = remaining_time - time_step ! If the last mini-timestep is a day or less, we cannot expect velocities to change by much. @@ -2237,13 +2243,13 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, must_update_vel=update_ice_vel) - call enable_averages(time_step, Time, CS%diag) + enddo + + call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) - call disable_averaging(CS%diag) - - enddo + call disable_averaging(CS%diag) end subroutine solo_step_ice_shelf diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 81a4c7e21b..25f6b9f73f 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -768,7 +768,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled ! call ice_shelf_temp(CS, ISS, G, US, time_step, ISS%water_flux, Time) - if (update_ice_vel) then + if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) then call enable_averages(CS%elapsed_velocity_time, Time, CS%diag) if (CS%id_col_thick > 0) call post_data(CS%id_col_thick, CS%OD_av, CS%diag) if (CS%id_u_shelf > 0) call post_data(CS%id_u_shelf, CS%u_shelf, CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 20a48730f3..1e2076f889 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -22,6 +22,7 @@ module MOM_ice_shelf_initialize public initialize_ice_shelf_boundary_from_file public initialize_ice_C_basal_friction public initialize_ice_AGlen +public initialize_ice_SMB ! 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 @@ -657,5 +658,51 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) call MOM_read_data(filename,trim(varname), AGlen, G%Domain) endif -end subroutine +end subroutine initialize_ice_AGlen + +!> Initialize ice surface mass balance field that is held constant over time +subroutine initialize_ice_SMB(SMB, G, US, PF) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: SMB !< Ice surface mass balance parameter, often in [kg m-2 s-1] + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters + + real :: SMB_val ! Constant ice surface mass balance parameter, often in [kg m-2 s-1] + character(len=40) :: mdl = "initialize_ice_SMB" ! This subroutine's name. + character(len=200) :: config + character(len=200) :: varname + character(len=200) :: inputdir, filename, SMB_file + + call get_param(PF, mdl, "ICE_SMB_CONFIG", config, & + "This specifies how the initial ice surface mass balance parameter is specified. "//& + "Valid values are: CONSTANT and FILE.", & + default="CONSTANT") + + if (trim(config)=="CONSTANT") then + call get_param(PF, mdl, "SMB", SMB_val, & + "Surface mass balance.", units="kg m-2 s-1", default=0.0) + + SMB(:,:) = SMB_val + + elseif (trim(config)=="FILE") then + call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading SMB parameter") + call get_param(PF, mdl, "INPUTDIR", inputdir, default=".") + inputdir = slasher(inputdir) + + call get_param(PF, mdl, "ICE_SMB_FILE", SMB_file, & + "The file from which the ice surface mass balance is read.", & + default="ice_SMB.nc") + filename = trim(inputdir)//trim(SMB_file) + call log_param(PF, mdl, "INPUTDIR/ICE_SMB_FILE", filename) + call get_param(PF, mdl, "ICE_SMB_VARNAME", varname, & + "The variable to use as surface mass balance.", & + default="SMB") + + if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & + " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) + call MOM_read_data(filename,trim(varname), SMB, G%Domain) + + endif +end subroutine initialize_ice_SMB end module MOM_ice_shelf_initialize From c9fc30d61b412bcfb07adddefe6d9632e75f6101 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Wed, 23 Aug 2023 18:29:45 -0400 Subject: [PATCH 458/629] ice shelf dHdt and optimization -fixed a bug in change_thickness_using_precip (was missing a division by ice density) -optimized ice shelf pass_var calls with optional complete arguments -corrected the grid area to multiply with ice shelf driving stress before its post_data call -changed some order of operations by adding parentheses, with the hope that it would improve symmetry of the ice shelf solution during MISMIP+. There was no effect, but this version of the code was used for MISMIP+ and MISOMIP. --- src/ice_shelf/MOM_ice_shelf.F90 | 24 ++-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 142 +++++++++++------------ 2 files changed, 83 insertions(+), 83 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 7176e3ccdf..89b868f0bf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -858,9 +858,9 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic endif enddo ; enddo - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(ISS%mass_shelf, G%domain) end subroutine change_thickness_using_melt @@ -1753,10 +1753,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, id_clock_pass = cpu_clock_id(' Ice shelf halo updates', grain=CLOCK_ROUTINE) call cpu_clock_begin(id_clock_pass) - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%mass_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) call pass_var(G%bathyT, G%domain) call cpu_clock_end(id_clock_pass) @@ -2032,7 +2032,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time do j=G%jsc,G%jec ; do i=G%isc,G%iec if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then - if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step < ISS%h_shelf(i,j)) then + if (-fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice < ISS%h_shelf(i,j)) then ISS%h_shelf(i,j) = ISS%h_shelf(i,j) + fluxes%shelf_sfc_mass_flux(i,j) * time_step * I_rho_ice else ! the ice is about to ablate, so set thickness, area, and mask to zero @@ -2101,10 +2101,10 @@ subroutine update_shelf_mass(G, US, CS, ISS, Time) CS%min_thickness_simple_calve, halo=0) endif - call pass_var(ISS%area_shelf_h, G%domain) - call pass_var(ISS%h_shelf, G%domain) - call pass_var(ISS%hmask, G%domain) - call pass_var(ISS%mass_shelf, G%domain) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(ISS%mass_shelf, G%domain, complete=.true.) end subroutine update_shelf_mass diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 25f6b9f73f..8a40d74b4e 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -21,7 +21,7 @@ module MOM_ice_shelf_dynamics use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state -use MOM_coms, only : reproducing_sum, sum_across_PEs, max_across_PEs, min_across_PEs +use MOM_coms, only : reproducing_sum, max_across_PEs, min_across_PEs use MOM_checksums, only : hchksum, qchksum use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_channel,initialize_ice_flow_from_file use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary_from_file,initialize_ice_C_basal_friction @@ -551,20 +551,20 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ enddo ; enddo endif - call pass_var(CS%OD_av,G%domain) - call pass_var(CS%ground_frac,G%domain) - call pass_var(CS%ice_visc,G%domain) - call pass_var(CS%basal_traction, G%domain) - call pass_var(CS%AGlen_visc, G%domain) - call pass_var(CS%bed_elev, G%domain) - call pass_var(CS%C_basal_friction, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) + call pass_var(CS%OD_av,G%domain, complete=.false.) + call pass_var(CS%ground_frac,G%domain, complete=.false.) + call pass_var(CS%ice_visc,G%domain, complete=.false.) + call pass_var(CS%basal_traction, G%domain, complete=.false.) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.false.) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.false.) + call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif @@ -597,28 +597,28 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ ! initialize basal friction coefficients if (new_sim) then call initialize_ice_C_basal_friction(CS%C_basal_friction, G, US, param_file) - call pass_var(CS%C_basal_friction, G%domain) + call pass_var(CS%C_basal_friction, G%domain, complete=.false.) ! initialize ice-stiffness AGlen call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) - call pass_var(CS%AGlen_visc, G%domain) + call pass_var(CS%AGlen_visc, G%domain, complete=.false.) !initialize boundary conditions call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) - call pass_var(ISS%hmask, G%domain) - call pass_var(CS%h_bdry_val, G%domain) - call pass_var(CS%thickness_bdry_val, G%domain) - call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE) - call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE) + call pass_var(ISS%hmask, G%domain, complete=.false.) + call pass_var(CS%h_bdry_val, G%domain, complete=.false.) + call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) + call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.false.) !initialize ice flow characteristic (velocities, bed elevation under the grounded part, etc) from file call initialize_ice_flow_from_file(CS%bed_elev,CS%u_shelf, CS%v_shelf, CS%ground_frac, & G, US, param_file) - call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE) - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%bed_elev, G%domain) + call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.true.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%bed_elev, G%domain, complete=.true.) call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) endif ! Register diagnostics. @@ -775,11 +775,11 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled if (CS%id_v_shelf > 0) call post_data(CS%id_v_shelf, CS%v_shelf, CS%diag) ! if (CS%id_t_shelf > 0) call post_data(CS%id_t_shelf, CS%t_shelf, CS%diag) if (CS%id_taudx_shelf > 0) then - taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaT(:,:) + taud_x(:,:) = CS%taudx_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudx_shelf, taud_x, CS%diag) endif if (CS%id_taudy_shelf > 0) then - taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaT(:,:) + taud_y(:,:) = CS%taudy_shelf(:,:)*G%IareaBu(:,:) call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) @@ -990,7 +990,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i endif enddo ; enddo - call pass_var(float_cond, G%Domain) + call pass_var(float_cond, G%Domain, complete=.false.) call bilinear_shape_functions_subgrid(Phisub, nsub) @@ -1004,9 +1004,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i enddo ; enddo call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) + call pass_var(CS%basal_traction, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be @@ -1079,9 +1079,9 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call MOM_mesg(mesg, 5) call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain) + call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%basal_traction, G%domain) + call pass_var(CS%basal_traction, G%domain, complete=.true.) if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! makes sure basal stress is only applied when it is supposed to be @@ -1272,18 +1272,18 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H RHSu(:,:) = taudx(:,:) !- ubd(:,:) RHSv(:,:) = taudy(:,:) !- vbd(:,:) - call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) - call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, hmask, & H_node, CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & G, US, isc-1, iec+1, jsc-1, jec+1, rhoi_rhow) - call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE, complete=.true.) Ru(:,:) = (RHSu(:,:) - Au(:,:)) Rv(:,:) = (RHSv(:,:) - Av(:,:)) @@ -1345,12 +1345,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jscq,jecq ; do i=iscq,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Du(I,J) * Au(I,J) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Du(I,J) * Au(I,J)) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Dv(I,J) * Av(I,J) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Dv(I,J) * Av(I,J)) endif enddo ; enddo @@ -1400,12 +1400,12 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H do j=jscq,jecq ; do i=iscq,iecq if (CS%umask(I,J) == 1) then - sum_vec(I,J) = resid_scale * Zu(I,J) * Ru(I,J) - sum_vec_2(I,J) = resid_scale * Zu_old(I,J) * Ru_old(I,J) + sum_vec(I,J) = resid_scale * (Zu(I,J) * Ru(I,J)) + sum_vec_2(I,J) = resid_scale * (Zu_old(I,J) * Ru_old(I,J)) endif if (CS%vmask(I,J) == 1) then - sum_vec(I,J) = sum_vec(I,J) + resid_scale * Zv(I,J) * Rv(I,J) - sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * Zv_old(I,J) * Rv_old(I,J) + sum_vec(I,J) = sum_vec(I,J) + resid_scale * (Zv(I,J) * Rv(I,J)) + sum_vec_2(I,J) = sum_vec_2(I,J) + resid_scale * (Zv_old(I,J) * Rv_old(I,J)) endif enddo ; enddo @@ -1443,9 +1443,9 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (cg_halo == 0) then ! pass vectors - call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE) - call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE) - call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE) + call pass_vector(Du, Dv, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(u_shlf, v_shlf, G%domain, TO_ALL, BGRID_NE, complete=.false.) + call pass_vector(Ru, Rv, G%domain, TO_ALL, BGRID_NE, complete=.true.) cg_halo = 3 endif @@ -2262,15 +2262,15 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, do iq=1,2 ; do jq=1,2 - uq = u_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - u_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - u_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - u_shlf(I,J) * xquad(iq) * xquad(jq) + uq = u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + u_shlf(I,J) * (xquad(iq) * xquad(jq)) - vq = v_shlf(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - v_shlf(I,J-1) * xquad(iq) * xquad(3-jq) + & - v_shlf(I-1,J) * xquad(3-iq) * xquad(jq) + & - v_shlf(I,J) * xquad(iq) * xquad(jq) + vq = v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + v_shlf(I,J) * (xquad(iq) * xquad(jq)) ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & @@ -2287,7 +2287,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - vy = v_shlf(I-1,j-1) * Phi(2,2*(jq-1)+iq,i,j) + & + vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) @@ -2306,9 +2306,9 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) endif enddo ; enddo enddo ; enddo @@ -2600,15 +2600,15 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, do iq=1,2 ; do jq=1,2 - uq = CS%u_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%u_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%u_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%u_bdry_val(I,J) * xquad(iq) * xquad(jq) + uq = CS%u_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + CS%u_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + CS%u_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + CS%u_bdry_val(I,J) * (xquad(iq) * xquad(jq)) - vq = CS%v_bdry_val(I-1,J-1) * xquad(3-iq) * xquad(3-jq) + & - CS%v_bdry_val(I,J-1) * xquad(iq) * xquad(3-jq) + & - CS%v_bdry_val(I-1,J) * xquad(3-iq) * xquad(jq) + & - CS%v_bdry_val(I,J) * xquad(iq) * xquad(jq) + vq = CS%v_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + CS%v_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + CS%v_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & + CS%v_bdry_val(I,J) * (xquad(iq) * xquad(jq)) ux = CS%u_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & CS%u_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & @@ -2643,7 +2643,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (float_cond(i,j) == 0) then u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) endif endif @@ -2654,7 +2654,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, if (float_cond(i,j) == 0) then v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * xquad(ilq) * xquad(jlq) + 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) endif endif enddo ; enddo @@ -2916,8 +2916,8 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 enddo ; enddo - call pass_var(CS%ground_frac, G%domain) - call pass_var(CS%OD_av, G%domain) + call pass_var(CS%ground_frac, G%domain, complete=.false.) + call pass_var(CS%OD_av, G%domain, complete=.true.) endif end subroutine update_OD_ffrac @@ -2989,8 +2989,8 @@ subroutine bilinear_shape_functions (X, Y, Phi, area) a = -X(1)*(1-yquad(qpoint)) + X(2)*(1-yquad(qpoint)) - X(3)*yquad(qpoint) + X(4)*yquad(qpoint) ! d(x)/d(x*) b = -Y(1)*(1-yquad(qpoint)) + Y(2)*(1-yquad(qpoint)) - Y(3)*yquad(qpoint) + Y(4)*yquad(qpoint) ! d(y)/d(x*) - c = -X(1)*(1-xquad(qpoint)) - X(2)*(xquad(qpoint)) + X(3)*(1-xquad(qpoint)) + X(4)*(xquad(qpoint)) ! d(x)/d(y*) - d = -Y(1)*(1-xquad(qpoint)) - Y(2)*(xquad(qpoint)) + Y(3)*(1-xquad(qpoint)) + Y(4)*(xquad(qpoint)) ! d(y)/d(y*) + c = -X(1)*(1-xquad(qpoint)) - X(2)*xquad(qpoint) + X(3)*(1-xquad(qpoint)) + X(4)*xquad(qpoint) ! d(x)/d(y*) + d = -Y(1)*(1-xquad(qpoint)) - Y(2)*xquad(qpoint) + Y(3)*(1-xquad(qpoint)) + Y(4)*xquad(qpoint) ! d(y)/d(y*) do node=1,4 @@ -3480,8 +3480,8 @@ subroutine ice_shelf_temp(CS, ISS, G, US, time_step, melt_rate, Time) endif enddo ; enddo - call pass_var(CS%t_shelf, G%domain) - call pass_var(CS%tmask, G%domain) + call pass_var(CS%t_shelf, G%domain, complete=.false.) + call pass_var(CS%tmask, G%domain, complete=.true.) if (CS%debug) then call hchksum(CS%t_shelf, "temp after front", G%HI, haloshift=3, scale=US%C_to_degC) From f514529a8a299b8e84512a10062aa524f0a23478 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Thu, 26 Oct 2023 15:11:12 -0400 Subject: [PATCH 459/629] Ice sheet thickness boundary condition (#474) * allow for assigned ice shelf thickness where hmask==3, but still solve for ice sheet velocity --- src/ice_shelf/MOM_ice_shelf.F90 | 4 +-- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 42 ++++++++++++------------ src/ice_shelf/MOM_ice_shelf_state.F90 | 4 +-- 3 files changed, 25 insertions(+), 25 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 89b868f0bf..84858f17bc 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1660,7 +1660,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j)==3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo @@ -1727,7 +1727,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%rotate_index, CS%turns) ! next make sure mass is consistent with thickness do j=G%jsd,G%jed ; do i=G%isd,G%ied - if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2)) then + if ((ISS%hmask(i,j) == 1) .or. (ISS%hmask(i,j) == 2) .or. (ISS%hmask(i,j) == 3)) then ISS%mass_shelf(i,j) = ISS%h_shelf(i,j)*CS%density_ice endif enddo ; enddo diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8a40d74b4e..ffa065e400 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -703,7 +703,7 @@ function ice_time_step_CFL(CS, ISS, G) min_dt = 5.0e17*G%US%s_to_T ! The starting maximum is roughly the lifetime of the universe. min_vel = (1.0e-12/(365.0*86400.0)) * G%US%m_s_to_L_T - do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (ISS%hmask(i,j) == 1.0 .or. ISS%hmask(i,j)==3) then dt_local = 2.0*G%areaT(i,j) / & ((G%dyCu(I,j) * max(abs(CS%u_shelf(I,J) + CS%u_shelf(I,j-1)), min_vel) + & G%dyCu(I-1,j)* max(abs(CS%u_shelf(I-1,J)+ CS%u_shelf(I-1,j-1)), min_vel)) + & @@ -979,7 +979,7 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i nodefloat = 0 do l=0,1 ; do k=0,1 - if ((ISS%hmask(i,j) == 1) .and. & + if ((ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j)==3) .and. & (rhoi_rhow * H_node(i-1+k,j-1+l) - CS%bed_elev(i,j) <= 0)) then nodefloat = nodefloat + 1 endif @@ -1512,7 +1512,7 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after do j=jsh,jeh ; do I=ish-1,ieh if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) - elseif ((hmask(i,j) == 1) .or. (hmask(i+1,j) == 1)) then + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1591,8 +1591,7 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after do J=jsh-1,jeh ; do i=ish,ieh if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) - elseif ((hmask(i,j) == 1) .or. (hmask(i,j+1) == 1)) then - + elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. @@ -1760,7 +1759,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 ISS%h_shelf(i,j) = h_reference ISS%area_shelf_h(i,j) = G%areaT(i,j) elseif ((partial_vol / G%areaT(i,j)) < h_reference) then @@ -1770,7 +1769,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ISS%h_shelf(i,j) = h_reference else - ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference partial_vol = partial_vol - h_reference * G%areaT(i,j) @@ -1962,30 +1961,31 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) dyh = G%dyT(i,j) Dx=dxh Dy=dyh - if (ISS%hmask(i,j) == 1) then ! we are inside the global computational bdry, at an ice-filled cell + if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then + ! we are inside the global computational bdry, at an ice-filled cell ! calculate sx if ((i+i_off) == gisc) then ! at west computational bdry - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then sx = (S(i+1,j)-S(i,j))/dxh else sx = 0 endif elseif ((i+i_off) == giec) then ! at east computational bdry - if (ISS%hmask(i-1,j) == 1) then + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then sx = (S(i,j)-S(i-1,j))/dxh else sx = 0 endif else ! interior - if (ISS%hmask(i+1,j) == 1) then + if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then cnt = cnt+1 Dx =dxh+ G%dxT(i+1,j) sx = S(i+1,j) else sx = S(i,j) endif - if (ISS%hmask(i-1,j) == 1) then + if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then cnt = cnt+1 Dx =dxh+ G%dxT(i-1,j) sx = sx - S(i-1,j) @@ -2003,26 +2003,26 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! calculate sy, similarly if ((j+j_off) == gjsc) then ! at south computational bdry - if (ISS%hmask(i,j+1) == 1) then + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then sy = (S(i,j+1)-S(i,j))/dyh else sy = 0 endif elseif ((j+j_off) == gjec) then ! at north computational bdry - if (ISS%hmask(i,j-1) == 1) then + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then sy = (S(i,j)-S(i,j-1))/dyh else sy = 0 endif else ! interior - if (ISS%hmask(i,j+1) == 1) then + if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then cnt = cnt+1 Dy =dyh+ G%dyT(i,j+1) sy = S(i,j+1) else sy = S(i,j) endif - if (ISS%hmask(i,j-1) == 1) then + if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then cnt = cnt+1 sy = sy - S(i,j-1) Dy =dyh+ G%dyT(i,j-1) @@ -2258,7 +2258,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, Ee=1.0 - do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1) then + do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then do iq=1,2 ; do jq=1,2 @@ -2426,7 +2426,7 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, Ee=1.0 - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then call bilinear_shape_fn_grid(G, i, j, Phi) @@ -2584,7 +2584,7 @@ subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, Ee=1.0 - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1) then + do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then ! process this cell if any corners have umask set to non-dirichlet bdry. @@ -3221,7 +3221,7 @@ subroutine update_velocity_masks(CS, G, hmask, umask, vmask, u_face_mask, v_face endif do j=js,G%jed; do i=is,G%ied - if (hmask(i,j) == 1) then + if (hmask(i,j) == 1 .or. hmask(i,j)==3) then umask(I-1:I,J-1:J)=1 vmask(I-1:I,J-1:J)=1 endif @@ -3362,7 +3362,7 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) num_h = 0 do k=0,1 do l=0,1 - if (hmask(i+k,j+l) == 1.0) then + if (hmask(i+k,j+l) == 1.0 .or. hmask(i+k,j+l) == 3.0) then summ = summ + h_shelf(i+k,j+l) num_h = num_h + 1 endif diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 32413ad2d8..8b66f35f48 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -31,8 +31,8 @@ module MOM_ice_shelf_state !! ice-covered cells are treated the same, this may change) !! 2: partially covered, do not solve for velocity !! 0: no ice in cell. - !! 3: bdry condition on thickness set - not in computational domain - !! -2 : default (out of computational boundary, and) not = 3 + !! 3: bdry condition on thickness set + !! -2 : default (out of computational boundary) !! NOTE: hmask will change over time and NEEDS TO BE MAINTAINED !! otherwise the wrong nodes will be included in velocity calcs. From e41929e073a6397d099a71fe2009fa0361f017e9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 26 Oct 2023 12:03:12 -0400 Subject: [PATCH 460/629] Update .readthedocs.yml configuration Newest Read the Docs configuration file requires explicit specification of the environment (using `build:`). This patch includes this section. Upgrading to newer Python environments has also forced us to specify an older Jinja2 that works with our legacy Sphinx module. --- .readthedocs.yml | 11 +++++++++-- docs/requirements.txt | 2 ++ 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/.readthedocs.yml b/.readthedocs.yml index f7ad4421b4..4fe8d6300d 100644 --- a/.readthedocs.yml +++ b/.readthedocs.yml @@ -1,5 +1,14 @@ +# Read the Docs configuration file for Sphinx projects +# See https://docs.readthedocs.io/en/stable/config-file/v2.html for details + +# Required version: 2 +build: + os: ubuntu-22.04 + tools: + python: "3.11" + # Extra formats # PDF generation is failing for now; disabled on 2020-12-02 #formats: @@ -10,7 +19,5 @@ sphinx: configuration: docs/conf.py python: - # make sure we're using Python 3 - version: 3 install: - requirements: docs/requirements.txt diff --git a/docs/requirements.txt b/docs/requirements.txt index 52fcf95bc0..ff627c61c7 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -8,3 +8,5 @@ sphinxcontrib-bibtex numpy six future +# Old Sphinx requires an old Jinja2 +jinja2<3.1 From 503a9f4c5f585e258a3d5810cad0b4af073c4fb8 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Fri, 27 Oct 2023 06:59:36 -0400 Subject: [PATCH 461/629] ice shelf front advection: When determining a reference thickness for a partially-filled cell, add the reference thickness contribution from a neighboring filled cell proportionate to its flux into the partially-filled cell. This is more accurate than simply taking the average thickness of all neighboring filled cells. Also fixed incorrect bounds. (#475) --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index ffa065e400..2965f6eac4 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -1723,14 +1723,14 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do j=jsc-1,jec+1 - if (((j+j_off) <= G%domain%njglobal+G%domain%njhalo) .AND. & - ((j+j_off) >= G%domain%njhalo+1)) then + if (((j+j_off) <= G%domain%njglobal) .AND. & + ((j+j_off) >= 1)) then do i=isc-1,iec+1 - if (((i+i_off) <= G%domain%niglobal+G%domain%nihalo) .AND. & - ((i+i_off) >= G%domain%nihalo+1)) then - ! first get reference thickness by averaging over cells that are fluxing into this cell + if (((i+i_off) <= G%domain%niglobal) .AND. & + ((i+i_off) >= 1)) then + ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 h_reference = 0.0 tot_flux = 0.0 @@ -1738,7 +1738,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) + h_reference = h_reference + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) + !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) tot_flux = tot_flux + flux_enter(i,j,k) flux_enter(i,j,k) = 0.0 endif @@ -1747,7 +1748,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k+2) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) + h_reference = h_reference + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) + !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) tot_flux = tot_flux + flux_enter(i,j,k+2) flux_enter(i,j,k+2) = 0.0 endif @@ -1755,7 +1757,8 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) if (n_flux > 0) then dxdyh = G%areaT(i,j) - h_reference = h_reference / real(n_flux) + h_reference = h_reference / tot_flux + !h_reference = h_reference / real(n_flux) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow From ddb88f8c2fb36ce282cfdb34739a1c37ed369abd Mon Sep 17 00:00:00 2001 From: Cory Spencer Jones Date: Mon, 16 Oct 2023 11:33:26 -0500 Subject: [PATCH 462/629] +Add timestamp and directory to particles restart The directory, time and timestamp variables are needed by the particle code in order to write better restart files. I have changed the particles_save_restart interface to add these variables. I have also removed the option to pass temperature and salinity to particles_save_restart, because these variables are not useful for restart. --- config_src/external/drifters/MOM_particles.F90 | 7 ++++--- src/core/MOM.F90 | 3 +-- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/config_src/external/drifters/MOM_particles.F90 b/config_src/external/drifters/MOM_particles.F90 index b86c720b75..95470e6510 100644 --- a/config_src/external/drifters/MOM_particles.F90 +++ b/config_src/external/drifters/MOM_particles.F90 @@ -47,12 +47,13 @@ end subroutine particles_run !>Save particle locations (and sometimes other vars) to restart file -subroutine particles_save_restart(parts, h, temp, salt) +subroutine particles_save_restart(parts, h, directory, time, time_stamped) ! Arguments type(particles), pointer :: parts !< Container for all types and memory real, dimension(:,:,:),intent(in) :: h !< Thickness of each layer [H ~> m or kg m-2] - real, dimension(:,:,:), optional, intent(in) :: temp !< Optional container for temperature [C ~> degC] - real, dimension(:,:,:), optional, intent(in) :: salt !< Optional container for salinity [S ~> ppt] + character(len=*), intent(in) :: directory !< The directory where the restart files are to be written + type(time_type), intent(in) :: time !< The current model time + logical, optional, intent(in) :: time_stamped !< If present and true, add time-stamp to the restart file names end subroutine particles_save_restart diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 7ff553b362..64e96bdf10 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -4022,8 +4022,7 @@ subroutine save_MOM_restart(CS, directory, time, G, time_stamped, filename, & time_stamped=time_stamped, filename=filename, GV=GV, & num_rest_files=num_rest_files, write_IC=write_IC) - ! TODO: Update particles to use Time and directories - if (CS%use_particles) call particles_save_restart(CS%particles, CS%h) + if (CS%use_particles) call particles_save_restart(CS%particles, CS%h, directory, time, time_stamped) end subroutine save_MOM_restart From 615e57f854db8be8c75a9edba6bb05e3f04a6eb7 Mon Sep 17 00:00:00 2001 From: raphael dussin Date: Sat, 28 Oct 2023 15:09:45 -0400 Subject: [PATCH 463/629] extension to the internal tides module (#481) the module in now able to read in tidal velocities for different tidal harmonics and distribute the energy and distribute TKE input over the different vertical modes. This involves upsizing dimensions of several arrays and mofiying some API. internal_tide_input_CS is promoted to public to facilitate the passing of energy input to MOM_internal_tides --- .../lateral/MOM_internal_tides.F90 | 184 ++++++++++++++---- .../vertical/MOM_diabatic_driver.F90 | 5 +- .../vertical/MOM_internal_tide_input.F90 | 127 ++++++++---- 3 files changed, 240 insertions(+), 76 deletions(-) diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index 172d2459d5..a8b0d3f813 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -16,11 +16,13 @@ module MOM_internal_tides use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_int_tide_input, only: int_tide_input_CS, get_input_TKE, get_barotropic_tidal_vel use MOM_io, only : slasher, MOM_read_data, file_exists, axis_info use MOM_io, only : set_axis_info, get_axis_info use MOM_restart, only : register_restart_field, MOM_restart_CS, restart_init, save_restart use MOM_restart, only : lock_check, restart_registry_lock use MOM_spatial_means, only : global_area_integral +use MOM_string_functions, only: extract_real use MOM_time_manager, only : time_type, time_type_to_real, operator(+), operator(/), operator(-) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : surface, thermo_var_ptrs @@ -54,6 +56,9 @@ module MOM_internal_tides !! the default is false; it is always true with aggress_adjust. logical :: use_PPMang !< If true, use PPM for advection of energy in angular space. + real, allocatable, dimension(:,:) :: fraction_tidal_input + !< how the energy from one tidal component is distributed + !! over the various vertical modes, 2d in frequency and mode [nondim] real, allocatable, dimension(:,:) :: refl_angle !< local coastline/ridge/shelf angles read from file [rad] ! (could be in G control structure) @@ -161,7 +166,7 @@ module MOM_internal_tides ! 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_tot_En = -1 integer :: id_refl_pref = -1, id_refl_ang = -1, id_land_mask = -1 integer :: id_trans = -1, id_residual = -1 integer :: id_dx_Cv = -1, id_dy_Cu = -1 @@ -172,7 +177,12 @@ module MOM_internal_tides integer, allocatable, dimension(:,:) :: & id_En_mode, & id_itidal_loss_mode, & + id_leak_loss_mode, & + id_quad_loss_mode, & + id_Froude_loss_mode, & + id_residual_loss_mode, & id_allprocesses_loss_mode, & + id_itide_drag, & id_Ub_mode, & id_cp_mode ! Diag handles considering: all modes, frequencies, and angles @@ -180,6 +190,7 @@ module MOM_internal_tides id_En_ang_mode, & id_itidal_loss_ang_mode integer, allocatable, dimension(:) :: & + id_TKE_itidal_input, & id_Ustruct_mode, & id_Wstruct_mode, & id_int_w2_mode, & @@ -200,8 +211,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, TKE_itidal_input, vel_btTide, Nb, Rho_bot, dt, & - G, GV, US, CS) +subroutine propagate_int_tide(h, tv, Nb, Rho_bot, dt, G, GV, US, inttide_input_CSp, 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. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -209,10 +219,6 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Pointer to thermodynamic variables !! (needed for wave structure). - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: TKE_itidal_input !< The energy input to the - !! internal waves [R 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(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. @@ -220,9 +226,14 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, !! reference density [R ~> kg m-3]. real, intent(in) :: dt !< Length of time over which to advance !! the internal tides [T ~> s]. + type(int_tide_input_CS), intent(in) :: inttide_input_CSp !< Internal tide input control structure type(int_tide_CS), intent(inout) :: CS !< Internal tide control structure ! Local variables + real, dimension(SZI_(G),SZJ_(G),CS%nFreq) :: & + TKE_itidal_input, & !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + 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) :: & @@ -231,15 +242,22 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, 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] Umax ! Maximum horizontal velocity of wave (modal) [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),CS%nFreq,CS%nMode) :: & + drag_scale ! bottom drag scale [T-1 ~> s-1] real, dimension(SZI_(G),SZJ_(G)) :: & + tot_vel_btTide2, & tot_En, & ! energy summed over angles, modes, frequencies [R Z3 T-2 ~> J m-2] tot_leak_loss, tot_quad_loss, tot_itidal_loss, tot_Froude_loss, tot_residual_loss, tot_allprocesses_loss, & ! energy loss rates summed over angle, freq, and mode [R Z3 T-3 ~> W m-2] htot, & ! The vertical sum of the layer thicknesses [H ~> m or kg m-2] - drag_scale, & ! bottom drag scale [T-1 ~> s-1] itidal_loss_mode, & ! Energy lost due to small-scale wave drag, summed over angles [R Z3 T-3 ~> W m-2] + leak_loss_mode, & + quad_loss_mode, & + Froude_loss_mode, & + residual_loss_mode, & allprocesses_loss_mode ! Total energy loss rates for a given mode and frequency (summed over ! all angles) [R Z3 T-3 ~> W m-2] + real :: frac_per_sector ! The inverse of the number of angular, modal and frequency bins [nondim] real :: f2 ! The squared Coriolis parameter interpolated to a tracer point [T-2 ~> s-2] real :: Kmag2 ! A squared horizontal wavenumber [L-2 ~> m-2] @@ -273,7 +291,10 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, en_subRO = 1e-30*US%W_m2_to_RZ3_T3*US%s_to_T ! initialize local arrays - drag_scale(:,:) = 0. + TKE_itidal_input(:,:,:) = 0. + vel_btTide(:,:,:) = 0. + tot_vel_btTide2(:,:) = 0. + drag_scale(:,:,:,:) = 0. Ub(:,:,:,:) = 0. Umax(:,:,:,:) = 0. @@ -329,24 +350,27 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, !enddo ; enddo ; enddo ! Add the forcing.*************************************************************** + + call get_input_TKE(G, TKE_itidal_input, CS%nFreq, inttide_input_CSp) + if (CS%energized_angle <= 0) then - frac_per_sector = 1.0 / real(CS%nAngle * CS%nMode * CS%nFreq) + frac_per_sector = 1.0 / real(CS%nAngle) do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) enddo ; enddo ; enddo ; enddo ; enddo elseif (CS%energized_angle <= CS%nAngle) then - frac_per_sector = 1.0 / real(CS%nMode * CS%nFreq) + frac_per_sector = 1.0 a = CS%energized_angle do m=1,CS%nMode ; do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie f2 = 0.25*((G%CoriolisBu(I,J)**2 + G%CoriolisBu(I-1,J-1)**2) + & (G%CoriolisBu(I-1,J)**2 + G%CoriolisBu(I,J-1)**2)) if (CS%frequency(fr)**2 > f2) & CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) + dt*frac_per_sector*(1.0-CS%q_itides) * & - TKE_itidal_input(i,j) + CS%fraction_tidal_input(fr,m) * TKE_itidal_input(i,j,fr) enddo ; enddo ; enddo ; enddo else call MOM_error(WARNING, "Internal tide energy is being put into a angular "//& @@ -397,6 +421,7 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Propagate the waves. do m=1,CS%nMode ; do fr=1,CS%Nfreq + ! initialize residual loss, will be computed in propagate CS%TKE_residual_loss(:,:,:,fr,m) = 0. call propagate(CS%En(:,:,:,fr,m), cn(:,:,m), CS%frequency(fr), dt, & @@ -479,29 +504,37 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! Extract the energy for mixing due to bottom drag------------------------------- if (CS%apply_bottom_drag) then - do j=js,je ; do i=is,ie ; htot(i,j) = 0.0 ; enddo ; enddo - do k=1,GV%ke ; do j=js,je ; do i=is,ie + do j=jsd,jed ; do i=isd,ied ; htot(i,j) = 0.0 ; enddo ; enddo + + call get_barotropic_tidal_vel(G, vel_btTide, CS%nFreq, inttide_input_CSp) + + do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied + tot_vel_btTide2(i,j) = tot_vel_btTide2(i,j) + vel_btTide(i,j,fr)**2 + enddo ; enddo ; enddo + + do k=1,GV%ke ; do j=jsd,jed ; do i=isd,ied htot(i,j) = htot(i,j) + h(i,j,k) enddo ; enddo ; enddo if (GV%Boussinesq) then ! This is mathematically equivalent to the form in the option below, but they differ at roundoff. - do j=js,je ; do i=is,ie + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_D_here = 1.0 / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + & - tot_En(i,j) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here - enddo ; enddo + drag_scale(i,j,fr,m) = CS%cdrag * sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * GV%RZ_to_H * I_D_here)) * GV%Z_to_H*I_D_here + enddo ; enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do m=1,CS%NMode ; do fr=1,CS%Nfreq ; do j=jsd,jed ; do i=isd,ied I_mass = GV%RZ_to_H / (max(htot(i,j), CS%drag_min_depth)) - drag_scale(i,j) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & - sqrt(max(0.0, US%L_to_Z**2*vel_btTide(i,j)**2 + tot_En(i,j) * I_mass)) - enddo ; enddo + drag_scale(i,j,fr,m) = (CS%cdrag * (Rho_bot(i,j)*I_mass)) * & + sqrt(max(0.0, US%L_to_Z**2*tot_vel_btTide2(i,j)**2 + & + tot_En_mode(i,j,fr,m) * I_mass)) + enddo ; enddo ; enddo ; enddo endif do m=1,CS%nMode ; do fr=1,CS%nFreq ; do a=1,CS%nAngle ; do j=js,je ; do i=is,ie ! Calculate loss rate and apply loss over the time step ; apply the same drag timescale ! to each En component (technically not correct; fix later) - CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j) ! loss rate - CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j)) ! implicit update + CS%TKE_quad_loss(i,j,a,fr,m) = CS%En(i,j,a,fr,m) * drag_scale(i,j,fr,m) ! loss rate + CS%En(i,j,a,fr,m) = CS%En(i,j,a,fr,m) / (1.0 + dt * drag_scale(i,j,fr,m)) ! implicit update enddo ; enddo ; enddo ; enddo ; enddo endif ! Check for En<0 - for debugging, delete later @@ -685,9 +718,14 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, ! 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) - if (CS%id_TKE_itidal_input > 0) call post_data(CS%id_TKE_itidal_input, & - TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_input(fr) > 0) call post_data(CS%id_TKE_itidal_input(fr), & + TKE_itidal_input(:,:,fr), CS%diag) + enddo + + do m=1,CS%nMode ; do fr=1,CS%nFreq + if (CS%id_itide_drag(fr,m) > 0) call post_data(CS%id_itide_drag(fr,m), drag_scale(:,:,fr,m), CS%diag) + enddo ; enddo ! Output 2-D energy density (summed over angles) for each frequency and mode do m=1,CS%nMode ; do fr=1,CS%Nfreq ; if (CS%id_En_mode(fr,m) > 0) then @@ -780,15 +818,27 @@ subroutine propagate_int_tide(h, tv, TKE_itidal_input, vel_btTide, Nb, Rho_bot, do m=1,CS%nMode ; do fr=1,CS%Nfreq if (CS%id_itidal_loss_mode(fr,m) > 0 .or. CS%id_allprocesses_loss_mode(fr,m) > 0) then itidal_loss_mode(:,:) = 0.0 ! wave-drag processes (could do others as well) + leak_loss_mode(:,:) = 0.0 + quad_loss_mode(:,:) = 0.0 + Froude_loss_mode(:,:) = 0.0 + residual_loss_mode(:,:) = 0.0 allprocesses_loss_mode(:,:) = 0.0 ! all processes summed together do a=1,CS%nAngle ; do j=js,je ; do i=is,ie itidal_loss_mode(i,j) = itidal_loss_mode(i,j) + CS%TKE_itidal_loss(i,j,a,fr,m) + leak_loss_mode(i,j) = leak_loss_mode(i,j) + CS%TKE_leak_loss(i,j,a,fr,m) + quad_loss_mode(i,j) = quad_loss_mode(i,j) + CS%TKE_quad_loss(i,j,a,fr,m) + Froude_loss_mode(i,j) = Froude_loss_mode(i,j) + CS%TKE_Froude_loss(i,j,a,fr,m) + residual_loss_mode(i,j) = residual_loss_mode(i,j) + CS%TKE_residual_loss(i,j,a,fr,m) allprocesses_loss_mode(i,j) = allprocesses_loss_mode(i,j) + & ((((CS%TKE_leak_loss(i,j,a,fr,m) + CS%TKE_quad_loss(i,j,a,fr,m)) + & CS%TKE_itidal_loss(i,j,a,fr,m)) + CS%TKE_Froude_loss(i,j,a,fr,m)) + & CS%TKE_residual_loss(i,j,a,fr,m)) enddo ; enddo ; enddo call post_data(CS%id_itidal_loss_mode(fr,m), itidal_loss_mode, CS%diag) + call post_data(CS%id_leak_loss_mode(fr,m), leak_loss_mode, CS%diag) + call post_data(CS%id_quad_loss_mode(fr,m), quad_loss_mode, CS%diag) + call post_data(CS%id_Froude_loss_mode(fr,m), Froude_loss_mode, CS%diag) + call post_data(CS%id_residual_loss_mode(fr,m), residual_loss_mode, CS%diag) call post_data(CS%id_allprocesses_loss_mode(fr,m), allprocesses_loss_mode, CS%diag) endif ; enddo ; enddo @@ -2501,6 +2551,7 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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] real :: period_1 ! The period of the gravest modeled mode [T ~> s] + real :: period ! A tidal period read from namelist [T ~> s] integer :: num_angle, num_freq, num_mode, m, fr integer :: isd, ied, jsd, jed, a, id_ang, i, j, nz type(axes_grp) :: axes_ang @@ -2516,6 +2567,9 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) character(len=200) :: h2_file character(len=80) :: rough_var ! Input file variable names + character(len=240), dimension(:), allocatable :: energy_fractions + character(len=240) :: periods + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed nz = GV%ke @@ -2539,17 +2593,29 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) if (.not.((num_freq > 0) .and. (num_angle > 0) .and. (num_mode > 0))) return CS%nFreq = num_freq ; CS%nAngle = num_angle ; CS%nMode = num_mode + allocate(energy_fractions(num_freq)) + allocate(CS%fraction_tidal_input(num_freq,num_mode)) + + call read_param(param_file, "ENERGY_FRACTION_PER_MODE", energy_fractions) + + do fr=1,num_freq ; do m=1,num_mode + CS%fraction_tidal_input(fr,m) = extract_real(energy_fractions(fr), " ,", m, 0.) + enddo ; enddo + ! Allocate phase speed array allocate(CS%cp(isd:ied, jsd:jed, num_freq, num_mode), source=0.0) ! Allocate and populate frequency array (each a multiple of first for now) allocate(CS%frequency(num_freq)) - call get_param(param_file, mdl, "FIRST_MODE_PERIOD", period_1, & - "The period of the first mode for internal tides", default=44567., & - units="s", scale=US%s_to_T) + + + ! The periods of the tidal constituents for internal tides raytracing + call read_param(param_file, "TIDAL_PERIODS", periods) do fr=1,num_freq - CS%frequency(fr) = (8.0*atan(1.0) * (real(fr)) / period_1) ! ADDED BDM + period = extract_real(periods, " ,", fr, 0.) + if (period == 0.) call MOM_error(FATAL, "MOM_internal_tides: invalid tidal period") + CS%frequency(fr) = 8.0*atan(1.0)/period enddo ! Read all relevant parameters and write them to the model log. @@ -2858,14 +2924,18 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_tot_En = register_diag_field('ocean_model', 'ITide_tot_En', diag%axesT1, & Time, 'Internal tide total energy density', & 'J m-2', conversion=US%RZ3_T3_to_W_m2*US%T_to_s) - ! Register 2-D drag scale used for quadratic bottom drag - CS%id_itide_drag = register_diag_field('ocean_model', 'ITide_drag', diag%axesT1, & - Time, 'Interior and bottom drag internal tide decay timescale', 's-1', conversion=US%s_to_T) - !Register 2-D energy input into internal tides - CS%id_TKE_itidal_input = register_diag_field('ocean_model', 'TKE_itidal_input', diag%axesT1, & - Time, 'Conversion from barotropic to baroclinic tide, '//& - 'a fraction of which goes into rays', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + + allocate(CS%id_itide_drag(CS%nFreq, CS%nMode), source=-1) + allocate(CS%id_TKE_itidal_input(CS%nFreq), source=-1) + do fr=1,CS%nFreq + ! Register 2-D energy input into internal tides for each frequency + write(var_name, '("TKE_itidal_input_freq",i1)') fr + write(var_descript, '("a fraction of which goes into rays in frequency ",i1)') fr + + CS%id_TKE_itidal_input(fr) = register_diag_field('ocean_model', var_name, diag%axesT1, & + Time, 'Conversion from barotropic to baroclinic tide, '//& + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo ! Register 2-D energy losses (summed over angles, freq, modes) CS%id_tot_leak_loss = register_diag_field('ocean_model', 'ITide_tot_leak_loss', diag%axesT1, & Time, 'Internal tide energy loss to background drag', & @@ -2889,6 +2959,10 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) allocate(CS%id_En_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_En_ang_mode(CS%nFreq,CS%nMode), source=-1) allocate(CS%id_itidal_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_leak_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_quad_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_Froude_loss_mode(CS%nFreq,CS%nMode), source=-1) + allocate(CS%id_residual_loss_mode(CS%nFreq,CS%nMode), source=-1) 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) @@ -2929,6 +3003,30 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) CS%id_itidal_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Leakage loss + write(var_name, '("Itide_leak_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy loss due to leakage from frequency ",i1," mode ",i1)') fr, m + CS%id_leak_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Quad loss + write(var_name, '("Itide_quad_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy quad loss from frequency ",i1," mode ",i1)') fr, m + CS%id_quad_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! Froude loss + write(var_name, '("Itide_froude_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy Froude loss from frequency ",i1," mode ",i1)') fr, m + CS%id_froude_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) + ! residual losses + write(var_name, '("Itide_residual_loss_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Internal tide energy residual loss from frequency ",i1," mode ",i1)') fr, m + CS%id_residual_loss_mode(fr,m) = register_diag_field('ocean_model', var_name, & + diag%axesT1, Time, var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + call MOM_mesg("Registering "//trim(var_name)//", Described as: "//var_descript, 5) ! all loss processes write(var_name, '("Itide_allprocesses_loss_freq",i1,"_mode",i1)') fr, m write(var_descript, '("Internal tide energy loss due to all processes from frequency ",i1," mode ",i1)') fr, m @@ -2958,6 +3056,12 @@ subroutine internal_tides_init(Time, G, GV, US, param_file, diag, CS) 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) + ! Register 2-D drag scale used for quadratic bottom drag for each frequency and mode + write(var_name, '("ITide_drag_freq",i1,"_mode",i1)') fr, m + write(var_descript, '("Interior and bottom drag int tide decay timescale in frequency ",i1, " mode ",i1)') fr, m + + CS%id_itide_drag(fr,m) = register_diag_field('ocean_model', var_name, diag%axesT1, Time, & + 's-1', conversion=US%s_to_T) enddo ; enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 5b89c8c726..097628c032 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -391,8 +391,9 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & call set_int_tide_input(u, v, h, tv, fluxes, CS%int_tide_input, dt, G, GV, US, & CS%int_tide_input_CSp) - call propagate_int_tide(h, tv, CS%int_tide_input%TKE_itidal_input, CS%int_tide_input%tideamp, & - CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, G, GV, US, CS%int_tide_CSp) + call propagate_int_tide(h, tv, CS%int_tide_input%Nb, CS%int_tide_input%Rho_bot, dt, & + G, GV, US, CS%int_tide_input_CSp, CS%int_tide_CSp) + if (showCallTree) call callTree_waypoint("done with propagate_int_tide (diabatic)") endif ! end CS%use_int_tides diff --git a/src/parameterizations/vertical/MOM_internal_tide_input.F90 b/src/parameterizations/vertical/MOM_internal_tide_input.F90 index 3da21b48fb..7280106125 100644 --- a/src/parameterizations/vertical/MOM_internal_tide_input.F90 +++ b/src/parameterizations/vertical/MOM_internal_tide_input.F90 @@ -11,11 +11,13 @@ module MOM_int_tide_input use MOM_debugging, only : hchksum use MOM_error_handler, only : MOM_error, is_root_pe, FATAL, WARNING, NOTE use MOM_file_parser, only : get_param, log_param, log_version, param_file_type +use MOM_file_parser, only : read_param use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_io, only : slasher, vardesc, MOM_read_data use MOM_interface_heights, only : thickness_to_dz, find_rho_bottom use MOM_isopycnal_slopes, only : vert_fill_TS +use MOM_string_functions, only : extractWord use MOM_time_manager, only : time_type, set_time, operator(+), operator(<=) use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, p3d @@ -27,6 +29,7 @@ module MOM_int_tide_input #include public set_int_tide_input, int_tide_input_init, int_tide_input_end +public get_input_TKE, get_barotropic_tidal_vel ! 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 @@ -44,9 +47,13 @@ module MOM_int_tide_input real :: kappa_fill !< Vertical diffusivity used to interpolate sensible values !! of T & S into thin layers [H Z T-1 ~> m2 s-1 or kg m-1 s-1] - real, allocatable, dimension(:,:) :: TKE_itidal_coef + real, allocatable, dimension(:,:,:) :: TKE_itidal_coef !< The time-invariant field that enters the TKE_itidal input calculation noting that the !! stratification and perhaps density are time-varying [R Z4 H-1 T-2 ~> J m-2 or J m kg-1]. + real, allocatable, dimension(:,:,:) :: & + TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. + tideamp !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. + character(len=200) :: inputdir !< The directory for input files. logical :: int_tide_source_test !< If true, apply an arbitrary generation site @@ -59,19 +66,19 @@ module MOM_int_tide_input integer :: int_tide_source_i !< I Location of generation site integer :: int_tide_source_j !< J Location of generation site logical :: int_tide_use_glob_ij !< Use global indices for generation site + integer :: nFreq = 0 !< The number of internal tide frequency bands !>@{ Diagnostic IDs - integer :: id_TKE_itidal_itide = -1, id_Nb = -1, id_N2_bot = -1 + integer, allocatable, dimension(:) :: id_TKE_itidal_itide + integer :: id_Nb = -1, id_N2_bot = -1 !>@} end type int_tide_input_CS !> This type is used to exchange fields related to the internal tides. type, public :: int_tide_input_type real, allocatable, dimension(:,:) :: & - TKE_itidal_input, & !< The internal tide TKE input at the bottom of the ocean [R Z3 T-3 ~> W m-2]. h2, & !< The squared topographic roughness height [Z2 ~> m2]. - tideamp, & !< The amplitude of the tidal velocities [Z T-1 ~> m s-1]. Nb, & !< The bottom stratification [T-1 ~> s-1]. Rho_bot !< The bottom density or the Boussinesq reference density [R ~> kg m-3]. end type int_tide_input_type @@ -110,6 +117,7 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) integer :: i, j, is, ie, js, je, nz, isd, ied, jsd, jed integer :: i_global, j_global + integer :: fr is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -133,52 +141,55 @@ subroutine set_int_tide_input(u, v, h, tv, fluxes, itide, dt, G, GV, US, CS) if (GV%Boussinesq .or. GV%semi_Boussinesq) then !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) - itide%TKE_itidal_input(i,j) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), CS%TKE_itide_max) - enddo ; enddo + CS%TKE_itidal_input(i,j,fr) = min(GV%Z_to_H*CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), CS%TKE_itide_max) + enddo ; enddo ; enddo else !$OMP parallel do default(shared) - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie itide%Nb(i,j) = G%mask2dT(i,j) * sqrt(N2_bot(i,j)) itide%Rho_bot(i,j) = G%mask2dT(i,j) * Rho_bot(i,j) - itide%TKE_itidal_input(i,j) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j)*itide%Nb(i,j), & + CS%TKE_itidal_input(i,j,fr) = min((GV%RZ_to_H*Rho_bot(i,j)) * CS%TKE_itidal_coef(i,j,fr)*itide%Nb(i,j), & CS%TKE_itide_max) - enddo ; enddo + enddo ; enddo ; enddo endif if (CS%int_tide_source_test) then - itide%TKE_itidal_input(:,:) = 0.0 + CS%TKE_itidal_input(:,:,:) = 0.0 if (time_end <= CS%time_max_source) then if (CS%int_tide_use_glob_ij) then - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie i_global = i + G%idg_offset j_global = j + G%jdg_offset if ((i_global == CS%int_tide_source_i) .and. (j_global == CS%int_tide_source_j)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif - enddo ; enddo + enddo ; enddo ; enddo else - do j=js,je ; do i=is,ie + do fr=1,CS%nFreq ; do j=js,je ; do i=is,ie ! Input an arbitrary energy point source.id_ if (((G%geoLonCu(I-1,j)-CS%int_tide_source_x) * (G%geoLonBu(I,j)-CS%int_tide_source_x) <= 0.0) .and. & ((G%geoLatCv(i,J-1)-CS%int_tide_source_y) * (G%geoLatCv(i,j)-CS%int_tide_source_y) <= 0.0)) then - itide%TKE_itidal_input(i,j) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 + CS%TKE_itidal_input(i,j,fr) = 1.0*US%kg_m3_to_R*US%m_to_Z**3*US%T_to_s**3 endif - enddo ; enddo + enddo ; enddo ; enddo endif endif endif if (CS%debug) then call hchksum(N2_bot,"N2_bot",G%HI,haloshift=0, scale=US%s_to_T**2) - call hchksum(itide%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & + call hchksum(CS%TKE_itidal_input,"TKE_itidal_input",G%HI,haloshift=0, & scale=US%RZ3_T3_to_W_m2) endif call enable_averages(dt, time_end, CS%diag) - if (CS%id_TKE_itidal_itide > 0) call post_data(CS%id_TKE_itidal_itide, itide%TKE_itidal_input, CS%diag) + do fr=1,CS%nFreq + if (CS%id_TKE_itidal_itide(fr) > 0) call post_data(CS%id_TKE_itidal_itide(fr), & + CS%TKE_itidal_input(isd:ied,jsd:jed,fr), CS%diag) + enddo if (CS%id_Nb > 0) call post_data(CS%id_Nb, itide%Nb, CS%diag) if (CS%id_N2_bot > 0 ) call post_data(CS%id_N2_bot, N2_bot, CS%diag) @@ -319,6 +330,38 @@ subroutine find_N2_bottom(h, tv, T_f, S_f, h2, fluxes, G, GV, US, N2_bot, rho_bo end subroutine find_N2_bottom +!> Returns TKE_itidal_input +subroutine get_input_TKE(G, TKE_itidal_input, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: TKE_itidal_input !< The energy input to the internal waves [R Z3 T-3 ~> W m-2]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + TKE_itidal_input(i,j,fr) = CS%TKE_itidal_input(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_input_TKE + +!> Returns barotropic tidal velocities +subroutine get_barotropic_tidal_vel(G, vel_btTide, nFreq, CS) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + real, dimension(SZI_(G),SZJ_(G),nFreq), & + intent(out) :: vel_btTide !< Barotropic velocity read from file [L T-1 ~> m s-1]. + integer, intent(in) :: nFreq !< number of frequencies + type(int_tide_input_CS), target :: CS !< A pointer that is set to point to the control + !! structure for the internal tide input module. + integer :: i,j,fr + + do fr=1,nFreq ; do j=G%jsd,G%jed ; do i=G%isd,G%ied + vel_btTide(i,j,fr) = CS%tideamp(i,j,fr) + enddo ; enddo ; enddo + +end subroutine get_barotropic_tidal_vel + !> Initializes the data related to the internal tide input module subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) type(time_type), intent(in) :: Time !< The current model time @@ -337,6 +380,9 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) character(len=40) :: mdl = "MOM_int_tide_input" ! This module's name. character(len=200) :: filename, tideamp_file, h2_file ! Input file names or paths character(len=80) :: tideamp_var, rough_var ! Input file variable names + character(len=80) :: var_name + character(len=200) :: var_descript + character(len=200) :: tidefile_varnames real :: mask_itidal ! A multiplicative land mask, 0 or 1 [nondim] real :: max_frac_rough ! The fraction relating the maximum topographic roughness @@ -349,6 +395,7 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) integer :: tlen_days !< Time interval from start for adding wave source !! for testing internal tides (BDM) integer :: i, j, is, ie, js, je, isd, ied, jsd, jed + integer :: num_freq, fr if (associated(CS)) then call MOM_error(WARNING, "int_tide_input_init called with an associated "// & @@ -390,12 +437,15 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "The constant tidal amplitude used with INT_TIDE_DISSIPATION.", & units="m s-1", default=0.0, scale=US%m_s_to_L_T) + call read_param(param_file, "INTERNAL_TIDE_FREQS", num_freq) + CS%nFreq= num_freq + allocate(itide%Nb(isd:ied,jsd:jed), source=0.0) allocate(itide%Rho_bot(isd:ied,jsd:jed), source=0.0) allocate(itide%h2(isd:ied,jsd:jed), source=0.0) - allocate(itide%TKE_itidal_input(isd:ied,jsd:jed), source=0.0) - allocate(itide%tideamp(isd:ied,jsd:jed), source=utide) - allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed), source=0.0) + allocate(CS%TKE_itidal_input(isd:ied,jsd:jed,num_freq), source=0.0) + allocate(CS%tideamp(isd:ied,jsd:jed,num_freq), source=utide) + allocate(CS%TKE_itidal_coef(isd:ied,jsd:jed, num_freq), source=0.0) call get_param(param_file, mdl, "KAPPA_ITIDES", kappa_itides, & "A topographic wavenumber used with INT_TIDE_DISSIPATION. "//& @@ -419,10 +469,13 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) "tidal amplitudes with INT_TIDE_DISSIPATION.", default="tideamp.nc") filename = trim(CS%inputdir) // trim(tideamp_file) call log_param(param_file, mdl, "INPUTDIR/TIDEAMP_FILE", filename) - call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & - "The name of the tidal amplitude variable in the input file.", & - default="tideamp") - call MOM_read_data(filename, tideamp_var, itide%tideamp, G%domain, scale=US%m_s_to_L_T) + + call read_param(param_file, "INTTIDE_AMP_VARNAMES", tidefile_varnames) + do fr=1,num_freq + tideamp_var = extractWord(tidefile_varnames,fr) + call MOM_read_data(filename, tideamp_var, CS%tideamp(:,:,fr), G%domain, scale=US%m_s_to_L_T) + enddo + endif call get_param(param_file, mdl, "H2_FILE", h2_file, & @@ -475,25 +528,31 @@ subroutine int_tide_input_init(Time, G, GV, US, param_file, diag, CS, itide) endif endif - do j=js,je ; do i=is,ie + do fr=1,num_freq ; do j=js,je ; do i=is,ie mask_itidal = 1.0 if (G%bathyT(i,j) + G%Z_ref < min_zbot_itides) mask_itidal = 0.0 - itide%tideamp(i,j) = itide%tideamp(i,j) * mask_itidal * G%mask2dT(i,j) + CS%tideamp(i,j,fr) = CS%tideamp(i,j,fr) * mask_itidal * G%mask2dT(i,j) ! Restrict rms topo to a fraction (often 10 percent) of the column depth. if (max_frac_rough >= 0.0) & itide%h2(i,j) = min((max_frac_rough*(G%bathyT(i,j)+G%Z_ref))**2, itide%h2(i,j)) ! Compute the fixed part of internal tidal forcing; units are [R Z4 H-1 T-2 ~> J m-2 or J m kg-1] here. - CS%TKE_itidal_coef(i,j) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & - kappa_itides * itide%h2(i,j) * itide%tideamp(i,j)**2 - enddo ; enddo + CS%TKE_itidal_coef(i,j,fr) = 0.5*US%L_to_Z*kappa_h2_factor * GV%H_to_RZ * & + kappa_itides * itide%h2(i,j) * CS%tideamp(i,j,fr)**2 + enddo ; enddo ; enddo - CS%id_TKE_itidal_itide = register_diag_field('ocean_model','TKE_itidal_itide',diag%axesT1,Time, & - 'Internal Tide Driven Turbulent Kinetic Energy', & - 'W m-2', conversion=US%RZ3_T3_to_W_m2) + allocate( CS%id_TKE_itidal_itide(num_freq), source=-1) + + do fr=1,num_freq + write(var_name, '("TKE_itidal_itide_freq",i1)') fr + write(var_descript, '("Internal Tide Driven Turbulent Kinetic Energy in frequency ",i1)') fr + + CS%id_TKE_itidal_itide(fr) = register_diag_field('ocean_model',var_name,diag%axesT1,Time, & + var_descript, 'W m-2', conversion=US%RZ3_T3_to_W_m2) + enddo CS%id_Nb = register_diag_field('ocean_model','Nb_itide',diag%axesT1,Time, & 'Bottom Buoyancy Frequency', 's-1', conversion=US%s_to_T) From d210cc6cdfd03150306c8ba41612e3380d66c281 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 16 Aug 2023 17:11:35 -0400 Subject: [PATCH 464/629] +Remove build_grid_arbitrary Removed the unused (and unusable) routine build_grid_arbitrary. This routine could not have been used because it had a hard-coded STOP call, and comments in it indicated that it should have been deleted in July, 2013. The run-time parameter setting that would have triggered a call to this routine has been retained for now, but with a fatal error message explaining that this routine has not been implemented. All answers are bitwise identical in any cases that ran before. --- src/ALE/MOM_regridding.F90 | 111 +------------------------------------ 1 file changed, 3 insertions(+), 108 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 1b006dbbd3..8ef0679358 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -855,9 +855,6 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & case ( REGRIDDING_RHO ) call build_rho_grid( G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS, frac_shelf_h ) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) - case ( REGRIDDING_ARBITRARY ) - call build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, trickGnuCompiler, CS ) - call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) case ( REGRIDDING_HYCOM1 ) call build_grid_HyCOM1( G, GV, G%US, h, nom_depth_H, tv, h_new, dzInterface, remapCS, CS, & frac_shelf_h, zScale=Z_to_H ) @@ -868,6 +865,9 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & call build_grid_adaptive(G, GV, G%US, h, nom_depth_H, tv, dzInterface, remapCS, CS) call calc_h_new_by_dz(CS, G, GV, h, dzInterface, h_new) + case ( REGRIDDING_ARBITRARY ) + call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& + 'Regridding mode "ARB" is not implemented.') case default call MOM_error(FATAL,'MOM_regridding, regridding_main: '//& 'Unknown regridding scheme selected!') @@ -1762,111 +1762,6 @@ subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) end subroutine adjust_interface_motion -!------------------------------------------------------------------------------ -! Build arbitrary grid -!------------------------------------------------------------------------------ -subroutine build_grid_arbitrary( G, GV, h, nom_depth_H, dzInterface, h_new, CS ) -!------------------------------------------------------------------------------ -! This routine builds a grid based on arbitrary rules -!------------------------------------------------------------------------------ - - ! Arguments - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Original layer thicknesses [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: nom_depth_H !< The bathymetric depth of this column - !! relative to mean sea level or another locally - !! valid reference height, converted to thickness - !! units [H ~> m or kg m-2] - type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< The change in interface - !! depth [H ~> m or kg m-2] - real, intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] - - ! Local variables - integer :: i, j, k - integer :: nz - real :: z_inter(SZK_(GV)+1) - real :: total_height - real :: delta_h - real :: max_depth - real :: eta ! local elevation [H ~> m or kg m-2] - real :: local_depth ! The local ocean depth relative to mean sea level in thickness units [H ~> m or kg m-2] - real :: x1, y1, x2, y2 - real :: x, t - - nz = GV%ke - max_depth = G%max_depth*GV%Z_to_H - - do j = G%jsc-1,G%jec+1 - do i = G%isc-1,G%iec+1 - - ! Local depth - local_depth = nom_depth_H(i,j) - - ! Determine water column height - total_height = 0.0 - do k = 1,nz - total_height = total_height + h(i,j,k) - enddo - - eta = total_height - local_depth - - ! Compute new thicknesses based on stretched water column - delta_h = (max_depth + eta) / nz - - ! Define interfaces - z_inter(1) = eta - do k = 1,nz - z_inter(k+1) = z_inter(k) - delta_h - enddo - - ! Refine grid in the middle - do k = 1,nz+1 - x1 = 0.35; y1 = 0.45; x2 = 0.65; y2 = 0.55 - - x = - ( z_inter(k) - eta ) / max_depth - - if ( x <= x1 ) then - t = y1*x/x1 - elseif ( (x > x1 ) .and. ( x < x2 )) then - t = y1 + (y2-y1) * (x-x1) / (x2-x1) - else - t = y2 + (1.0-y2) * (x-x2) / (1.0-x2) - endif - - z_inter(k) = -t * max_depth + eta - - enddo - - ! Modify interface heights to account for topography - z_inter(nz+1) = - local_depth - - ! Modify interface heights to avoid layers of zero thicknesses - do k = nz,1,-1 - if ( z_inter(k) < (z_inter(k+1) + CS%min_thickness) ) then - z_inter(k) = z_inter(k+1) + CS%min_thickness - endif - enddo - - ! Change in interface position - x = 0. ! Left boundary at x=0 - dzInterface(i,j,1) = 0. - do k = 2,nz - x = x + h(i,j,k) - dzInterface(i,j,k) = z_inter(k) - x - enddo - dzInterface(i,j,nz+1) = 0. - - enddo - enddo - -stop 'OOOOOOPS' ! For some reason the gnu compiler will not let me delete this - ! routine???? - -end subroutine build_grid_arbitrary - - !------------------------------------------------------------------------------ ! Check grid integrity From 467d1dd016317c2bbd51586ef3960383abc87f31 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 16 Aug 2023 17:13:38 -0400 Subject: [PATCH 465/629] +Remove rescale_grid_bathymetry Removed the unused routine rescale_grid_bathymetry. This routine was added in August 2018 as a part of the development of the depth unit conversion and dimensional consistency testing, but it is no longer being called now that this conversion is essentially complete (and it has not been called by the code in several years). For the original commit that first added this code, see github.com/mom-ocean/MOM6/commit/ddc9ed1c33a1b7357b213929118ecaa19ae63f9f. All answers are bitwise identical. --- src/core/MOM.F90 | 2 +- src/core/MOM_grid.F90 | 36 +----------------------------------- 2 files changed, 2 insertions(+), 36 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 64e96bdf10..bb890d2d87 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -89,7 +89,7 @@ module MOM use MOM_forcing_type, only : copy_common_forcing_fields, set_derived_forcing_fields use MOM_forcing_type, only : homogenize_forcing, homogenize_mech_forcing use MOM_grid, only : ocean_grid_type, MOM_grid_init, MOM_grid_end -use MOM_grid, only : set_first_direction, rescale_grid_bathymetry +use MOM_grid, only : set_first_direction 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, calc_derived_thermo, thickness_to_dz diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 2e413e505b..9cbf420b23 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -15,7 +15,7 @@ module MOM_grid #include public MOM_grid_init, MOM_grid_end, set_derived_metrics, set_first_direction -public isPointInCell, hor_index_type, get_global_grid_size, rescale_grid_bathymetry +public isPointInCell, hor_index_type, get_global_grid_size ! 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 @@ -400,40 +400,6 @@ subroutine MOM_grid_init(G, param_file, US, HI, global_indexing, bathymetry_at_v end subroutine MOM_grid_init -!> rescale_grid_bathymetry permits a change in the internal units for the bathymetry on the grid, -!! both rescaling the depths and recording the new internal units. -subroutine rescale_grid_bathymetry(G, m_in_new_units) - type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure - real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. - !### It appears that this routine is never called. - - ! Local variables - real :: rescale ! A unit rescaling factor [various combinations of units ~> 1] - integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB - - isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed - IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB - - if (m_in_new_units == 1.0) return - if (m_in_new_units < 0.0) & - call MOM_error(FATAL, "rescale_grid_bathymetry: Negative depth units are not permitted.") - if (m_in_new_units == 0.0) & - call MOM_error(FATAL, "rescale_grid_bathymetry: Zero depth units are not permitted.") - - rescale = 1.0 / m_in_new_units - do j=jsd,jed ; do i=isd,ied - G%bathyT(i,j) = rescale*G%bathyT(i,j) - enddo ; enddo - if (G%bathymetry_at_vel) then ; do j=jsd,jed ; do I=IsdB,IedB - G%Dblock_u(I,j) = rescale*G%Dblock_u(I,j) ; G%Dopen_u(I,j) = rescale*G%Dopen_u(I,j) - enddo ; enddo ; endif - if (G%bathymetry_at_vel) then ; do J=JsdB,JedB ; do i=isd,ied - G%Dblock_v(i,J) = rescale*G%Dblock_v(i,J) ; G%Dopen_v(i,J) = rescale*G%Dopen_v(i,J) - enddo ; enddo ; endif - G%max_depth = rescale*G%max_depth - -end subroutine rescale_grid_bathymetry - !> set_derived_metrics calculates metric terms that are derived from other metrics. subroutine set_derived_metrics(G, US) type(ocean_grid_type), intent(inout) :: G !< The horizontal grid structure From 19f0147067db2d8ec8fb8919bdaa4ee622edd94e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 13 Oct 2023 08:34:37 -0400 Subject: [PATCH 466/629] +Fix dimensional rescaling with HARMONICS_SAL Corrected dimensional rescaling bugs in the spherical harmonics SAL code. An issue with horizontal length scaling was corrected by using G%Rad_Earth_L in place of G%Rad_Earth in spherical_harmonics_init. There are new optional tmp_scale arguments to calc_SAL and spherical_harmonics_forward to allow the rescaling to be undone before calling the reproducing sums. This commit also modifies the call to the reproducing sums in spherical_harmonics_forward so that all real or imaginary components are calculated with a single call, which reduces the cost of the SAL calculation reproducing sums from about 6.7 times the cost with non-reproducing sums to just 5.5 times as much in testing with the tides_025 test case. There is also code added to avoid NaNs arising from a square root operating on a negative argument from a 32-bit integer roll-over when a very large number of harmonics components (more than 1024 x 1024) are unadvisedly being used. While this commit corrects the dimensional scaling when HARMONICS_SAL is true, all answers are bitwise identical when no rescaling is used or when the spherical harmonics SAL is not used. There are new optional arguments to two publicly visible interfaces. --- src/core/MOM_PressureForce_FV.F90 | 6 +-- src/core/MOM_PressureForce_Montgomery.F90 | 4 +- .../lateral/MOM_self_attr_load.F90 | 14 ++++--- .../lateral/MOM_spherical_harmonics.F90 | 42 ++++++++++++------- 4 files changed, 41 insertions(+), 25 deletions(-) diff --git a/src/core/MOM_PressureForce_FV.F90 b/src/core/MOM_PressureForce_FV.F90 index 64df200f31..5fb3ade634 100644 --- a/src/core/MOM_PressureForce_FV.F90 +++ b/src/core/MOM_PressureForce_FV.F90 @@ -319,7 +319,7 @@ subroutine PressureForce_FV_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_ SSH(i,j) = (za(i,j) - alpha_ref*p(i,j,1)) * I_gEarth - G%Z_ref & - max(-G%bathyT(i,j)-G%Z_ref, 0.0) enddo ; enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) if ((CS%tides_answer_date>20230630) .or. (.not.GV%semi_Boussinesq) .or. (.not.CS%tides)) then !$OMP parallel do default(shared) @@ -587,7 +587,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) @@ -618,7 +618,7 @@ subroutine PressureForce_FV_Bouss(h, tv, PFu, PFv, G, GV, US, CS, ALE_CSp, p_atm SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) else !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 diff --git a/src/core/MOM_PressureForce_Montgomery.F90 b/src/core/MOM_PressureForce_Montgomery.F90 index 3de713c801..6d982bc7e3 100644 --- a/src/core/MOM_PressureForce_Montgomery.F90 +++ b/src/core/MOM_PressureForce_Montgomery.F90 @@ -216,7 +216,7 @@ subroutine PressureForce_Mont_nonBouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pb enddo ; enddo ; enddo endif - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 geopot_bot(i,j) = geopot_bot(i,j) - GV%g_Earth*e_sal(i,j) @@ -481,7 +481,7 @@ subroutine PressureForce_Mont_Bouss(h, tv, PFu, PFv, G, GV, US, CS, p_atm, pbce, SSH(i,j) = SSH(i,j) + h(i,j,k)*GV%H_to_Z enddo ; enddo enddo - call calc_SAL(SSH, e_sal, G, CS%SAL_CSp) + call calc_SAL(SSH, e_sal, G, CS%SAL_CSp, tmp_scale=US%Z_to_m) !$OMP parallel do default(shared) do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 e(i,j,nz+1) = e(i,j,nz+1) - e_sal(i,j) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index 20d239eb53..7f7215c9d8 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -42,19 +42,21 @@ module MOM_self_attr_load !! be changed into bottom pressure anomaly in the future. Note that the SAL calculation applies to all motions !! across the spectrum. Tidal-specific methods that assume periodicity, i.e. iterative and read-in SAL, are !! stored in MOM_tidal_forcing module. -subroutine calc_SAL(eta, eta_sal, G, CS) +subroutine calc_SAL(eta, eta_sal, G, CS, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: eta !< The sea surface height anomaly from !! a time-mean geoid [Z ~> m]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_sal !< The sea surface height anomaly from !! self-attraction and loading [Z ~> m]. type(SAL_CS), intent(inout) :: CS !< The control structure returned by a previous call to SAL_init. + real, optional, intent(in) :: tmp_scale !< A rescaling factor to temporarily convert eta + !! to MKS units in reproducing sumes [m Z-1 ~> 1] ! Local variables integer :: n, m, l integer :: Isq, Ieq, Jsq, Jeq integer :: i, j - real :: eta_prop + real :: eta_prop ! The scalar constant of proportionality between eta and eta_sal [nondim] call cpu_clock_begin(id_clock_SAL) @@ -69,7 +71,7 @@ subroutine calc_SAL(eta, eta_sal, G, CS) ! use the spherical harmonics method elseif (CS%use_sal_sht) then - call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd) + call spherical_harmonics_forward(G, CS%sht, eta, CS%Snm_Re, CS%Snm_Im, CS%sal_sht_Nd, tmp_scale=tmp_scale) ! Multiply scaling factors to each mode do m = 0,CS%sal_sht_Nd @@ -119,8 +121,8 @@ subroutine calc_love_scaling(nlm, rhoW, rhoE, Love_Scaling) real, dimension(:), intent(out) :: Love_Scaling !< Scaling factors for inverse SHT [nondim] ! Local variables - real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames - real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers + real, dimension(:), allocatable :: HDat, LDat, KDat ! Love numbers converted in CF reference frames [nondim] + real :: H1, L1, K1 ! Temporary variables to store degree 1 Love numbers [nondim] integer :: n_tot ! Size of the stored Love numbers integer :: n, m, l @@ -163,7 +165,7 @@ subroutine SAL_init(G, US, param_file, CS) logical :: calculate_sal logical :: tides, use_tidal_sal_file - real :: tide_sal_scalar_value + real :: tide_sal_scalar_value ! Scaling SAL factor [nondim] ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") diff --git a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 index 2a72d26a20..26258e6b8e 100644 --- a/src/parameterizations/lateral/MOM_spherical_harmonics.F90 +++ b/src/parameterizations/lateral/MOM_spherical_harmonics.F90 @@ -42,7 +42,7 @@ module MOM_spherical_harmonics contains !> Calculates forward spherical harmonics transforms -subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) +subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(sht_CS), intent(inout) :: CS !< Control structure for SHT real, dimension(SZI_(G),SZJ_(G)), & @@ -51,13 +51,20 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) real, intent(out) :: Snm_Im(:) !< SHT coefficients for the imaginary modes (sine) [A] integer, optional, intent(in) :: Nd !< Maximum degree of the spherical harmonics !! overriding ndegree in the CS [nondim] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor to convert + !! var to MKS units during the reproducing + !! sums [a A-1 ~> 1] ! local variables - integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics [nondim] - integer :: Ltot ! Local copy of the number of spherical harmonics [nondim] + integer :: Nmax ! Local copy of the maximum degree of the spherical harmonics + integer :: Ltot ! Local copy of the number of spherical harmonics real, dimension(SZI_(G),SZJ_(G)) :: & pmn, & ! Current associated Legendre polynomials of degree n and order m [nondim] pmnm1, & ! Associated Legendre polynomials of degree n-1 and order m [nondim] pmnm2 ! Associated Legendre polynomials of degree n-2 and order m [nondim] + real :: scale ! A rescaling factor to temporarily convert var to MKS units during the + ! reproducing sums [a A-1 ~> 1] + real :: I_scale ! The inverse of scale [A a-1 ~> 1] + real :: sum_tot ! The total of all components output by the reproducing sum in arbitrary units [a] integer :: i, j, k integer :: is, ie, js, je, isd, ied, jsd, jed integer :: m, n, l @@ -81,12 +88,13 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) do l=1,Ltot ; Snm_Re(l) = 0.0; Snm_Im(l) = 0.0 ; enddo if (CS%reprod_sum) then + scale = 1.0 ; if (present(tmp_scale)) scale = tmp_scale do m=0,Nmax l = order2index(m, Nmax) do j=js,je ; do i=is,ie - CS%Snm_Re_raw(i,j,l) = var(i,j) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) - CS%Snm_Im_raw(i,j,l) = var(i,j) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) + CS%Snm_Re_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%cos_lonT_wtd(i,j,m+1) + CS%Snm_Im_raw(i,j,l) = (scale*var(i,j)) * CS%Pmm(i,j,m+1) * CS%sin_lonT_wtd(i,j,m+1) pmnm2(i,j) = 0.0 pmnm1(i,j) = CS%Pmm(i,j,m+1) enddo ; enddo @@ -94,8 +102,8 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) do n = m+1, Nmax ; do j=js,je ; do i=is,ie pmn(i,j) = & CS%a_recur(n+1,m+1) * CS%cos_clatT(i,j) * pmnm1(i,j) - CS%b_recur(n+1,m+1) * pmnm2(i,j) - CS%Snm_Re_raw(i,j,l+n-m) = var(i,j) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) - CS%Snm_Im_raw(i,j,l+n-m) = var(i,j) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) + CS%Snm_Re_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%cos_lonT_wtd(i,j,m+1) + CS%Snm_Im_raw(i,j,l+n-m) = (scale*var(i,j)) * pmn(i,j) * CS%sin_lonT_wtd(i,j,m+1) pmnm2(i,j) = pmnm1(i,j) pmnm1(i,j) = pmn(i,j) enddo ; enddo ; enddo @@ -125,10 +133,15 @@ subroutine spherical_harmonics_forward(G, CS, var, Snm_Re, Snm_Im, Nd) if (id_clock_sht_global_sum>0) call cpu_clock_begin(id_clock_sht_global_sum) if (CS%reprod_sum) then - do l=1,Ltot - Snm_Re(l) = reproducing_sum(CS%Snm_Re_raw(:,:,l)) - Snm_Im(l) = reproducing_sum(CS%Snm_Im_raw(:,:,l)) - enddo + sum_tot = reproducing_sum(CS%Snm_Re_raw(:,:,1:Ltot), sums=Snm_Re(1:Ltot)) + sum_tot = reproducing_sum(CS%Snm_Im_raw(:,:,1:Ltot), sums=Snm_Im(1:Ltot)) + if (scale /= 1.0) then + I_scale = 1.0 / scale + do l=1,Ltot + Snm_Re(l) = I_scale * Snm_Re(l) + Snm_Im(l) = I_scale * Snm_Im(l) + enddo + endif else call sum_across_PEs(Snm_Re, Ltot) call sum_across_PEs(Snm_Im, Ltot) @@ -240,8 +253,9 @@ subroutine spherical_harmonics_init(G, param_file, CS) allocate(CS%a_recur(CS%ndegree+1, CS%ndegree+1)); CS%a_recur(:,:) = 0.0 allocate(CS%b_recur(CS%ndegree+1, CS%ndegree+1)); CS%b_recur(:,:) = 0.0 do m=0,CS%ndegree ; do n=m+1,CS%ndegree + ! These expressione will give NaNs with 32-bit integers for n > 23170, but this is trapped elsewhere. CS%a_recur(n+1,m+1) = sqrt(real((2*n-1) * (2*n+1)) / real((n-m) * (n+m))) - CS%b_recur(n+1,m+1) = sqrt(real((2*n+1) * (n+m-1) * (n-m-1)) / real((n-m) * (n+m) * (2*n-3))) + CS%b_recur(n+1,m+1) = sqrt((real(2*n+1) * real((n+m-1) * (n-m-1))) / (real((n-m) * (n+m)) * real(2*n-3))) enddo ; enddo ! Calculate complex exponential factors @@ -253,8 +267,8 @@ subroutine spherical_harmonics_init(G, param_file, CS) do j=js,je ; do i=is,ie CS%cos_lonT(i,j,m+1) = cos(real(m) * (G%geolonT(i,j)*RADIAN)) CS%sin_lonT(i,j,m+1) = sin(real(m) * (G%geolonT(i,j)*RADIAN)) - CS%cos_lonT_wtd(i,j,m+1) = CS%cos_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth**2 - CS%sin_lonT_wtd(i,j,m+1) = CS%sin_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth**2 + CS%cos_lonT_wtd(i,j,m+1) = CS%cos_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 + CS%sin_lonT_wtd(i,j,m+1) = CS%sin_lonT(i,j,m+1) * G%areaT(i,j) / G%Rad_Earth_L**2 enddo ; enddo enddo From ffa6af667cdce26376e1fa49dc9806d52116b435 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 30 Oct 2023 17:38:01 -0400 Subject: [PATCH 467/629] Document 31 real variables units Added standard-format unit descriptions for 31 real variables in comments scattered across 14 modules in the core, tracer, and both parameterizations directories. Only comments are changed and all answers are bitwise identical. --- src/core/MOM_barotropic.F90 | 8 ++++---- src/core/MOM_dynamics_split_RK2.F90 | 12 ++++++------ src/core/MOM_forcing_type.F90 | 4 ++-- src/core/MOM_grid.F90 | 16 ++++++++++------ src/core/MOM_interface_heights.F90 | 2 +- .../lateral/MOM_mixed_layer_restrat.F90 | 4 ++-- .../lateral/MOM_thickness_diffuse.F90 | 4 ++-- .../lateral/MOM_tidal_forcing.F90 | 2 +- .../vertical/MOM_energetic_PBL.F90 | 2 +- src/parameterizations/vertical/MOM_opacity.F90 | 4 ++-- src/tracer/MOM_CFC_cap.F90 | 2 +- src/tracer/MOM_tracer_diabatic.F90 | 4 ++-- src/tracer/dyed_obc_tracer.F90 | 2 +- src/tracer/oil_tracer.F90 | 14 +++++++------- 14 files changed, 42 insertions(+), 38 deletions(-) diff --git a/src/core/MOM_barotropic.F90 b/src/core/MOM_barotropic.F90 index 21c3e64488..83bfab0820 100644 --- a/src/core/MOM_barotropic.F90 +++ b/src/core/MOM_barotropic.F90 @@ -409,7 +409,7 @@ module MOM_barotropic !>@} !> A negligible parameter which avoids division by zero, but is too small to -!! modify physical values. +!! modify physical values [nondim]. real, parameter :: subroundoff = 1e-30 contains @@ -662,7 +662,7 @@ subroutine btstep(U_in, V_in, eta_in, dt, bc_accel_u, bc_accel_v, forces, pbce, time_bt_start, & ! The starting time of the barotropic steps. time_step_end, & ! The end time of a barotropic step. time_end_in ! The end time for diagnostics when this routine started. - real :: time_int_in ! The diagnostics' time interval when this routine started. + real :: time_int_in ! The diagnostics' time interval when this routine started [s] real :: Htot_avg ! The average total thickness of the tracer columns adjacent to a ! velocity point [H ~> m or kg m-2] logical :: do_hifreq_output ! If true, output occurs every barotropic step. @@ -3972,7 +3972,7 @@ subroutine set_local_BT_cont_types(BT_cont, BTCL_u, BTCL_v, G, US, MS, BT_Domain vBT_NN, vBT_SS, & ! Meridional velocities at which the form of the fit changes [L T-1 ~> m s-1] FA_v_NN, FA_v_N0, FA_v_S0, FA_v_SS ! Meridional face areas [H L ~> m2 or kg m-1] real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -4107,7 +4107,7 @@ subroutine adjust_local_BT_cont_types(ubt, uhbt, vbt, vhbt, BTCL_u, BTCL_v, & ! Local variables real :: dt ! The baroclinic timestep [T ~> s] or 1.0 [nondim] - real, parameter :: C1_3 = 1.0/3.0 + real, parameter :: C1_3 = 1.0/3.0 ! [nondim] integer :: i, j, is, ie, js, je, hs is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 31f285c26f..36ba8b60f8 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -387,7 +387,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] logical :: dyn_p_surf @@ -1055,8 +1055,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif if (CS%fpmix) then - if (CS%id_uold > 0) call post_data(CS%id_uold , uold, CS%diag) - if (CS%id_vold > 0) call post_data(CS%id_vold , vold, CS%diag) + if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) endif ! The time-averaged free surface height has already been set by the last call to btstep. @@ -1072,8 +1072,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) ! Here the thickness fluxes are offered for time averaging. - if (CS%id_uh > 0) call post_data(CS%id_uh , uh, CS%diag) - if (CS%id_vh > 0) call post_data(CS%id_vh , vh, CS%diag) + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) @@ -1301,7 +1301,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) , & + 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)), & target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index b5a17130e4..dcbf440292 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -2169,7 +2169,7 @@ subroutine forcing_accumulate(flux_tmp, forces, fluxes, G, wt2) type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] ! This subroutine copies mechancal forcing from flux_tmp to fluxes and ! stores the time-weighted averages of the various buoyancy fluxes in fluxes, @@ -2187,7 +2187,7 @@ subroutine fluxes_accumulate(flux_tmp, fluxes, G, wt2, forces) type(forcing), intent(inout) :: fluxes !< A structure containing time-averaged !! thermodynamic forcing fields type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure - real, intent(out) :: wt2 !< The relative weight of the new fluxes + real, intent(out) :: wt2 !< The relative weight of the new fluxes [nondim] type(mech_forcing), optional, intent(in) :: forces !< A structure with the driving mechanical forces ! This subroutine copies mechanical forcing from flux_tmp to fluxes and diff --git a/src/core/MOM_grid.F90 b/src/core/MOM_grid.F90 index 9cbf420b23..52e37f1a9b 100644 --- a/src/core/MOM_grid.F90 +++ b/src/core/MOM_grid.F90 @@ -136,14 +136,18 @@ module MOM_grid IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. real, pointer, dimension(:) :: & - gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes. + gridLatT => NULL(), & !< The latitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatT. - gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes. + gridLatB => NULL() !< The latitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatBu. real, pointer, dimension(:) :: & - gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes. + gridLonT => NULL(), & !< The longitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonT. - gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes. + gridLonB => NULL() !< The longitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonBu. character(len=40) :: & ! Except on a Cartesian grid, these are usually some variant of "degrees". @@ -187,8 +191,8 @@ module MOM_grid ! initialization routines (but not all) real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] - real :: len_lat !< The latitudinal (or y-coord) extent of physical domain - real :: len_lon !< The longitudinal (or x-coord) extent of physical domain + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain [degrees_N] or [km] or [m] + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain [degrees_E] or [km] or [m] real :: Rad_Earth !< The radius of the planet [m] real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] real :: max_depth !< The maximum depth of the ocean in depth units [Z ~> m] diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 3dfbc89a03..6681034cb9 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -66,7 +66,7 @@ subroutine find_eta_3d(h, tv, G, GV, US, eta, eta_bt, halo_size, dZref) real :: p(SZI_(G),SZJ_(G),SZK_(GV)+1) ! Hydrostatic pressure at each interface [R L2 T-2 ~> Pa] real :: dz_geo(SZI_(G),SZJ_(G),SZK_(GV)) ! The change in geopotential height ! across a layer [L2 T-2 ~> m2 s-2]. - real :: dilate(SZI_(G)) ! non-dimensional dilation factor + real :: dilate(SZI_(G)) ! A non-dimensional dilation factor [nondim] 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] diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 444ef8f064..1f73653aa3 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -837,7 +837,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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. + real, parameter :: two_thirds = 2./3. ! [nondim] 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 @@ -1156,7 +1156,7 @@ real elemental function rmean2ts(signal, filtered, tau_growing, tau_decaying, dt 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 :: afac, bfac ! Non-dimensional fractional weights [nondim] real :: rt ! Reciprocal time scale [T-1 ~> s-1] if (signal>=filtered) then diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 248a90d76a..2638ca71e1 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -1671,11 +1671,11 @@ subroutine add_detangling_Kh(h, e, Kh_u, Kh_v, KH_u_CFL, KH_v_CFL, tv, dt, G, GV real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: int_slope_u !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: int_slope_v !< Ratio that determine how much of !! the isopycnal slopes are taken directly from !! the interface slopes without consideration - !! of density gradients. + !! of density gradients [nondim]. ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & de_top ! The distances between the top of a layer and the top of the diff --git a/src/parameterizations/lateral/MOM_tidal_forcing.F90 b/src/parameterizations/lateral/MOM_tidal_forcing.F90 index eb481f2131..1cd8a45a78 100644 --- a/src/parameterizations/lateral/MOM_tidal_forcing.F90 +++ b/src/parameterizations/lateral/MOM_tidal_forcing.F90 @@ -256,7 +256,7 @@ subroutine tidal_forcing_init(Time, G, US, param_file, CS) character(len=40) :: mdl = "MOM_tidal_forcing" ! This module's name. character(len=128) :: mesg character(len=200) :: tidal_input_files(4*MAX_CONSTITUENTS) - real :: tide_sal_scalar_value + real :: tide_sal_scalar_value ! The constant of proportionality with the scalar approximation to SAL [nondim] integer :: i, j, c, is, ie, js, je, isd, ied, jsd, jed, nc is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 380725b744..1a59b177bd 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -108,7 +108,7 @@ module MOM_energetic_PBL !/ mstar_scheme == 0 real :: fixed_mstar !< Mstar is the ratio of the friction velocity cubed to the TKE available to - !! drive entrainment, nondimensional. This quantity is the vertically + !! drive entrainment [nondim]. This quantity is the vertically !! integrated shear production minus the vertically integrated !! dissipation of TKE produced by shear. This value is used if the option !! for using a fixed mstar is used. diff --git a/src/parameterizations/vertical/MOM_opacity.F90 b/src/parameterizations/vertical/MOM_opacity.F90 index bd1b804cba..61a7a0c7d0 100644 --- a/src/parameterizations/vertical/MOM_opacity.F90 +++ b/src/parameterizations/vertical/MOM_opacity.F90 @@ -422,7 +422,7 @@ function opacity_morel(chl_data) !> This sets the penetrating shortwave fraction according to the scheme proposed by !! Morel and Antoine (1994). function SW_pen_frac_morel(chl_data) - real, intent(in) :: chl_data !< The chlorophyll-A concentration in mg m-3. + real, intent(in) :: chl_data !< The chlorophyll-A concentration [mg m-3] real :: SW_pen_frac_morel !< The returned penetrating shortwave fraction [nondim] ! The following are coefficients for the optical model taken from Morel and @@ -608,7 +608,7 @@ subroutine absorbRemainingSW(G, GV, US, h, opacity_band, nsw, optics, j, dt, H_l real :: SW_trans ! fraction of shortwave radiation that is not ! absorbed in a layer [nondim] real :: unabsorbed ! fraction of the shortwave radiation that - ! is not absorbed because the layers are too thin + ! is not absorbed because the layers are too thin [nondim] real :: Ih_limit ! inverse of the total depth at which the ! surface fluxes start to be limited [H-1 ~> m-1 or m2 kg-1] real :: h_min_heat ! minimum thickness layer that should get heated [H ~> m or kg m-2] diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 7539f05ba2..38777346a1 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -361,7 +361,7 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: flux_scale + real :: flux_scale ! A dimensional rescaling factor for fluxes [H R-1 Z-1 ~> m3 kg-1 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_tracer_diabatic.F90 b/src/tracer/MOM_tracer_diabatic.F90 index 4e067e6896..f18c14e105 100644 --- a/src/tracer/MOM_tracer_diabatic.F90 +++ b/src/tracer/MOM_tracer_diabatic.F90 @@ -56,7 +56,7 @@ subroutine tracer_vertdiff(h_old, ea, eb, dt, tr, G, GV, & btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the !! difference in sinking rates across the layer [H ~> m or kg m-2]. @@ -253,7 +253,7 @@ subroutine tracer_vertdiff_Eulerian(h_old, ent, dt, tr, G, GV, & btm_src !< The time-integrated bottom source of the tracer [CU H ~> CU m or CU kg m-2]. real, dimension(SZI_(G)) :: & b1, & !< b1 is used by the tridiagonal solver [H-1 ~> m-1 or m2 kg-1]. - d1 !! d1=1-c1 is used by the tridiagonal solver, nondimensional. + d1 !! d1=1-c1 is used by the tridiagonal solver [nondim]. real :: c1(SZI_(G),SZK_(GV)) !< c1 is used by the tridiagonal solver [nondim]. real :: h_minus_dsink(SZI_(G),SZK_(GV)) !< The layer thickness minus the !! difference in sinking rates across the layer [H ~> m or kg m-2]. diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 285abe3785..92e10187a6 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -213,7 +213,7 @@ subroutine dyed_obc_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! fluxes can be applied [H ~> m or kg m-2] ! Local variables - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 71800284a6..fc8f82f0df 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -42,18 +42,18 @@ module oil_tracer character(len=200) :: IC_file !< The file in which the age-tracer initial values !! can be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the IC_file is in Z-space. The default is false. - real :: oil_source_longitude !< Latitude of source location (geographic) - real :: oil_source_latitude !< Longitude of source location (geographic) - integer :: oil_source_i=-999 !< Local i of source location (computational) - integer :: oil_source_j=-999 !< Local j of source location (computational) + real :: oil_source_longitude !< Latitude of source location (geographic) [degrees_N] + real :: oil_source_latitude !< Longitude of source location (geographic) [degrees_E] + integer :: oil_source_i=-999 !< Local i of source location (computational index location) + integer :: oil_source_j=-999 !< Local j of source location (computational index location) real :: oil_source_rate !< Rate of oil injection [kg T-1 ~> kg s-1] real :: oil_start_year !< The time at which the oil source starts [years] real :: oil_end_year !< The time at which the oil source ends [years] type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? - real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value. - real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, [kg m-3] + real, dimension(NTR_MAX) :: IC_val = 0.0 !< The (uniform) initial condition value [kg m-3] + real, dimension(NTR_MAX) :: land_val = -1.0 !< The value of tr used where land is masked out [kg m-3] real, dimension(NTR_MAX) :: oil_decay_rate !< Decay rate of oil [T-1 ~> s-1] calculated from oil_decay_days integer, dimension(NTR_MAX) :: oil_source_k !< Layer of source logical :: oil_may_reinit !< If true, oil tracers may be reset by the initialization code From 11c3f56435345c7374d6113381e7d98f648ae797 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 11 Oct 2023 10:41:07 -0400 Subject: [PATCH 468/629] +Save tv%p_surf to some restart files Save tv%p_surf in the restart file when USE_PSURF_IN_EOS is true so that the diagnosed potential energy written to the ocean.stats files after a restart matches the energy written at the end of the previous run-segment in certain non-Boussinesq configurations, including the Baltic test case. Because p_surf_EOS is a non-mandatory restart field, there is no problem restarting the run from a restart file created by an older version of the model. The solutions themselves are bitwise identical. This change requires that tv%p_surf is treated as an allocatable pointer to its own array rather than being used as a pointer to the p_surf element of the fluxes or forces structures so that it can be registered as a restart field. At some point tv%p_surf could be converted into an allocatable array instead of a pointer, but this would require more extensive code refactoring. All answers are bitwise identical. --- src/core/MOM.F90 | 40 ++++++++++++++++++++++++---------------- 1 file changed, 24 insertions(+), 16 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bb890d2d87..1460af1fa3 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -291,8 +291,6 @@ module MOM logical :: useMEKE !< If true, call the MEKE parameterization. logical :: use_stochastic_EOS !< If true, use the stochastic EOS parameterizations. logical :: useWaves !< If true, update Stokes drift - logical :: use_p_surf_in_EOS !< If true, always include the surface pressure contributions - !! in equation of state calculations. logical :: use_diabatic_time_bug !< If true, uses the wrong calendar time for diabatic processes, !! as was done in MOM6 versions prior to February 2018. real :: dtbt_reset_period !< The time interval between dynamic recalculation of the @@ -410,11 +408,11 @@ module MOM type(sponge_CS), pointer :: sponge_CSp => NULL() !< Pointer to the layered-mode sponge control structure type(ALE_sponge_CS), pointer :: ALE_sponge_CSp => NULL() - !< Pointer to the oda incremental update control structure + !< Pointer to the ALE-mode sponge control structure type(oda_incupd_CS), pointer :: oda_incupd_CSp => NULL() - !< Pointer to the internal tides control structure + !< Pointer to the oda incremental update control structure type(int_tide_CS), pointer :: int_tide_CSp => NULL() - !< Pointer to the ALE-mode sponge control structure + !< Pointer to the internal tides control structure type(ALE_CS), pointer :: ALE_CSp => NULL() !< Pointer to the Arbitrary Lagrangian Eulerian (ALE) vertical coordinate control structure @@ -634,6 +632,9 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS endif endif + ! This will be replaced later with the pressures from forces or fluxes if they are available. + if (associated(CS%tv%p_surf)) CS%tv%p_surf(:,:) = 0.0 + ! First determine the time step that is consistent with this call and an ! integer fraction of time_interval. if (do_dyn) then @@ -657,8 +658,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS !---------- Initiate group halo pass of the forcing fields call cpu_clock_begin(id_clock_pass) + ! Halo updates for surface pressure need to be completed before calling calc_resoln_function + ! among other routines if the surface pressure is used in the equation of state. nonblocking_p_surf_update = G%nonblocking_updates .and. & - .not.(CS%use_p_surf_in_EOS .and. associated(forces%p_surf) .and. & + .not.(associated(CS%tv%p_surf) .and. associated(forces%p_surf) .and. & allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) if (.not.associated(forces%taux) .or. .not.associated(forces%tauy)) & call MOM_error(FATAL,'step_MOM:forces%taux,tauy not associated') @@ -678,9 +681,8 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS if (associated(forces%p_surf)) p_surf => forces%p_surf if (.not.associated(forces%p_surf)) CS%interp_p_surf = .false. - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(forces%p_surf)) then - CS%tv%p_surf => forces%p_surf + if (associated(CS%tv%p_surf) .and. associated(forces%p_surf)) then + do j=jsd,jed ; do i=isd,ied ; CS%tv%p_surf(i,j) = forces%p_surf(i,j) ; enddo ; enddo if (allocated(CS%tv%SpV_avg) .and. associated(CS%tv%T)) then ! The internal ocean state depends on the surface pressues, so update SpV_avg. @@ -704,11 +706,10 @@ subroutine step_MOM(forces_in, fluxes_in, sfc_state, Time_start, time_int_in, CS call pass_var(fluxes%tau_mag, G%Domain, clock=id_clock_pass, halo=1) if (associated(fluxes%p_surf)) p_surf => fluxes%p_surf - CS%tv%p_surf => NULL() - if (CS%use_p_surf_in_EOS .and. associated(fluxes%p_surf)) then - CS%tv%p_surf => fluxes%p_surf + if (associated(CS%tv%p_surf) .and. associated(fluxes%p_surf)) then + do j=js,je ; do i=is,ie ; CS%tv%p_surf(i,j) = fluxes%p_surf(i,j) ; enddo ; enddo if (allocated(CS%tv%SpV_avg)) then - call pass_var(fluxes%p_surf, G%Domain, clock=id_clock_pass) + call pass_var(CS%tv%p_surf, G%Domain, clock=id_clock_pass) ! The internal ocean state depends on the surface pressues, so update SpV_avg. call extract_diabatic_member(CS%diabatic_CSp, diabatic_halo=halo_sz) halo_sz = max(halo_sz, 1) @@ -2040,6 +2041,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: bulkmixedlayer ! If true, a refined bulk mixed layer scheme is used ! with nkml sublayers and nkbl buffer layer. logical :: use_temperature ! If true, temperature and salinity used as state variables. + logical :: use_p_surf_in_EOS ! If true, always include the surface pressure contributions + ! in equation of state calculations. logical :: use_frazil ! If true, liquid seawater freezes if temp below freezing, ! with accumulated heat deficit returned to surface ocean. logical :: bound_salinity ! If true, salt is added to keep salinity above @@ -2301,7 +2304,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & units="s", default=US%T_to_s*CS%dt, scale=US%s_to_T, do_not_log=.not.associated(CS%OBC)) ! This is here in case these values are used inappropriately. - use_frazil = .false. ; bound_salinity = .false. + use_frazil = .false. ; bound_salinity = .false. ; use_p_surf_in_EOS = .false. CS%tv%P_Ref = 2.0e7*US%Pa_to_RL2_T2 if (use_temperature) then call get_param(param_file, "MOM", "FRAZIL", use_frazil, & @@ -2330,7 +2333,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & "This is only used if ENABLE_THERMODYNAMICS is true. The default "//& "value is from the TEOS-10 definition of conservative temperature.", & units="J kg-1 K-1", default=3991.86795711963, scale=US%J_kg_to_Q*US%C_to_degC) - call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", CS%use_p_surf_in_EOS, & + call get_param(param_file, "MOM", "USE_PSURF_IN_EOS", use_p_surf_in_EOS, & "If true, always include the surface pressure contributions "//& "in equation of state calculations.", default=.true.) endif @@ -2656,6 +2659,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif endif + if (use_p_surf_in_EOS) allocate(CS%tv%p_surf(isd:ied,jsd:jed), source=0.0) if (use_frazil) allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) if (bound_salinity) allocate(CS%tv%salt_deficit(isd:ied,jsd:jed), source=0.0) @@ -3205,8 +3209,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call do_group_pass(pass_uv_T_S_h, G%Domain) ! Update derived thermodynamic quantities. + if (associated(CS%tv%p_surf)) call pass_var(CS%tv%p_surf, G%Domain, halo=dynamics_stencil) if (allocated(CS%tv%SpV_avg)) then - !### There may be a restart issue here with the surface pressure not being updated? call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) endif @@ -3446,6 +3450,10 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) "Previous ocean surface pressure", "Pa", conversion=US%RL2_T2_to_Pa) endif + if (associated(CS%tv%p_surf)) & + call register_restart_field(CS%tv%p_surf, "p_surf_EOS", .false., restart_CSp, & + "Ocean surface pressure used in EoS", "Pa", conversion=US%RL2_T2_to_Pa) + call register_restart_field(CS%ave_ssh_ibc, "ave_ssh", .false., restart_CSp, & "Time average sea surface height", "meter", conversion=US%Z_to_m) From ab54a1ec4bebfcf7444ebe8646a5471fdf32487d Mon Sep 17 00:00:00 2001 From: alex-huth Date: Fri, 27 Oct 2023 17:23:27 -0400 Subject: [PATCH 469/629] Added capability to write an ice_shelf.stats file (or with custom filename specified by new parameter ICE_SHELF_ENERGYFILE). Currently, this file outputs the kinetic energy and mass of the ice sheet according to the smae parameters used to write the ocean.stats file (TIMEUNIT, ENERGYSAVEDAYS, and ENERGYSAVEDAYS_GEOMETRIC). --- .../STALE_mct_cap/mom_ocean_model_mct.F90 | 2 +- .../ice_solo_driver/ice_shelf_driver.F90 | 3 +- .../nuopc_cap/mom_ocean_model_nuopc.F90 | 2 +- src/core/MOM.F90 | 5 +- src/ice_shelf/MOM_ice_shelf.F90 | 31 ++- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 205 +++++++++++++++++- 6 files changed, 230 insertions(+), 18 deletions(-) diff --git a/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 index 82d8881c03..d1c46f4254 100644 --- a/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_ocean_model_mct.F90 @@ -369,7 +369,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index f91595bd51..c4be8c769d 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -283,7 +283,8 @@ program Shelf_main call set_axes_info(ocn_grid, GV, US, param_file, diag) - call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, fluxes_in=fluxes, solo_ice_sheet_in=.true.) + call initialize_ice_shelf(param_file, ocn_grid, Time, ice_shelf_CSp, diag, & + Start_time, dirs%output_directory, fluxes_in=fluxes, solo_ice_sheet_in=.true.) call initialize_ice_SMB(fluxes%shelf_sfc_mass_flux, ocn_grid, US, param_file) diff --git a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 index b4a9f1d604..9ac40daaa4 100644 --- a/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_ocean_model_nuopc.F90 @@ -390,7 +390,7 @@ subroutine ocean_model_init(Ocean_sfc, OS, Time_init, Time_in, gas_fields_ocn, i if (OS%use_ice_shelf) then call initialize_ice_shelf(param_file, OS%grid, OS%Time, OS%ice_shelf_CSp, & - OS%diag, OS%forces, OS%fluxes) + OS%diag, Time_init, OS%dirs%output_directory, OS%forces, OS%fluxes) endif if (OS%icebergs_alter_ocean) then call marine_ice_init(OS%Time, OS%grid, param_file, OS%diag, OS%marine_ice_CSp) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1460af1fa3..a823ce1744 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2853,7 +2853,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! These arrays are not initialized in most solo cases, but are needed ! when using an ice shelf. Passing the ice shelf diagnostics CS from MOM ! for legacy reasons. The actual ice shelf diag CS is internal to the ice shelf - call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr) + call initialize_ice_shelf(param_file, G_in, Time, ice_shelf_CSp, diag_ptr, & + Time_init, dirs%output_directory) allocate(frac_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(mass_shelf_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed), source=0.0) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) @@ -2912,7 +2913,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & deallocate(frac_shelf_in,mass_shelf_in) else if (use_ice_shelf) then - call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr) + call initialize_ice_shelf(param_file, G, Time, ice_shelf_CSp, diag_ptr, Time_init, dirs%output_directory) allocate(CS%frac_shelf_h(isd:ied, jsd:jed), source=0.0) allocate(CS%mass_shelf(isd:ied, jsd:jed), source=0.0) call ice_shelf_query(ice_shelf_CSp,G,CS%frac_shelf_h, CS%mass_shelf) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 84858f17bc..d7aacef8ed 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -48,7 +48,7 @@ module MOM_ice_shelf use MOM_get_input, only : directories, Get_MOM_input use MOM_EOS, only : calculate_density, calculate_density_derivs, calculate_TFreeze, EOS_domain use MOM_EOS, only : EOS_type, EOS_init -use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf +use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end @@ -162,6 +162,8 @@ module MOM_ice_shelf type(EOS_type) :: eqn_of_state !< Type that indicates the equation of state to use. logical :: active_shelf_dynamics !< True if the ice shelf mass changes as a result !! the dynamic ice-shelf model. + logical :: shelf_mass_is_dynamic !< True if ice shelf mass changes over time. If true, ice + !! shelf dynamics will be initialized logical :: data_override_shelf_fluxes !< True if the ice shelf surface mass fluxes can be !! written using the data_override feature (only for MOSAIC grids) logical :: override_shelf_movement !< If true, user code specifies the shelf movement @@ -784,6 +786,10 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) endif + if (CS%shelf_mass_is_dynamic) & + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + time_step=real_to_time(US%T_to_s*time_step) ) + call enable_averages(time_step, Time, CS%diag) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) @@ -1211,14 +1217,16 @@ end subroutine add_shelf_flux !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, & - fluxes_in, sfc_state_in, Time_in, solo_ice_sheet_in) +subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, directory, forces_in, & + fluxes_in, sfc_state_in, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(ocean_grid_type), pointer :: ocn_grid !< The calling ocean model's horizontal grid structure type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_CS), pointer :: CS !< A pointer to the ice shelf control structure type(MOM_diag_ctrl), pointer :: diag !< This is a pointer to the MOM diag CS !! which will be discarded + type(time_type), intent(in) :: Time_init !< The time at initialization. + character(len=*), intent(in) :: directory !< The directory where the energy file goes. type(mech_forcing), optional, target, intent(inout) :: forces_in !< A structure with the driving mechanical forces type(forcing), optional, target, intent(inout) :: fluxes_in !< A structure containing pointers to any @@ -1226,7 +1234,6 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, type(surface), target, optional, intent(inout) :: sfc_state_in !< A structure containing fields that !! describe the surface state of the ocean. The !! intent is only inout to allow for halo updates. - type(time_type), optional, intent(in) :: Time_in !< The time at initialization. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. @@ -1248,7 +1255,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, character(len=40) :: mdl = "MOM_ice_shelf" ! This module's name. integer :: i, j, is, ie, js, je, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq integer :: wd_halos(2) - logical :: read_TideAmp, shelf_mass_is_dynamic, debug + logical :: read_TideAmp, debug logical :: global_indexing character(len=240) :: Tideamp_file ! Input file names character(len=80) :: tideamp_var ! Input file variable names @@ -1363,7 +1370,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, CS%solo_ice_sheet = .false. if (present(solo_ice_sheet_in)) CS%solo_ice_sheet = solo_ice_sheet_in - if (present(Time_in)) Time = Time_in + !if (present(Time_in)) Time = Time_in CS%override_shelf_movement = .false. ; CS%active_shelf_dynamics = .false. @@ -1373,10 +1380,10 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, call get_param(param_file, mdl, "DEBUG_IS", CS%debug, & "If true, write verbose debugging messages for the ice shelf.", & default=debug) - call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", shelf_mass_is_dynamic, & + call get_param(param_file, mdl, "DYNAMIC_SHELF_MASS", CS%shelf_mass_is_dynamic, & "If true, the ice sheet mass can evolve with time.", & default=.false.) - if (shelf_mass_is_dynamic) then + if (CS%shelf_mass_is_dynamic) then call get_param(param_file, mdl, "OVERRIDE_SHELF_MOVEMENT", CS%override_shelf_movement, & "If true, user provided code specifies the ice-shelf "//& "movement instead of the dynamic ice model.", default=.false.) @@ -1777,8 +1784,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ISS%water_flux(:,:) = 0.0 endif - if (shelf_mass_is_dynamic) & - call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, solo_ice_sheet_in) + if (CS%shelf_mass_is_dynamic) & + call initialize_ice_shelf_dyn(param_file, Time, ISS, CS%dCS, G, US, CS%diag, new_sim, & + Time_init, directory, solo_ice_sheet_in) call fix_restart_unit_scaling(US, unscaled=.true.) @@ -2245,6 +2253,9 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in enddo + call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & + time_step=real_to_time(US%T_to_s*time_step) ) + call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 2965f6eac4..42416ce807 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -16,8 +16,12 @@ module MOM_ice_shelf_dynamics use MOM_file_parser, only : read_param, get_param, log_param, log_version, param_file_type use MOM_grid, only : MOM_grid_init, ocean_grid_type use MOM_io, only : file_exists, slasher, MOM_read_data +use MOM_io, only : open_ASCII_file, get_filename_appendix +use MOM_io, only : APPEND_FILE, WRITEONLY_FILE use MOM_restart, only : register_restart_field, MOM_restart_CS -use MOM_time_manager, only : time_type, set_time +use MOM_time_manager, only : time_type, get_time, set_time, time_type_to_real, operator(>) +use MOM_time_manager, only : operator(+), operator(-), operator(*), operator(/) +use MOM_time_manager, only : operator(/=), operator(<=), operator(>=), operator(<) use MOM_unit_scaling, only : unit_scale_type, unit_scaling_init !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary use MOM_ice_shelf_state, only : ice_shelf_state @@ -31,7 +35,7 @@ module MOM_ice_shelf_dynamics #include public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf -public ice_time_step_CFL, ice_shelf_dyn_end +public ice_time_step_CFL, ice_shelf_dyn_end, write_ice_shelf_energy public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -167,6 +171,27 @@ module MOM_ice_shelf_dynamics !! 2: exit based on "fixed point" metric (|u - u_last| / |u| < tol) where | | is infty-norm !! 3: exit based on change of norm + ! for write_ice_shelf_energy + type(time_type) :: energysavedays !< The interval between writing the energies + !! and other integral quantities of the run. + type(time_type) :: energysavedays_geometric !< The starting interval for computing a geometric + !! progression of time deltas between calls to + !! write_energy. This interval will increase by a factor of 2. + !! after each call to write_energy. + logical :: energysave_geometric !< Logical to control whether calls to write_energy should + !! follow a geometric progression + type(time_type) :: write_energy_time !< The next time to write to the energy file. + type(time_type) :: geometric_end_time !< Time at which to stop the geometric progression + !! of calls to write_energy and revert to the standard + !! energysavedays interval + real :: timeunit !< The length of the units for the time axis and certain input parameters + !! including ENERGYSAVEDAYS [s]. + type(time_type) :: Start_time !< The start time of the simulation. + ! Start_time is set in MOM_initialization.F90 + integer :: prev_IS_energy_calls = 0 !< The number of times write_ice_shelf_energy has been called. + integer :: IS_fileenergy_ascii !< The unit number of the ascii version of the energy file. + character(len=200) :: IS_energyfile !< The name of the ice sheet energy file with path. + ! ids for outputting intermediate thickness in advection subroutine (debugging) !integer :: id_h_after_uflux = -1, id_h_after_vflux = -1, id_h_after_adv = -1 @@ -329,7 +354,8 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) end subroutine register_ice_shelf_dyn_restarts !> Initializes shelf model data, parameters and diagnostics -subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, solo_ice_sheet_in) +subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_sim, & + Input_start_time, directory, solo_ice_sheet_in) type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(time_type), intent(inout) :: Time !< The clock that that will indicate the model time type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe @@ -340,6 +366,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ type(diag_ctrl), target, intent(in) :: diag !< A structure that is used to regulate the diagnostic output. logical, intent(in) :: new_sim !< If true this is a new simulation, otherwise !! has been started from a restart file. + type(time_type), intent(in) :: Input_start_time !< The start time of the simulation. + character(len=*), intent(in) :: directory !< The directory where the ice sheet energy file goes. logical, optional, intent(in) :: solo_ice_sheet_in !< If present, this indicates whether !! a solo ice-sheet driver. @@ -354,6 +382,8 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ logical :: shelf_mass_is_dynamic, override_shelf_movement, active_shelf_dynamics logical :: debug integer :: i, j, isd, ied, jsd, jed, Isdq, Iedq, Jsdq, Jedq, iters + character(len=200) :: IS_energyfile ! The name of the energy file. + character(len=32) :: filename_appendix = '' ! FMS appendix to filename for ensemble runs Isdq = G%isdB ; Iedq = G%iedB ; Jsdq = G%jsdB ; Jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -483,6 +513,43 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "Min thickness rule for the VERY simple calving law",& units="m", default=0.0, scale=US%m_to_Z) + !for write_ice_shelf_energy + ! Note that the units of CS%Timeunit are the MKS units of [s]. + call get_param(param_file, mdl, "TIMEUNIT", CS%Timeunit, & + "The time unit in seconds a number of input fields", & + units="s", default=86400.0) + if (CS%Timeunit < 0.0) CS%Timeunit = 86400.0 + call get_param(param_file, mdl, "ENERGYSAVEDAYS",CS%energysavedays, & + "The interval in units of TIMEUNIT between saves of the "//& + "energies of the run and other globally summed diagnostics.",& + default=set_time(0,days=1), timeunit=CS%Timeunit) + call get_param(param_file, mdl, "ENERGYSAVEDAYS_GEOMETRIC",CS%energysavedays_geometric, & + "The starting interval in units of TIMEUNIT for the first call "//& + "to save the energies of the run and other globally summed diagnostics. "//& + "The interval increases by a factor of 2. after each call to write_ice_shelf_energy.",& + default=set_time(seconds=0), timeunit=CS%Timeunit) + if ((time_type_to_real(CS%energysavedays_geometric) > 0.) .and. & + (CS%energysavedays_geometric < CS%energysavedays)) then + CS%energysave_geometric = .true. + else + CS%energysave_geometric = .false. + endif + CS%Start_time = Input_start_time + call get_param(param_file, mdl, "ICE_SHELF_ENERGYFILE", IS_energyfile, & + "The file to use to write the energies and globally "//& + "summed diagnostics.", default="ice_shelf.stats") + !query fms_io if there is a filename_appendix (for ensemble runs) + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + IS_energyfile = trim(IS_energyfile) //'.'//trim(filename_appendix) + endif + + CS%IS_energyfile = trim(slasher(directory))//trim(IS_energyfile) + call log_param(param_file, mdl, "output_path/ENERGYFILE", CS%IS_energyfile) +#ifdef STATSLABEL + CS%IS_energyfile = trim(CS%IS_energyfile)//"."//trim(adjustl(STATSLABEL)) +#endif + ! Allocate memory in the ice shelf dynamics control structure that was not ! previously allocated for registration for restarts. @@ -810,6 +877,138 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled end subroutine update_ice_shelf +!> Writes the total ice shelf kinetic energy and mass to an ascii file +subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< The ice shelf dynamics control structure + type(ocean_grid_type), intent(inout) :: G !< The grid structure used by the ice shelf. + type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: mass !< The mass per unit area of the ice shelf + !! or sheet [R Z ~> kg m-2] + type(time_type), intent(in) :: day !< The current model time. + type(time_type), optional, intent(in) :: time_step !< The current time step + ! Local variables + type(time_type) :: dt ! A time_type version of the timestep. + real, dimension(SZDI_(G),SZDJ_(G)) :: tmp1 ! A temporary array used in reproducing sums [various] + real :: KE_tot, mass_tot, KE_scale_factor, mass_scale_factor + integer :: is, ie, js, je, isr, ier, jsr, jer, i, j + character(len=32) :: mesg_intro, time_units, day_str, n_str, date_str + integer :: start_of_day, num_days + real :: reday ! Time in units given by CS%Timeunit, but often [days] + + ! write_energy_time is the next integral multiple of energysavedays. + if (present(time_step)) then + dt = time_step + else + dt = set_time(seconds=2) + endif + + !CS%prev_IS_energy_calls tracks the ice sheet step, which is outputted in the energy file. + if (CS%prev_IS_energy_calls == 0) then + if (CS%energysave_geometric) then + if (CS%energysavedays_geometric < CS%energysavedays) then + CS%write_energy_time = day + CS%energysavedays_geometric + CS%geometric_end_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + else + CS%write_energy_time = CS%Start_time + CS%energysavedays * & + (1 + (day - CS%Start_time) / CS%energysavedays) + endif + elseif (day + (dt/2) <= CS%write_energy_time) then + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 + return ! Do not write this step + else ! Determine the next write time before proceeding + if (CS%energysave_geometric) then + if (CS%write_energy_time + CS%energysavedays_geometric >= & + CS%geometric_end_time) then + CS%write_energy_time = CS%geometric_end_time + CS%energysave_geometric = .false. ! stop geometric progression + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays_geometric + endif + CS%energysavedays_geometric = CS%energysavedays_geometric*2 + else + CS%write_energy_time = CS%write_energy_time + CS%energysavedays + endif + endif + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + isr = is - (G%isd-1) ; ier = ie - (G%isd-1) ; jsr = js - (G%jsd-1) ; jer = je - (G%jsd-1) + + !calculate KE using cell-centered ice shelf velocity + tmp1(:,:)=0.0 + KE_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 * US%L_T_to_m_s**2 + do j=js,je ; do i=is,ie + tmp1(i,j) = KE_scale_factor * 0.03125 * G%areaT(i,j) * mass(i,j) * & + ((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J-1)+CS%u_shelf(I,J)+CS%u_shelf(I,J-1))**2 + & + (CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J-1)+CS%v_shelf(I,J)+CS%v_shelf(I,J-1))**2) + enddo; enddo + + KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + + !calculate mass + tmp1(:,:)=0.0 + mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 + do j=js,je ; do i=is,ie + tmp1(i,j) = mass_scale_factor * mass(i,j) * G%areaT(i,j) + enddo; enddo + + mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) + + if (is_root_pe()) then ! Only the root PE actually writes anything. + if (day > CS%Start_time) then + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=APPEND_FILE) + else + call open_ASCII_file(CS%IS_fileenergy_ascii, trim(CS%IS_energyfile), action=WRITEONLY_FILE) + if (abs(CS%timeunit - 86400.0) < 1.0) then + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Day,"8x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(12x,"[days]",10x,"[m2 s-2]",17x,"[kg]")') + else + if ((CS%timeunit >= 0.99) .and. (CS%timeunit < 1.01)) then + time_units = " [seconds] " + elseif ((CS%timeunit >= 3599.0) .and. (CS%timeunit < 3601.0)) then + time_units = " [hours] " + elseif ((CS%timeunit >= 86399.0) .and. (CS%timeunit < 86401.0)) then + time_units = " [days] " + elseif ((CS%timeunit >= 3.0e7) .and. (CS%timeunit < 3.2e7)) then + time_units = " [years] " + else + write(time_units,'(9x,"[",es8.2," s] ")') CS%timeunit + endif + + write(CS%IS_fileenergy_ascii,'(" Step,",7x,"Time,"7x,"Energy/Mass,",13x,"Total Mass")') + write(CS%IS_fileenergy_ascii,'(A25,3x,"[m2 s-2]",17x,"[kg]")') time_units + endif + endif + + call get_time(day, start_of_day, num_days) + + if (abs(CS%timeunit - 86400.0) < 1.0) then + reday = REAL(num_days)+ (REAL(start_of_day)/86400.0) + else + reday = REAL(num_days)*(86400.0/CS%timeunit) + REAL(start_of_day)/abs(CS%timeunit) + endif + + if (reday < 1.0e8) then ; write(day_str, '(F12.3)') reday + elseif (reday < 1.0e11) then ; write(day_str, '(F15.3)') reday + else ; write(day_str, '(ES15.9)') reday ; endif + + if (CS%prev_IS_energy_calls < 1000000) then ; write(n_str, '(I6)') CS%prev_IS_energy_calls + elseif (CS%prev_IS_energy_calls < 10000000) then ; write(n_str, '(I7)') CS%prev_IS_energy_calls + elseif (CS%prev_IS_energy_calls < 100000000) then ; write(n_str, '(I8)') CS%prev_IS_energy_calls + else ; write(n_str, '(I10)') CS%prev_IS_energy_calls ; endif + + write(CS%IS_fileenergy_ascii,'(A,",",A,", En ",ES22.16,", M ",ES11.5)') & + trim(n_str), trim(day_str), KE_tot/mass_tot, mass_tot + endif + + CS%prev_IS_energy_calls = CS%prev_IS_energy_calls + 1 +end subroutine write_ice_shelf_energy + !> This subroutine takes the velocity (on the Bgrid) and timesteps h_t = - div (uh) once. !! Additionally, it will update the volume of ice in partially-filled cells, and update !! hmask accordingly From 3ab3dfc18b95b2c8948fb32ed8907e5d2a7095b6 Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Thu, 2 Nov 2023 13:59:27 -0400 Subject: [PATCH 470/629] Fix ice-sheet grounding based on ocean column thickness (#512) A few bug fixes so that the GL_couple=.true. option works correctly. Setting GL_couple=.true. will determine the grounding based on ocean column thickness rather than the typical the hydrostatic equilibrium condition. This has the advantage of accounting for changes in sea level, tides, etc. However, it has the disadvantage of not working with the same thoroughly-tested sub-element grounding line parameterization used for the hydrostatic condition. Instead, it accounts for sub-element grounding line movement by, during the SSA solution, using a grounding mask averaged over all ocean (sub)steps that completed since the last SSA solve. Unlike the hydrostatic sub-element parameterization, the dependence of the GL_couple=.true. scheme on grid resolution has not yet been determined. Qualitatively similar grounding line retreat/advance behavior is achieved with both approaches for MISOMIP IceOcean1 on a 2km grid, but GL_couple=.true. results in a rougher grounding line position with less retreat. Note that this commit also fixed a bug in applying the hydrostatic grounding line approach without its sub-element parameterization (though the sub-element parameterization should also be used anyway). --- src/ice_shelf/MOM_ice_shelf.F90 | 1 + src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 89 ++++++++++++++---------- 2 files changed, 55 insertions(+), 35 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index d7aacef8ed..5c67a66262 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1402,6 +1402,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. + if (CS%solo_ice_sheet) CS%GL_couple = .false. endif call get_param(param_file, mdl, "SHELF_THERMO", CS%isthermo, & diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 42416ce807..8a95ce46d2 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -432,6 +432,9 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "will be called. GL_REGULARIZE and GL_COUPLE are exclusive.", & default=.false., do_not_log=CS%GL_regularize) if (CS%GL_regularize) CS%GL_couple = .false. + if (present(solo_ice_sheet_in)) then + if (solo_ice_sheet_in) CS%GL_couple = .false. + endif if (CS%GL_regularize .and. (CS%n_sub_regularize == 0)) call MOM_error (FATAL, & "GROUNDING_LINE_INTERP_SUBGRID_N must be a positive integer if GL regularization is used") call get_param(param_file, mdl, "ICE_SHELF_CFL_FACTOR", CS%CFL_factor, & @@ -826,6 +829,7 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call update_OD_ffrac(CS, G, US, ocean_mass, update_ice_vel) elseif (update_ice_vel) then call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) + CS%GL_couple=.false. endif @@ -1121,8 +1125,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! An array indicating where the ice - ! shelf is floating: 0 if floating, 1 if not. + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, an array indicating where the ice + ! shelf is floating: 0 if floating, 1 if not real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter @@ -1148,18 +1152,18 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! need to make these conditional on GL interpolation float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 - CS%ground_frac(:,:) = 0.0 + !CS%ground_frac(:,:) = 0.0 allocate(Phisub(nsub,nsub,2,2,2,2), source=0.0) - do j=G%jsc,G%jec - do i=G%isc,G%iec + if (.not. CS%GL_couple) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then - float_cond(i,j) = 1.0 + if (CS%GL_regularize) float_cond(i,j) = 1.0 CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif - enddo - enddo + enddo ; enddo + endif call calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, CS%OD_av) call pass_vector(taudx, taudy, G%domain, TO_ALL, BGRID_NE) @@ -1209,10 +1213,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! This makes sure basal stress is only applied when it is supposed to be - do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) - enddo ; enddo + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif if (CS%nonlin_solve_err_mode == 1) then ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & @@ -1284,11 +1293,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) ! makes sure basal stress is only applied when it is supposed to be - - do j=G%jsd,G%jed ; do i=G%isd,G%ied -! CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) - enddo ; enddo + if (CS%GL_regularize) then + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + enddo ; enddo + else + do j=G%jsd,G%jed ; do i=G%isd,G%ied + CS%basal_traction(i,j) = CS%basal_traction(i,j) * CS%ground_frac(i,j) + enddo ; enddo + endif if (CS%nonlin_solve_err_mode == 1) then !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 @@ -1395,8 +1408,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -2139,18 +2152,24 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) rhoi_rhow = rho/rhow ! prelim - go through and calculate S - S(:,:) = -CS%bed_elev(:,:) + ISS%h_shelf(:,:) - ! check whether the ice is floating or grounded - - do j=jsc-G%domain%njhalo,jec+G%domain%njhalo - do i=isc-G%domain%nihalo,iec+G%domain%nihalo - if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then - S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) - else - S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) - endif + if (CS%GL_couple) then + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + S(i,j) = -CS%bed_elev(i,j) + (OD(i,j) + ISS%h_shelf(i,j)) + enddo enddo - enddo + else + ! check whether the ice is floating or grounded + do j=jsc-G%domain%njhalo,jec+G%domain%njhalo + do i=isc-G%domain%nihalo,iec+G%domain%nihalo + if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) <= 0) then + S(i,j) = (1 - rhoi_rhow)*ISS%h_shelf(i,j) + else + S(i,j) = ISS%h_shelf(i,j)-CS%bed_elev(i,j) + endif + enddo + enddo + endif call pass_var(S, G%domain) @@ -2413,8 +2432,8 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points !! relative to sea-level [Z ~> m]. @@ -2584,8 +2603,8 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. + intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice + !! shelf is floating: 0 if floating, 1 if not real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. @@ -3115,7 +3134,7 @@ subroutine update_OD_ffrac(CS, G, US, ocean_mass, find_avg) CS%ground_frac(i,j) = 1.0 - (CS%ground_frac_rt(i,j) * I_counter) CS%OD_av(i,j) = CS%OD_rt(i,j) * I_counter - CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0 + CS%OD_rt(i,j) = 0.0 ; CS%ground_frac_rt(i,j) = 0.0; CS%OD_rt_counter = 0 enddo ; enddo call pass_var(CS%ground_frac, G%domain, complete=.false.) From dcaadf71d0680e41d23f41db29b3cef0b4a96ea8 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Mon, 6 Nov 2023 14:10:11 -0700 Subject: [PATCH 471/629] set %label in register_netcdf_field and register_netcdf_axis (#262) --- src/framework/MOM_netcdf.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 index 95e6aa7bb7..73f276aba9 100644 --- a/src/framework/MOM_netcdf.F90 +++ b/src/framework/MOM_netcdf.F90 @@ -217,6 +217,8 @@ function register_netcdf_field(handle, label, axes, longname, units) & allocate(dimids(size(axes))) dimids(:) = [(axes(i)%dimid, i = 1, size(axes))] + field%label = label + ! Determine the corresponding netCDF data type ! TODO: Support a `pack`-like argument select case (kind(1.0)) @@ -225,7 +227,7 @@ function register_netcdf_field(handle, label, axes, longname, units) & case (real64) xtype = NF90_DOUBLE case default - call MOM_error(FATAL, "register_netcdf_axis: Unknown kind(real).") + call MOM_error(FATAL, "register_netcdf_field: Unknown kind(real).") end select ! Register the field variable @@ -293,6 +295,8 @@ function register_netcdf_axis(handle, label, units, longname, points, & "Axis must either have explicit points or be a time axis ('T').") endif + axis%label = label + if (present(points)) then axis_size = size(points) allocate(axis%points(axis_size)) From d85fe733fdfb81db591215b3c2a10cd62b61b7bb Mon Sep 17 00:00:00 2001 From: Alex Huth Date: Mon, 6 Nov 2023 20:33:57 -0500 Subject: [PATCH 472/629] ice-sheet/ocean coupling for misomip (#511) * This commit fixes a bug where restarts were not bitwise identical for coupled ice sheet/ocean runs. This required adding visc%taux and visc%taux (stress on the ocean under ice shelves) to the ocean restart file. Furthermore, ice shelf geometry-related variables needed to be updated and their halo cells filled (within subroutine update_ice_shelf) before (rather than after) calculating shelf fluxes and pressure to the ocean (subroutine add_shelf_flux). Also fixed a bug to calculate ISS%mass_shelf properly in ice-shelf cells that are only partially-filled (ice-shelf area < cell area) due to advection of the ice-shelf front. * Modified the scheme that attempts to enforce a constant sea level in coupled ice-sheet/ocean runs, where balancing fluxes are applied to part/all of the open ocean to offset the sea level effects caused by changes in ice sheet mass on the ocean. The old scheme assumes the entire ice sheet is floating, and is retained here for the case where CS$override_shelf_movement==.true. and CS%mass_from_file (this approach is used for the MISOMIP tests without a dynamic ice sheet). The new scheme (which is needed for the MISOMIP tests with a dynamic ice sheet, e.g. IceOcean1r and IceOcean1a), accounts for the more general case where some of the ice sheet is grounded. In either case, the ocean balancing fluxes are applied over the entirety of the ice-sheet-free ocean by default. However, if the new parameter CONST_SEA_LEVEL_MISOMIP==.true., the balancing flux is only applied where x>=790 km, which is the sponge region for the MISOMIP tests. The new scheme also requires calculation of ice sheet dHdT, which is now calculated and optionally saved as a useful diagnositc field for any ice sheet simulation. * Eliminated array syntax and added inverse dt variables where needed --- src/core/MOM.F90 | 2 +- src/ice_shelf/MOM_ice_shelf.F90 | 88 +++++++++++++------ src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 58 +++++++++++- src/ice_shelf/MOM_ice_shelf_state.F90 | 4 +- .../vertical/MOM_set_viscosity.F90 | 22 ++++- 5 files changed, 143 insertions(+), 31 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index a823ce1744..e1fa004fb8 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2752,7 +2752,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%tracer_Reg, restart_CSp) call MEKE_alloc_register_restart(HI, US, param_file, CS%MEKE, restart_CSp) - call set_visc_register_restarts(HI, GV, US, param_file, CS%visc, restart_CSp) + call set_visc_register_restarts(HI, G, GV, US, param_file, CS%visc, restart_CSp, use_ice_shelf) call mixedlayer_restrat_register_restarts(HI, GV, US, param_file, & CS%mixedlayer_restrat_CSp, restart_CSp) diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 5c67a66262..b435b0a677 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -50,7 +50,7 @@ module MOM_ice_shelf use MOM_EOS, only : EOS_type, EOS_init use MOM_ice_shelf_dynamics, only : ice_shelf_dyn_CS, update_ice_shelf, write_ice_shelf_energy use MOM_ice_shelf_dynamics, only : register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn -use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve +use MOM_ice_shelf_dynamics, only : ice_shelf_min_thickness_calve, change_in_draft use MOM_ice_shelf_dynamics, only : ice_time_step_CFL, ice_shelf_dyn_end use MOM_ice_shelf_initialize, only : initialize_ice_thickness !MJH use MOM_ice_shelf_initialize, only : initialize_ice_shelf_boundary @@ -177,6 +177,8 @@ module MOM_ice_shelf logical :: const_gamma !< If true, gamma_T is specified by the user. logical :: constant_sea_level !< if true, apply an evaporative, heat and salt !! fluxes. It will avoid large increase in sea level. + logical :: constant_sea_level_misomip !< If true, constant_sea_level fluxes are applied only over + !! the surface sponge cells from the ISOMIP/MISOMIP configuration real :: min_ocean_mass_float !< The minimum ocean mass per unit area before the ice !! shelf is considered to float when constant_sea_level !! is used [R Z ~> kg m-2] @@ -200,7 +202,7 @@ module MOM_ice_shelf id_tfreeze = -1, id_tfl_shelf = -1, & id_thermal_driving = -1, id_haline_driving = -1, & id_u_ml = -1, id_v_ml = -1, id_sbdry = -1, & - id_h_shelf = -1, id_h_mask = -1, & + id_h_shelf = -1, id_dhdt_shelf, id_h_mask = -1, & id_surf_elev = -1, id_bathym = -1, & id_area_shelf_h = -1, & id_ustar_shelf = -1, id_shelf_mass = -1, id_mass_flux = -1, & @@ -271,6 +273,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) !! interface, positive for melting and negative for freezing [S ~> ppt]. !! This is computed as part of the ISOMIP diagnostics. real :: time_step !< Length of time over which these fluxes will be applied [T ~> s]. + real :: Itime_step !< Inverse of the length of time over which these fluxes will be applied [T-1 ~> s-1] real :: VK !< Von Karman's constant - dimensionless real :: ZETA_N !< This is the stability constant xi_N = 0.052 from Holland & Jenkins '99 !! divided by the von Karman constant VK. Was 1/8. [nondim] @@ -751,6 +754,9 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) ! Melting has been computed, now is time to update thickness and mass with dynamic ice shelf if (CS%active_shelf_dynamics) then + + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + call change_thickness_using_melt(ISS, G, US, time_step, fluxes, CS%density_ice, CS%debug) if (CS%debug) then @@ -767,29 +773,29 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) scale=US%RZ_to_kg_m2) endif - endif - - if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) - - call add_shelf_flux(G, US, CS, sfc_state, fluxes) - - ! now the thermodynamic data is passed on... time to update the ice dynamic quantities - - if (CS%active_shelf_dynamics) then update_ice_vel = .false. - coupled_GL = (CS%GL_couple .and. .not.CS%solo_ice_sheet) + coupled_GL = (CS%GL_couple .and. .not. CS%solo_ice_sheet) ! advect the ice shelf, and advance the front. Calving will be in here somewhere as well.. ! when we decide on how to do it call update_ice_shelf(CS%dCS, ISS, G, US, time_step, Time, & sfc_state%ocean_mass, coupled_GL) + Itime_step = 1./time_step + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j))*Itime_step + enddo; enddo endif if (CS%shelf_mass_is_dynamic) & call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & time_step=real_to_time(US%T_to_s*time_step) ) + if (CS%debug) call MOM_forcing_chksum("Before add shelf flux", fluxes, G, CS%US, haloshift=0) + + ! pass on the updated ice sheet geometry (for pressure on ocean) and thermodynamic data + call add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) + call enable_averages(time_step, Time, CS%diag) if (CS%id_shelf_mass > 0) call post_data(CS%id_shelf_mass, ISS%mass_shelf, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) @@ -808,6 +814,7 @@ subroutine shelf_calc_flux(sfc_state_in, fluxes_in, Time, time_step_in, CS) if (CS%id_exch_vel_t > 0) call post_data(CS%id_exch_vel_t, exch_vel_t, CS%diag) if (CS%id_exch_vel_s > 0) call post_data(CS%id_exch_vel_s, exch_vel_s, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask,ISS%hmask,CS%diag) call disable_averaging(CS%diag) @@ -860,7 +867,7 @@ subroutine change_thickness_using_melt(ISS, G, US, time_step, fluxes, density_ic ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * density_ice endif enddo ; enddo @@ -1018,13 +1025,13 @@ subroutine add_shelf_pressure(Ocn_grid, US, CS, fluxes) end subroutine add_shelf_pressure !> Updates surface fluxes that are influenced by sub-ice-shelf melting -subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) +subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes, time_step) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(ice_shelf_CS), pointer :: CS !< This module's control structure. type(surface), intent(inout) :: sfc_state !< Surface ocean state type(forcing), intent(inout) :: fluxes !< A structure of surface fluxes that may be used/updated. - + real, intent(in) :: time_step !< Time step over which fluxes are applied ! local variables real :: frac_shelf !< The fractional area covered by the ice shelf [nondim]. real :: frac_open !< The fractional area of the ocean that is not covered by the ice shelf [nondim]. @@ -1045,6 +1052,8 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) !! at at previous time (Time-dt) real, dimension(SZDI_(G),SZDJ_(G)) :: last_area_shelf_h !< Ice shelf area [L2 ~> m2] !! at at previous time (Time-dt) + real, dimension(SZDI_(G),SZDJ_(G)) :: delta_draft !< change in ice shelf draft thickness [L ~> m] + !! since previous time (Time-dt) type(ice_shelf_state), pointer :: ISS => NULL() !< A structure with elements that describe !! the ice-shelf state @@ -1171,22 +1180,38 @@ subroutine add_shelf_flux(G, US, CS, sfc_state, fluxes) else! first time step delta_mass_shelf = 0.0 endif - else ! ice shelf mass does not change - delta_mass_shelf = 0.0 + else + if (CS%active_shelf_dynamics) then ! change in ice_shelf draft + do j=js,je ; do i=is,ie + last_h_shelf(i,j) = ISS%h_shelf(i,j) - time_step * ISS%dhdt_shelf(i,j) + enddo ; enddo + call change_in_draft(CS%dCS, G, last_h_shelf, ISS%h_shelf, delta_draft) + + !this currently assumes area_shelf_h is constant over the time step + delta_mass_shelf = global_area_integral(delta_draft, G, tmp_scale=US%RZ_to_kg_m2, & + area=ISS%area_shelf_h) & + * CS%Rho_ocn / CS%time_step + else ! ice shelf mass does not change + delta_mass_shelf = 0.0 + endif endif - ! average total melt flux over sponge area + ! average total melt flux over sponge area (ISOMIP/MISOMIP only) or open ocean (general case) do j=js,je ; do i=is,ie - if ((G%mask2dT(i,j) > 0.0) .AND. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then - ! Uncomment this for some ISOMIP cases: - ! .AND. (G%geoLonT(i,j) >= 790.0) .AND. (G%geoLonT(i,j) <= 800.0)) then + if (CS%constant_sea_level_misomip) then !for ismip/misomip only + if (G%geoLonT(i,j) >= 790.0) then + bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) + else + bal_frac(i,j) = 0.0 + endif + elseif ((G%mask2dT(i,j) > 0.0) .and. (ISS%area_shelf_h(i,j) * G%IareaT(i,j) < 1.0)) then !general case bal_frac(i,j) = max(1.0 - ISS%area_shelf_h(i,j) * G%IareaT(i,j), 0.0) else bal_frac(i,j) = 0.0 endif enddo ; enddo - balancing_area = global_area_integral(bal_frac, G) + balancing_area = global_area_integral(bal_frac, G, area=G%areaT) if (balancing_area > 0.0) then balancing_flux = ( global_area_integral(ISS%water_flux, G, tmp_scale=US%RZ_T_to_kg_m2s, & area=ISS%area_shelf_h) + & @@ -1430,6 +1455,9 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, "ISOMIP+ experiments (Ocean3 and Ocean4). "//& "IMPORTANT: it is not currently possible to do "//& "prefect restarts using this flag.", default=.false.) + call get_param(param_file, mdl, "CONST_SEA_LEVEL_MISOMIP", CS%constant_sea_level_misomip, & + "If true, constant_sea_level fluxes are applied only over "//& + "the surface sponge cells from the ISOMIP/MISOMIP configuration", default=.false.) call get_param(param_file, mdl, "MIN_OCEAN_FLOAT_THICK", dz_ocean_min_float, & "The minimum ocean thickness above which the ice shelf is considered to be "//& "floating when CONST_SEA_LEVEL = True.", & @@ -1809,6 +1837,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, 'mass of shelf', 'kg/m^2', conversion=US%RZ_to_kg_m2) CS%id_h_shelf = register_diag_field('ice_shelf_model', 'h_shelf', CS%diag%axesT1, CS%Time, & 'ice shelf thickness', 'm', conversion=US%Z_to_m) + CS%id_dhdt_shelf = register_diag_field('ice_shelf_model', 'dhdt_shelf', CS%diag%axesT1, CS%Time, & + 'change in ice shelf thickness over time', 'm s-1', conversion=US%Z_to_m*US%s_to_T) CS%id_mass_flux = register_diag_field('ice_shelf_model', 'mass_flux', CS%diag%axesT1,& CS%Time, 'Total mass flux of freshwater across the ice-ocean interface.', & 'kg/s', conversion=US%RZ_T_to_kg_m2s*US%L_to_m**2) @@ -2050,7 +2080,7 @@ subroutine change_thickness_using_precip(CS, ISS, G, US, fluxes, time_step, Time ISS%hmask(i,j) = 0.0 ISS%area_shelf_h(i,j) = 0.0 endif - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * CS%density_ice + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice endif enddo ; enddo @@ -2204,20 +2234,22 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in real :: remaining_time ! The remaining time in this call [T ~> s] real :: time_step ! The internal time step during this call [T ~> s] real :: full_time_step ! The external time step (sum of internal time steps) during this call [T ~> s] + real :: Ifull_time_step ! The inverse of the external time step [T-1 ~> s-1] real :: min_time_step ! The minimal required timestep that would indicate a fatal problem [T ~> s] character(len=240) :: mesg logical :: update_ice_vel ! If true, it is time to update the ice shelf velocities. logical :: coupled_GL ! If true the grounding line position is determined based on ! coupled ice-ocean dynamics. - integer :: is, iec, js, jec + integer :: is, ie, js, je, i, j G => CS%grid US => CS%US ISS => CS%ISS - is = G%isc ; iec = G%iec ; js = G%jsc ; jec = G%jec + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec remaining_time = US%s_to_T*time_type_to_real(time_interval) full_time_step = remaining_time + Ifull_time_step = 1./full_time_step if (present (min_time_step_in)) then min_time_step = min_time_step_in @@ -2228,6 +2260,8 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in write (mesg,*) "TIME in ice shelf call, yrs: ", time_type_to_real(Time)/(365. * 86400.) call MOM_mesg("solo_step_ice_shelf: "//mesg, 5) + ISS%dhdt_shelf(:,:) = ISS%h_shelf(:,:) + do while (remaining_time > 0.0) nsteps = nsteps+1 @@ -2256,10 +2290,14 @@ subroutine solo_step_ice_shelf(CS, time_interval, nsteps, Time, min_time_step_in call write_ice_shelf_energy(CS%dCS, G, US, ISS%mass_shelf, Time, & time_step=real_to_time(US%T_to_s*time_step) ) + do j=js,je ; do i=is,ie + ISS%dhdt_shelf(i,j) = (ISS%h_shelf(i,j) - ISS%dhdt_shelf(i,j)) * Ifull_time_step + enddo; enddo call enable_averages(full_time_step, Time, CS%diag) if (CS%id_area_shelf_h > 0) call post_data(CS%id_area_shelf_h, ISS%area_shelf_h, CS%diag) if (CS%id_h_shelf > 0) call post_data(CS%id_h_shelf, ISS%h_shelf, CS%diag) + if (CS%id_dhdt_shelf > 0) call post_data(CS%id_dhdt_shelf, ISS%dhdt_shelf, CS%diag) if (CS%id_h_mask > 0) call post_data(CS%id_h_mask, ISS%hmask, CS%diag) call disable_averaging(CS%diag) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 8a95ce46d2..312fa43fe9 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -35,7 +35,7 @@ module MOM_ice_shelf_dynamics #include public register_ice_shelf_dyn_restarts, initialize_ice_shelf_dyn, update_ice_shelf -public ice_time_step_CFL, ice_shelf_dyn_end, write_ice_shelf_energy +public ice_time_step_CFL, ice_shelf_dyn_end, change_in_draft, write_ice_shelf_energy public shelf_advance_front, ice_shelf_min_thickness_calve, calve_to_mask ! A note on unit descriptions in comments: MOM6 uses units that can be rescaled for dimensional @@ -1091,6 +1091,15 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) endif endif + do j=jsc,jec; do i=isc,iec + ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice + enddo; enddo + + call pass_var(ISS%mass_shelf, G%domain, complete=.false.) + call pass_var(ISS%h_shelf, G%domain, complete=.false.) + call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) + call pass_var(ISS%hmask, G%domain, complete=.true.) + !call enable_averages(time_step, Time, CS%diag) !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) !call disable_averaging(CS%diag) @@ -3171,6 +3180,53 @@ subroutine update_OD_ffrac_uncoupled(CS, G, h_shelf) end subroutine update_OD_ffrac_uncoupled +subroutine change_in_draft(CS, G, h_shelf0, h_shelf1, ddraft) + type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure + type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf0 !< the previous thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(in) :: h_shelf1 !< the current thickness of the ice shelf [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)), & + intent(inout) :: ddraft !< the change in shelf draft thickness + real :: b0,b1 + integer :: i, j, isc, iec, jsc, jec + real :: rhoi_rhow, OD + + rhoi_rhow = CS%density_ice / CS%density_ocean_avg + isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec + ddraft = 0.0 + + do j=jsc,jec + do i=isc,iec + + b0=0.0; b1=0.0 + + if (h_shelf0(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf0(i,j) + if (OD >= 0) then + !floating + b0 = rhoi_rhow * h_shelf0(i,j) + else + b0 = CS%bed_elev(i,j) + endif + endif + + if (h_shelf1(i,j)>0.0) then + OD = CS%bed_elev(i,j) - rhoi_rhow * h_shelf1(i,j) + if (OD >= 0) then + !floating + b1 = rhoi_rhow * h_shelf1(i,j) + else + b1 = CS%bed_elev(i,j) + endif + endif + + ddraft(i,j) = b1-b0 + enddo + enddo +end subroutine change_in_draft + !> This subroutine calculates the gradients of bilinear basis elements that !! that are centered at the vertices of the cell. Values are calculated at !! points of gaussian quadrature. diff --git a/src/ice_shelf/MOM_ice_shelf_state.F90 b/src/ice_shelf/MOM_ice_shelf_state.F90 index 8b66f35f48..e6be780073 100644 --- a/src/ice_shelf/MOM_ice_shelf_state.F90 +++ b/src/ice_shelf/MOM_ice_shelf_state.F90 @@ -26,6 +26,7 @@ module MOM_ice_shelf_state area_shelf_h => NULL(), & !< The area per cell covered by the ice shelf [L2 ~> m2]. h_shelf => NULL(), & !< the thickness of the shelf [Z ~> m], redundant with mass but may !! make the code more readable + dhdt_shelf => NULL(), & !< the change in thickness of the shelf over time [Z T-1 ~> m s-1] hmask => NULL(),& !< Mask used to indicate ice-covered or partiall-covered cells !! 1: fully covered, solve for velocity here (for now all !! ice-covered cells are treated the same, this may change) @@ -70,6 +71,7 @@ subroutine ice_shelf_state_init(ISS, G) allocate(ISS%mass_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%area_shelf_h(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%h_shelf(isd:ied,jsd:jed), source=0.0 ) + allocate(ISS%dhdt_shelf(isd:ied,jsd:jed), source=0.0 ) allocate(ISS%hmask(isd:ied,jsd:jed), source=-2.0 ) allocate(ISS%tflux_ocn(isd:ied,jsd:jed), source=0.0 ) @@ -87,7 +89,7 @@ subroutine ice_shelf_state_end(ISS) if (.not.associated(ISS)) return - deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%hmask) + deallocate(ISS%mass_shelf, ISS%area_shelf_h, ISS%h_shelf, ISS%dhdt_shelf, ISS%hmask) deallocate(ISS%tflux_ocn, ISS%water_flux, ISS%salt_flux, ISS%tflux_shelf) deallocate(ISS%tfreeze) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 57cddeca5c..b207b1ff1c 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -20,12 +20,12 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_interface_heights, only : thickness_to_dz -use MOM_io, only : slasher, MOM_read_data +use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E use MOM_open_boundary, only : OBC_DIRECTION_W, OBC_DIRECTION_N, OBC_DIRECTION_S use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS -use MOM_restart, only : register_restart_field_as_obsolete +use MOM_restart, only : register_restart_field_as_obsolete, register_restart_pair use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type @@ -2072,8 +2072,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) end subroutine set_viscous_ML !> Register any fields associated with the vertvisc_type. -subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) +subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_CS, use_ice_shelf) type(hor_index_type), intent(in) :: HI !< A horizontal index type 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(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time @@ -2082,6 +2083,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) !! viscosities and related fields. !! Allocated here. type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + logical, intent(in) :: use_ice_shelf !< if true, register tau_shelf restarts ! Local variables logical :: use_kappa_shear, KS_at_vertex logical :: adiabatic, useKPP, useEPBL @@ -2090,6 +2092,7 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) real :: hfreeze !< If hfreeze > 0 [Z ~> m], melt potential will be computed. character(len=16) :: Kv_units, Kd_units character(len=40) :: mdl = "MOM_set_visc" ! This module's name. + type(vardesc) :: u_desc, v_desc isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke call get_param(param_file, mdl, "ADIABATIC", adiabatic, default=.false., & @@ -2173,6 +2176,19 @@ subroutine set_visc_register_restarts(HI, GV, US, param_file, visc, restart_CS) conversion=US%Z_to_m**2*US%s_to_T**3) endif + if (use_ice_shelf) then + if (.not.allocated(visc%taux_shelf)) & + allocate(visc%taux_shelf(G%IsdB:G%IedB, G%jsd:G%jed), source=0.0) + if (.not.allocated(visc%tauy_shelf)) & + allocate(visc%tauy_shelf(G%isd:G%ied, G%JsdB:G%JedB), source=0.0) + u_desc = var_desc("u_taux_shelf", "Pa", "the zonal stress on the ocean under ice shelves", & + hor_grid='Cu',z_grid='1') + v_desc = var_desc("v_tauy_shelf", "Pa", "the meridional stress on the ocean under ice shelves", & + hor_grid='Cv',z_grid='1') + call register_restart_pair(visc%taux_shelf, visc%tauy_shelf, u_desc, v_desc, & + .false., restart_CS, conversion=US%RZ_T_to_kg_m2s*US%L_T_to_m_s) + endif + end subroutine set_visc_register_restarts !> This subroutine does remapping for the auxiliary restart variables in a vertvisc_type From 4329f4709cb9141a5f37dd01d310c8085310e6c9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 1 Nov 2023 16:15:26 -0400 Subject: [PATCH 473/629] Update makedep to support directory exclusion Makedep can now exclude prescribed directories in the directory tree used to generate the file lists. This is required for projects which may not follow normal development processes, such as the FMS test programs. --- ac/makedep | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/ac/makedep b/ac/makedep index 9da68aa6e6..99c2ef6ce6 100755 --- a/ac/makedep +++ b/ac/makedep @@ -25,12 +25,12 @@ re_procedure = re.compile( ) -def create_deps(src_dirs, makefile, debug, exec_target, fc_rule, +def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, link_externals, script_path): """Create "makefile" after scanning "src_dis".""" # Scan everything Fortran related - all_files = find_files(src_dirs) + all_files = find_files(src_dirs, skip_dirs) # Lists of things # ... all F90 source @@ -332,10 +332,15 @@ def object_file(src_file): return os.path.splitext(os.path.basename(src_file))[0] + '.o' -def find_files(src_dirs): +def find_files(src_dirs, skip_dirs): """Return sorted list of all source files starting from each directory in the list "src_dirs".""" + if skip_dirs is not None: + skip = [os.path.normpath(s) for s in skip_dirs] + else: + skip = [] + # TODO: Make this a user-defined argument extensions = ('.f90', '.f', '.c', '.inc', '.h', '.fh') @@ -345,6 +350,8 @@ def find_files(src_dirs): if not os.path.isdir(path): raise ValueError("Directory '{}' was not found".format(path)) for p, d, f in os.walk(os.path.normpath(path), followlinks=True): + d[:] = [s for s in d if os.path.join(p, s) not in skip] + for file in f: if any(file.lower().endswith(ext) for ext in extensions): files.append(p+'/'+file) @@ -392,8 +399,13 @@ parser.add_argument( action='store_true', help="Annotate the makefile with extra information." ) +parser.add_argument( + '-s', '--skip', + action='append', + help="Skip directory in source code search." +) args = parser.parse_args() # Do the thing -create_deps(args.path, args.makefile, args.debug, args.exec_target, +create_deps(args.path, args.skip, args.makefile, args.debug, args.exec_target, args.fc_rule, args.link_externals, sys.argv[0]) From 4964b8b6a3187fc41aad0814332fe68de8c1fac0 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 3 Nov 2023 11:57:05 -0400 Subject: [PATCH 474/629] Target framework fix; config flag refactor The target (regression) configure step did not use a --with-framework flag and would always build with FMS1, even if FRAMEWORK was set to fms2. This patch adds the flag to its configure step. This patch also does some refactoring of the MOM_ENV and MOM_FCFLAGS setup rules. Values common to all rules are set externally, and additional values for individual rules are appended. Variable syntax also follows Makefile format (spaces around =) rather than POSIX shell (no spaces). --- .testing/Makefile | 50 ++++++++++++++++++++--------------------------- 1 file changed, 21 insertions(+), 29 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 6d2dc2addd..d88008e6f0 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -245,31 +245,26 @@ 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) \ +MOM_ENV := $(PATH_FMS) +build/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/asymmetric/Makefile: MOM_ENV += $(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) -build/opt/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/opt_target/Makefile: MOM_ENV=$(PATH_FMS) $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/coupled/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/nuopc/Makefile: MOM_ENV=$(PATH_FMS) $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/cov/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) -build/unit/Makefile: MOM_ENV=$(PATH_FMS) $(COV_FCFLAGS) $(COV_LDFLAGS) +build/repro/Makefile: MOM_ENV += $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +build/openmp/Makefile: MOM_ENV += $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +build/target/Makefile: MOM_ENV += $(TARGET_FCFLAGS) $(MOM_LDFLAGS) +build/opt/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +build/opt_target/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +build/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +build/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +build/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) # Configure script flags -build/symmetric/Makefile: MOM_ACFLAGS= -build/asymmetric/Makefile: MOM_ACFLAGS= -build/repro/Makefile: MOM_ACFLAGS= -build/openmp/Makefile: MOM_ACFLAGS=--enable-openmp -build/target/Makefile: MOM_ACFLAGS= -build/opt/Makefile: MOM_ACFLAGS= -build/opt_target/Makefile: MOM_ACFLAGS= -build/coupled/Makefile: MOM_ACFLAGS=--with-driver=FMS_cap -build/nuopc/Makefile: MOM_ACFLAGS=--with-driver=nuopc_cap -build/cov/Makefile: MOM_ACFLAGS= -build/unit/Makefile: MOM_ACFLAGS=--with-driver=unit_tests +MOM_ACFLAGS := --with-framework=$(FRAMEWORK) +build/openmp/Makefile: MOM_ACFLAGS += --enable-openmp +build/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap +build/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap +build/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) @@ -277,9 +272,6 @@ build/opt_target/Makefile: | $(TARGET_CODEBASE) # Define source code dependencies -# NOTE: ./configure is too much, but Makefile is not enough! -# Ideally we only want to re-run both Makefile and mkmf, but the mkmf call -# is inside ./configure, so we must re-run ./configure as well. build/target_codebase/configure: $(TARGET_SOURCE) @@ -295,8 +287,8 @@ build/%/MOM6: build/%/Makefile $(MOM_SOURCE) build/%/Makefile: ../ac/configure ../ac/Makefile.in deps/lib/libFMS.a mkdir -p $(@D) cd $(@D) \ - && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) --with-framework=$(FRAMEWORK) \ - || (cat config.log && false) + && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) \ + || (cat config.log && false) ../ac/configure: ../ac/configure.ac ../ac/m4 @@ -308,8 +300,8 @@ build/target/Makefile build/opt_target/Makefile: \ $(TARGET_CODEBASE)/ac/configure deps/lib/libFMS.a mkdir -p $(@D) cd $(@D) \ - && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ - || (cat config.log && false) + && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ + || (cat config.log && false) $(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) From 715f53ae3a250afe421b02461e62ddba2d5adf44 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 3 Nov 2023 13:29:32 -0400 Subject: [PATCH 475/629] Update default FMS to 2023.03 The default FMS build in ac/deps is updated to 2023.03. FMS source now includes a suite of test programs which require explicit preprocessing macros, which can complicate out makedep-based build when those macros are not present. To avoid this, the new "skip" flag has been added to the makedep build. The skip flag should not cause errors or other issues in older versions of FMS which do not have the excluded directory (though perhaps that could or should change in the future). --- .testing/Makefile | 2 +- ac/deps/Makefile | 2 +- ac/deps/Makefile.fms.in | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index d88008e6f0..6afda40a38 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -75,7 +75,7 @@ MAKEFLAGS += -R -include config.mk # Set the infra framework -FRAMEWORK ?= fms1 +FRAMEWORK ?= fms2 # Set the MPI launcher here # TODO: This needs more automated configuration diff --git a/ac/deps/Makefile b/ac/deps/Makefile index 3263dde678..01431cef8c 100644 --- a/ac/deps/Makefile +++ b/ac/deps/Makefile @@ -8,7 +8,7 @@ MAKEFLAGS += -R # FMS framework FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git -FMS_COMMIT ?= 2019.01.03 +FMS_COMMIT ?= 2023.03 # List of source files to link this Makefile's dependencies to model Makefiles diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in index caf4abb9c7..71c46f082a 100644 --- a/ac/deps/Makefile.fms.in +++ b/ac/deps/Makefile.fms.in @@ -23,4 +23,4 @@ ARFLAGS = @ARFLAGS@ .PHONY: depend depend: Makefile.dep Makefile.dep: - $(PYTHON) $(MAKEDEP) -o Makefile.dep -e -x libFMS.a @srcdir@ + $(PYTHON) $(MAKEDEP) -o Makefile.dep -e -x libFMS.a -s @srcdir@/test_fms @srcdir@ From feaeb116093cbced4b5384eee3a972db20a9dffe Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 11 Oct 2023 17:01:29 -0400 Subject: [PATCH 476/629] *Non-Boussinesq refactoring of brine plumes Revised the recently added brine-plume code to avoid using a vertical sum and to use tv%SpV_avg to determine the brine plume mixing thickness instead of GV%Z_to_H when in non-Boussinesq mode. Several internal brine plume expressions now work in units of H instead of Z, and a total of 5 unit conversion factors were eliminated. This will change certain non-Boussinesq calculations to avoid any dependency on the Boussinesq reference density, but some Boussinesq answers may also be changed and made more robust by avoiding the answer-indeterminate sum() function. --- .../vertical/MOM_diabatic_aux.F90 | 48 +++++++++++++------ 1 file changed, 34 insertions(+), 14 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 95c4d43ad3..6fdfdd5936 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -72,7 +72,8 @@ module MOM_diabatic_aux logical :: do_brine_plume !< If true, insert salt flux below the surface according to !! a parameterization by \cite Nguyen2009. integer :: brine_plume_n !< The exponent in the brine plume parameterization. - real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed layer. + real :: plume_strength !< Fraction of the available brine to take to the bottom of the mixed + !! layer [nondim]. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(diag_ctrl), pointer :: diag !< Structure used to regulate timing of diagnostic output @@ -1093,7 +1094,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. - real, pointer, dimension(:,:), optional :: MLD!< Mixed layer depth for brine plumes [Z ~> m] + real, pointer, dimension(:,:), optional :: MLD !< Mixed layer depth for brine plumes [Z ~> m] ! Local variables integer, parameter :: maxGroundings = 5 @@ -1135,7 +1136,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t netsalt_rate, & ! netsalt but for dt=1 (e.g. returns a rate) ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] - mixing_depth ! Mixed layer depth [Z -> m] + mixing_depth, & ! The mixing depth for brine plumes [H ~> m or kg m-2] + MLD_H, & ! The mixed layer depth for brine plumes in thickness units [H ~> m or kg m-2] + MLD_Z, & ! Running sum of distance from the surface for finding MLD_H [Z ~> m] + total_h ! Total thickness of the water column [H ~> m or kg m-2] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] ! dz, & ! Layer thicknesses in depth units [Z ~> m] @@ -1168,10 +1172,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! and rejected brine are initially applied in vanishingly thin layers at the ! top of the layer before being mixed throughout the layer. logical :: calculate_buoyancy ! If true, calculate the surface buoyancy flux. - real, dimension(SZI_(G)) :: dK ! Depth [Z ~> m]. - real, dimension(SZI_(G)) :: A_brine ! Constant [Z-(n+1) ~> m-(n+1)]. - real :: fraction_left_brine ! Sum for keeping track of the fraction of brine so far (in depth) - real :: plume_fraction ! Sum for keeping track of the fraction of brine so far (in depth) + real :: dK(SZI_(G)) ! Depth of the layer center in thickness units [H ~> m or kg m-2] + real :: A_brine(SZI_(G)) ! Constant [H-(n+1) ~> m-(n+1) or m(2n+2) kg-(n+1)]. + real :: fraction_left_brine ! Fraction of the brine that has not been applied yet [nondim] + real :: plume_fraction ! Fraction of the brine that is applied to a layer [nondim] real :: plume_flux ! Brine flux to move downwards [S H ~> ppt m or ppt kg m-2] integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, is, ie, js, je, k, nz, nb @@ -1238,7 +1242,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & !$OMP mixing_depth,A_brine,fraction_left_brine, & - !$OMP plume_fraction,dK) & + !$OMP plume_fraction,dK,MLD_H,MLD_Z,total_h) & !$OMP firstprivate(SurfPressure,plume_flux) do j=js,je ! Work in vertical slices for efficiency @@ -1363,9 +1367,26 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! B/ update mass, salt, temp from mass leaving ocean. ! C/ update temp due to penetrative SW if (CS%do_brine_plume) then + ! Find the plume mixing depth. + if (GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then + do i=is,ie ; MLD_H(i) = GV%Z_to_H * MLD(i,j) ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo + else + do i=is,ie ; MLD_H(i) = 0.0 ; MLD_Z(i) = 0.0 ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie + total_h(i) = total_h(i) + h(i,j,k) + if (MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) < MLD(i,j)) then + MLD_H(i) = MLD_H(i) + h(i,j,k) + MLD_Z(i) = MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + elseif (MLD_Z(i) < MLD(i,j)) then ! This is the last layer in the mixed layer + MLD_H(i) = MLD_H(i) + GV%RZ_to_H * (MLD(i,j) - MLD_Z(i)) / tv%SpV_avg(i,j,k) + MLD_Z(i) = MLD(i,j) + endif + enddo ; enddo + endif do i=is,ie - mixing_depth(i) = max(MLD(i,j) - minimum_forcing_depth * GV%H_to_Z, minimum_forcing_depth * GV%H_to_Z) - mixing_depth(i) = min(mixing_depth(i), max(sum(h(i,j,:)), GV%angstrom_h) * GV%H_to_Z) + mixing_depth(i) = min( max(MLD_H(i) - minimum_forcing_depth, minimum_forcing_depth), & + max(total_h(i), GV%angstrom_h) ) + GV%H_subroundoff A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) enddo endif @@ -1464,16 +1485,15 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t if (fluxes%salt_left_behind(i,j) > 0 .and. fraction_left_brine > 0.0) then ! Place forcing into this layer by depth for brine plume parameterization. if (k == 1) then - dK(i) = 0.5 * h(i,j,k) * GV%H_to_Z ! Depth of center of layer K + dK(i) = 0.5 * h(i,j,k) ! Depth of center of layer K plume_flux = - (1000.0*US%ppt_to_S * (CS%plume_strength * fluxes%salt_left_behind(i,j))) * GV%RZ_to_H plume_fraction = 1.0 else - dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) * GV%H_to_Z ! Depth of center of layer K + dK(i) = dK(i) + 0.5 * ( h(i,j,k) + h(i,j,k-1) ) ! Depth of center of layer K plume_flux = 0.0 endif if (dK(i) <= mixing_depth(i) .and. fraction_left_brine > 0.0) then - plume_fraction = min(fraction_left_brine, A_brine(i) * dK(i) ** CS%brine_plume_n & - * h(i,j,k) * GV%H_to_Z) + plume_fraction = min(fraction_left_brine, (A_brine(i) * dK(i)**CS%brine_plume_n) * h(i,j,k)) else IforcingDepthScale = 1. / max(GV%H_subroundoff, minimum_forcing_depth - netMassOut(i) ) ! plume_fraction = fraction_left_brine, unless h2d is less than IforcingDepthScale. From 0f2a69d52558d5a44486acdbc83272bd9b451b0c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 8 Nov 2023 09:03:09 -0900 Subject: [PATCH 477/629] Obc tracer fix (#507) * +Fix for issue #506, tracer OBC bug - it only happens in the advection for certain flow directions, inflow from OBC plus along-boundary flow. * Tracer OBCs need more of an h halo update. - This one should finally fix the processor count issues with OBCs. * Correct the "if" statement. * +Adding more halo points to an exchange - This will change answers if you start with a non-zero velocity. You need three halo points (or maybe cont_stencil) for the continuity solver. - Also trying to put in some initial DEBUG_OBC code. * Fix some DEBUG_OBC logic * Writing to temporary arrays for tres_xy - Way to trick some compiler. * Another fix for DEBUG_OBC * Fixing the whalo troubles for grids that are 2 wide/long. * Exchange all the h_new points. - without this, because we're remapping all the tres points, it dies in debug mode on bad h_new values. * Trying a different exchange - as it was, it was passing my tests, failing the auto-tests. * Fixing the DEBUG_OBC logging * Putting the logging statement back. - Making an error more verbose too. --- src/core/MOM.F90 | 12 ++-- src/core/MOM_open_boundary.F90 | 57 ++++++++++++++----- src/framework/MOM_restart.F90 | 4 +- .../lateral/MOM_hor_visc.F90 | 5 +- 4 files changed, 54 insertions(+), 24 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e1fa004fb8..ae794e02e2 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1627,9 +1627,11 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (CS%split) & call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) - if (associated(CS%OBC)) & - call pass_var(h_new, G%Domain) + if (associated(CS%OBC)) then + call pass_var(h, G%Domain, complete=.false.) + call pass_var(h_new, G%Domain, complete=.true.) call remap_OBC_fields(G, GV, h, h_new, CS%OBC, PCM_cell=PCM_cell) + endif call remap_vertvisc_aux_vars(G, GV, CS%visc, h, h_new, CS%ALE_CSp, CS%OBC) if (associated(CS%visc%Kv_shear)) & @@ -3016,10 +3018,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call cpu_clock_begin(id_clock_pass_init) call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) if (use_temperature) then - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain, halo=1) - call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%T, G%Domain) + call create_group_pass(tmp_pass_uv_T_S_h, CS%tv%S, G%Domain) endif - call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain, halo=1) + call create_group_pass(tmp_pass_uv_T_S_h, CS%h, G%Domain) call do_group_pass(tmp_pass_uv_T_S_h, G%Domain) call cpu_clock_end(id_clock_pass_init) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 13ce524006..5cf7c92fe9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -7,33 +7,33 @@ module MOM_open_boundary use MOM_array_transform, only : allocate_rotated_array use MOM_coms, only : sum_across_PEs, Set_PElist, Get_PElist, PE_here, num_PEs use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : diag_ctrl, time_type use MOM_domains, only : pass_var, pass_vector use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type use MOM_domains, only : To_All, EAST_FACE, NORTH_FACE, SCALAR_PAIR, CGRID_NE, CORNER +use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING, NOTE, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type, log_param use MOM_grid, only : ocean_grid_type, hor_index_type -use MOM_dyn_horgrid, only : dyn_horgrid_type use MOM_interface_heights, only : thickness_to_dz +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, field_size, SINGLE_FILE use MOM_io, only : vardesc, query_vardesc, var_desc +use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char +use MOM_regridding, only : regridding_CS +use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme, remapping_CS +use MOM_remapping, only : initialize_remapping, remapping_core_h, end_remapping use MOM_restart, only : register_restart_field, register_restart_pair use MOM_restart, only : query_initialized, MOM_restart_CS -use MOM_obsolete_params, only : obsolete_logical, obsolete_int, obsolete_real, obsolete_char -use MOM_string_functions, only : extract_word, remove_spaces, uppercase +use MOM_string_functions, only : extract_word, remove_spaces, uppercase, lowercase use MOM_tidal_forcing, only : astro_longitudes, astro_longitudes_init, eq_phase, nodal_fu, tidal_frequency 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 use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type -use MOM_string_functions, only : lowercase implicit none ; private @@ -528,13 +528,16 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%add_tide_constituents = .false. endif - call get_param(param_file, mdl, "DEBUG", OBC%debug, default=.false.) - call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=.false.) - if (debug_OBC .or. OBC%debug) & + call get_param(param_file, mdl, "DEBUG", debug_OBC, default=.false.) + call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug_OBC, & + do_not_log=.not.debug_OBC) + if (debug_OBC) then call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & "If true, do additional calls to help debug the performance "//& "of the open boundary condition code.", default=.false., & debuggingParam=.true.) + OBC%debug = debug_OBC + endif call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& @@ -854,6 +857,8 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) ! if (siz(4) == 1) segment%values_needed = .false. if (segment%on_pe) then if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then + write(mesg,'("Brushcutter mode sizes ", I6, I6))') siz(1), siz(2) + call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) call MOM_error(FATAL,'segment data are not on the supergrid') endif siz2(1)=1 @@ -2224,6 +2229,8 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, type(OBC_segment_type), pointer :: segment => NULL() integer :: i, j, k, is, ie, js, je, m, nz, n integer :: is_obc, ie_obc, js_obc, je_obc + logical :: sym + character(len=3) :: var_num is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -3298,6 +3305,29 @@ subroutine radiation_open_bdry_conds(OBC, u_new, u_old, v_new, v_old, G, GV, US, call pass_vector(u_new, v_new, G%Domain, clock=id_clock_pass) + if (OBC%debug) then + sym = G%Domain%symmetric + if (OBC%radiation_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_normal", OBC%rx_normal, OBC%ry_normal, G%HI, & + haloshift=0, symmetric=sym, scale=1.0) + endif + if (OBC%oblique_BCs_exist_globally) then + call uvchksum("radiation_OBCs: OBC%r[xy]_oblique_[uv]", OBC%rx_oblique_u, OBC%ry_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%r[yx]_oblique_[uv]", OBC%ry_oblique_u, OBC%rx_oblique_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + call uvchksum("radiation_OBCs: OBC%cff_normal_[uv]", OBC%cff_normal_u, OBC%cff_normal_v, G%HI, & + haloshift=0, symmetric=sym, scale=1.0/US%L_T_to_m_s**2) + endif + if (OBC%ntr == 0) return + if (.not. allocated (OBC%tres_x) .or. .not. allocated (OBC%tres_y)) return + do m=1,OBC%ntr + write(var_num,'(I3.3)') m + call uvchksum("radiation_OBCs: OBC%tres_[xy]_"//var_num, OBC%tres_x(:,:,:,m), OBC%tres_y(:,:,:,m), G%HI, & + haloshift=0, symmetric=sym, scale=1.0) + enddo + endif + end subroutine radiation_open_bdry_conds !> Applies OBC values stored in segments to 3d u,v fields @@ -5638,9 +5668,6 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) To_All+Scalar_Pair) if (OBC%oblique_BCs_exist_globally) then call do_group_pass(OBC%pass_oblique, G%Domain) -! call pass_vector(OBC%rx_oblique_u, OBC%ry_oblique_v, G%Domain, To_All+Scalar_Pair) -! call pass_vector(OBC%ry_oblique_u, OBC%rx_oblique_v, G%Domain, To_All+Scalar_Pair) -! call pass_vector(OBC%cff_normal_u, OBC%cff_normal_v, G%Domain, To_All+Scalar_Pair) endif end subroutine remap_OBC_fields diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 252f14bfac..188cfbb2ec 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -660,7 +660,7 @@ end subroutine register_restart_field_0d !> query_initialized_name determines whether a named field has been successfully -!! read from a restart file or has otherwise been recored as being initialzed. +!! read from a restart file or has otherwise been recorded as being initialized. function query_initialized_name(name, CS) result(query_initialized) character(len=*), intent(in) :: name !< The name of the field that is being queried type(MOM_restart_CS), intent(in) :: CS !< MOM restart control struct @@ -1271,7 +1271,7 @@ subroutine only_read_restart_pair_3d(a_ptr, b_ptr, a_name, b_name, G, CS, & end subroutine only_read_restart_pair_3d -!> Return an indicationof whether the named variable is the restart files, and provie the full path +!> Return an indication of whether the named variable is in the restart files, and provide the full path !! to the restart file in which a variable is found. function find_var_in_restart_files(varname, G, CS, file_path, filename, directory, is_global) result (found) character(len=*), intent(in) :: varname !< The variable name to be used in the restart file diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 02b4ec66a6..e3249afb73 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -414,12 +414,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB h_neglect = GV%H_subroundoff - h_neglect3 = h_neglect**3 + !h_neglect3 = h_neglect**3 + h_neglect3 = h_neglect*h_neglect*h_neglect inv_PI3 = 1.0/((4.0*atan(1.0))**3) inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 - m_leithy(:,:) = 0. ! Initialize + m_leithy(:,:) = 0.0 ! Initialize if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally From b15a9d4deaa73e8272662161e5c2209e8e77de41 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 10 Nov 2023 11:34:59 -0500 Subject: [PATCH 478/629] Adds stand alone test_MOM_EOS and time_MOM_EOS (#516) - Added simple single-thread program to invoke EOS_unit_tests.F90 - Added not-as-simple program to time the cost of calculate_density() and calculate_spec_vol() for both scalar and array APIs - Placed in new directory config_src/drivers/timing_tests/ - Renamed MOM_unit_test_driver.F90 to test_MOM_file_parser.F90 - Updated .testing/Makefile - Added list of programs in config_src/drivers/unit_tests - These are added to BUILDS if DO_UNIT_TESTS is not blank. (DO_UNIT_TESTS was an existing macro but it might be uneeded) - These programs are compiled with code coverage - Added list of programs in config_src/drivers/timing_tests - These programs are compiled with optimization and no coverage - Fixed rule for building UNIT_EXECS (which did not re-build properly because the central Makefile was trying to model the dependencies even though those dependencies are in the build/unit/Makefile.dep) - Added convenient targets build.unit, run.unit, build.timing, run.timing - Timing tests currently time a loop over 1000 calls (so that the resolution of the CPU timer is not too large) and 400 samples to collect statistics on timings. On gaea c5 this takes about 10 seconds. - The results are written to stdout in json. - Added placeholder build and run of timing_tests to GH workflow. - Enabled for [push,pull_request] - We probably will not be able to use timings from GH but I still want to exercise the code we know the timing programs aren't broken by a commit. - Also added driver for string_functions_unit_tests --- .github/workflows/coverage.yml | 12 +- .github/workflows/perfmon.yml | 17 +- .testing/Makefile | 71 ++++-- .testing/README.rst | 11 + .testing/tools/disp_timing.py | 133 +++++++++++ .../drivers/timing_tests/time_MOM_EOS.F90 | 206 ++++++++++++++++++ .../drivers/unit_tests/test_MOM_EOS.F90 | 10 + ...st_driver.F90 => test_MOM_file_parser.F90} | 4 +- .../test_MOM_mixedlayer_restrat.F90 | 10 + .../unit_tests/test_MOM_string_functions.F90 | 10 + src/equation_of_state/MOM_EOS.F90 | 41 +++- src/framework/MOM_error_handler.F90 | 75 +++++-- .../lateral/MOM_mixed_layer_restrat.F90 | 2 + 13 files changed, 564 insertions(+), 38 deletions(-) create mode 100755 .testing/tools/disp_timing.py create mode 100644 config_src/drivers/timing_tests/time_MOM_EOS.F90 create mode 100644 config_src/drivers/unit_tests/test_MOM_EOS.F90 rename config_src/drivers/unit_tests/{MOM_unit_test_driver.F90 => test_MOM_file_parser.F90} (96%) create mode 100644 config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 create mode 100644 config_src/drivers/unit_tests/test_MOM_string_functions.F90 diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index ad15989475..5cd5f91baa 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -19,12 +19,18 @@ jobs: - uses: ./.github/actions/testing-setup - - name: Compile unit testing - run: make -j build/unit/MOM_unit_tests + - name: Compile file parser unit tests + run: make -j build/unit/test_MOM_file_parser - - name: Run unit tests + - name: Run file parser unit tests run: make run.cov.unit + - name: Compile unit testing + run: make -j build.unit + + - name: Run (single processor) unit tests + run: make run.unit + - name: Report unit test coverage to CI (PR) if: github.event_name == 'pull_request' run: make report.cov.unit REQUIRE_COVERAGE_UPLOAD=true diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml index 09b4d617a2..76140c9469 100644 --- a/.github/workflows/perfmon.yml +++ b/.github/workflows/perfmon.yml @@ -1,6 +1,6 @@ name: Performance Monitor -on: [pull_request] +on: [push, pull_request] jobs: build-test-perfmon: @@ -20,6 +20,7 @@ jobs: - uses: ./.github/actions/testing-setup - name: Compile optimized models + if: ${{ github.event_name == 'pull_request' }} run: >- make -j build.prof MOM_TARGET_SLUG=$GITHUB_REPOSITORY @@ -27,12 +28,26 @@ jobs: DO_REGRESSION_TESTS=true - name: Generate profile data + if: ${{ github.event_name == 'pull_request' }} run: >- pip install f90nml && make profile DO_REGRESSION_TESTS=true - name: Generate perf data + if: ${{ github.event_name == 'pull_request' }} run: | sudo sysctl -w kernel.perf_event_paranoid=2 make perf DO_REGRESSION_TESTS=true + + - name: Compile timing tests + run: | + make -j build.timing + + - name: Run timing tests + run: | + make -j run.timing + + - name: Display timing results + run: | + make -j show.timing diff --git a/.testing/Makefile b/.testing/Makefile index 6afda40a38..aabe51c8b6 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -116,6 +116,9 @@ DO_PROFILE ?= # Enable code coverage runs DO_COVERAGE ?= +# Enable code coverage runs +DO_UNIT_TESTS ?= + # Report failure if coverage report is not uploaded REQUIRE_COVERAGE_UPLOAD ?= @@ -151,10 +154,16 @@ ifeq ($(DO_PROFILE), true) BUILDS += opt/MOM6 opt_target/MOM6 endif -# Unit testing -UNIT_EXECS ?= MOM_unit_tests +# Coverage ifeq ($(DO_COVERAGE), true) - BUILDS += cov/MOM6 $(foreach e, $(UNIT_EXECS), unit/$(e)) + BUILDS += cov/MOM6 +endif + +# Unit testing (or coverage) +UNIT_EXECS ?= $(basename $(notdir $(wildcard ../config_src/drivers/unit_tests/*.F90) ) ) +TIMING_EXECS ?= $(basename $(notdir $(wildcard ../config_src/drivers/timing_tests/*.F90) ) ) +ifneq (X$(DO_COVERAGE)$(DO_UNIT_TESTS)X, XX) + BUILDS += $(foreach e, $(UNIT_EXECS), unit/$(e)) endif ifeq ($(DO_PROFILE), false) @@ -258,6 +267,7 @@ build/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) build/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) build/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +build/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) # Configure script flags MOM_ACFLAGS := --with-framework=$(FRAMEWORK) @@ -265,6 +275,7 @@ build/openmp/Makefile: MOM_ACFLAGS += --enable-openmp build/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap build/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap build/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests +build/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Fetch regression target source code build/target/Makefile: | $(TARGET_CODEBASE) @@ -276,10 +287,15 @@ build/target_codebase/configure: $(TARGET_SOURCE) # Build executables -$(foreach e,$(UNIT_EXECS),build/unit/$(e)): build/unit/Makefile $(MOM_SOURCE) - cd $(@D) && $(TIME) $(MAKE) -j -build/%/MOM6: build/%/Makefile $(MOM_SOURCE) - cd $(@D) && $(TIME) $(MAKE) -j +build/unit/test_%: build/unit/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +build/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) +build/timing/time_%: build/timing/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +build/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) +build/%/MOM6: build/%/Makefile FORCE + cd $(@D) && $(TIME) $(MAKE) $(@F) -j +FORCE: ; # Use autoconf to construct the Makefile for each target @@ -655,28 +671,47 @@ test.summary: .PHONY: run.cov.unit run.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov -$(WORKSPACE)/work/unit/std.out: build/unit/MOM_unit_tests +.PHONY: build.unit +build.unit: $(foreach f, $(UNIT_EXECS), build/unit/$(f)) +.PHONY: run.unit +run.unit: $(foreach f, $(UNIT_EXECS), work/unit/$(f).out) +.PHONY: build.timing +build.timing: $(foreach f, $(TIMING_EXECS), build/timing/$(f)) +.PHONY: run.timing +run.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).out) +.PHONY: show.timing +show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) +$(WORKSPACE)/work/timing/%.show: + ./tools/disp_timing.py $(@:.show=.out) + +# General rule to run a unit test executable +# Pattern is to run build/unit/executable and direct output to executable.out +$(WORKSPACE)/work/unit/%.out: build/unit/% + @mkdir -p $(@D) + cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> >(tee $*.err) > $*.out + +$(WORKSPACE)/work/unit/test_MOM_file_parser.out: build/unit/test_MOM_file_parser if [ $(REPORT_COVERAGE) ]; then \ find build/unit -name *.gcda -exec rm -f '{}' \; ; \ fi - rm -rf $(@D) mkdir -p $(@D) cd $(@D) \ - && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out \ + && rm -f input.nml logfile.0000*.out *_input MOM_parameter_doc.* \ + && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> test_MOM_file_parser.err > test_MOM_file_parser.out \ || !( \ - cat std.out | tail -n 100 ; \ - cat std.err | tail -n 100 ; \ + cat test_MOM_file_parser.out | tail -n 100 ; \ + cat test_MOM_file_parser.err | tail -n 100 ; \ ) cd $(@D) \ - && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.std.err > p2.std.out \ + && $(TIME) $(MPIRUN) -n 2 $(abspath $<) 2> p2.test_MOM_file_parser.err > p2.test_MOM_file_parser.out \ || !( \ - cat p2.std.out | tail -n 100 ; \ - cat p2.std.err | tail -n 100 ; \ + cat p2.test_MOM_file_parser.out | tail -n 100 ; \ + cat p2.test_MOM_file_parser.err | tail -n 100 ; \ ) # NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out # TODO: Replace $(WORKSPACE)/work/unit/std.out with *.gcda? -build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/std.out +build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/test_MOM_file_parser.out cd $(@D) \ && gcov -b *.gcda > gcov.unit.out find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; @@ -693,6 +728,10 @@ report.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov codecov if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ } +$(WORKSPACE)/work/timing/%.out: build/timing/% FORCE + @mkdir -p $(@D) + @echo Running $< in $(@D) + @cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> $*.err > $*.out #--- # Profiling based on FMS clocks diff --git a/.testing/README.rst b/.testing/README.rst index 5bab076707..49103da718 100644 --- a/.testing/README.rst +++ b/.testing/README.rst @@ -22,6 +22,17 @@ Usage ``make clean`` Delete the MOM6 test executables and dependency builds (FMS). +``make -j build.unit`` + Build the unit test programs in config_src/drivers/unit_tests + +``make -j run.unit`` + Run the unit test programs from config_src/drivers/unit_tests in $(WORKSPACE)/work/unit + +``make -j build.timing`` + Build the timing test programs in config_src/drivers/timing_tests + +``make -j run.timing`` + Run the timing test programs from config_src/drivers/timing_tests in $(WORKSPACE)/work/timing Configuration ============= diff --git a/.testing/tools/disp_timing.py b/.testing/tools/disp_timing.py new file mode 100755 index 0000000000..ac90ef2b55 --- /dev/null +++ b/.testing/tools/disp_timing.py @@ -0,0 +1,133 @@ +#!/usr/bin/env python3 + +from __future__ import print_function + +import argparse +import json +import math + +scale = 1e6 # micro-seconds (should make this dynamic) + + +def display_timing_file(file, show_all): + """Parse a JSON file of timing results and pretty-print the results""" + + with open(file) as json_file: + timing_dict = json.load(json_file) + + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Min time Module & function") + for sub in timing_dict.keys(): + tmin = timing_dict[sub]['min'] * scale + print("%10.4e %s" % (tmin, sub)) + + if show_all: + tmean = timing_dict[sub]['mean'] * scale + tmax = timing_dict[sub]['max'] * scale + tstd = timing_dict[sub]['std'] * scale + nsamp = timing_dict[sub]['n_samples'] + tsstd = tstd / math.sqrt(nsamp) + print(" (" + + "mean = %10.4e " % (tmean) + + "±%7.1e, " % (tsstd) + + "max = %10.4e, " % (tmax) + + "std = %8.2e, " % (tstd) + + "# = %d)" % (nsamp)) + + +def compare_timing_files(file, ref, show_all, significance_threshold): + """Read and compare two JSON files of timing results""" + + with open(file) as json_file: + timing_dict = json.load(json_file) + + with open(ref) as json_file: + ref_dict = json.load(json_file) + + print("(Times measured in %5.0e seconds)" % (1./scale)) + print(" Delta (%) Module & function") + for sub in {**ref_dict, **timing_dict}.keys(): + T1 = ref_dict.get(sub) + T2 = timing_dict.get(sub) + if T1 is not None: + # stats for reference (old) + tmin1 = T1['min'] * scale + tmean1 = T1['mean'] * scale + if T2 is not None: + # stats for reference (old) + tmin2 = T2['min'] * scale + tmean2 = T2['mean'] * scale + if (T1 is not None) and (T2 is not None): + # change in actual minimum as percentage of old + dt = (tmin2 - tmin1) * 100 / tmin1 + if dt < -significance_threshold: + color = '\033[92m' + elif dt > significance_threshold: + color = '\033[91m' + else: + color = '' + print("%s%+10.4f%%\033[0m %s" % (color, dt, sub)) + else: + if T2 is None: + print(" removed %s" % (sub)) + else: + print(" added %s" % (sub)) + + if show_all: + if T2 is None: + print(" --") + else: + tmax2 = T2['max'] * scale + tstd2 = T2['std'] * scale + n2 = T2['n_samples'] + tsstd2 = tstd2 / math.sqrt(n2) + print(" %10.4e (" % (tmin2) + + "mean = %10.4e " % (tmean2) + + "±%7.1e, " % (tsstd2) + + "max=%10.4e, " % (tmax2) + + "std=%8.2e, " % (tstd2) + + "# = %d)" % (n2)) + if T1 is None: + print(" --") + else: + tmax1 = T1['max'] * scale + tstd1 = T1['std'] * scale + n1 = T1['n_samples'] + tsstd1 = tstd1 / math.sqrt(n1) + print(" %10.4e (" % (tmin1) + + "mean = %10.4e " % (tmean1) + + "±%7.1e, " % (tsstd1) + + "max=%10.4e, " % (tmax1) + + "std=%8.2e, " % (tstd1) + + "# = %d)" % (n1)) + + +# Parse arguments +parser = argparse.ArgumentParser( + description="Beautify timing output from MOM6 timing tests." +) +parser.add_argument( + 'file', + help="File to process." +) +parser.add_argument( + '-a', '--all', + action='store_true', + help="Display all metrics rather than just the minimum time." +) +parser.add_argument( + '-t', '--threshold', + default=6.0, type=float, + help="Significance threshold to flag (percentage)." +) +parser.add_argument( + '-r', '--reference', + help="Reference file to compare against." +) +args = parser.parse_args() + +# Do the thing +if args.reference is None: + display_timing_file(args.file, args.all) +else: + compare_timing_files(args.file, args.reference, args.all, args.threshold) diff --git a/config_src/drivers/timing_tests/time_MOM_EOS.F90 b/config_src/drivers/timing_tests/time_MOM_EOS.F90 new file mode 100644 index 0000000000..29bd4a30ab --- /dev/null +++ b/config_src/drivers/timing_tests/time_MOM_EOS.F90 @@ -0,0 +1,206 @@ +program time_MOM_EOS + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_EOS, only : EOS_type +use MOM_EOS, only : EOS_manual_init +use MOM_EOS, only : calculate_density, calculate_spec_vol +use MOM_EOS, only : list_of_eos, get_EOS_name + +implicit none + +! This macro is used to write out timings of a single test rather than conduct +! a suite of tests. It is not meant for general consumption. +#undef PDF_ONLY + +integer, parameter :: n_fns = 4 +character(len=40) :: fn_labels(n_fns) + +! Testing parameters: +! nic is number of elements to compute density for (array size), per call +! halo is data on either end of the array that should not be used +! nits is how many times to repeat the call between turning the timer on/off +! to overcome limited resolution of the timer +! nsamp repeats the timing to collect statistics on the measurement +#ifdef PDF_ONLY +integer, parameter :: nic=26, halo=4, nits=10000, nsamp=400 +#else +integer, parameter :: nic=23, halo=4, nits=1000, nsamp=400 +#endif + +real :: times(nsamp) ! For observing the PDF + +! Arrays to hold timings: +! first axis corresponds to the form of EOS +! second axis corresponds to the function being timed +real, dimension(:,:), allocatable :: timings, tmean, tstd, tmin, tmax +integer :: n_eos, i, j + +n_eos = size(list_of_eos) +allocate( timings(n_eos,n_fns), tmean(n_eos,n_fns) ) +allocate( tstd(n_eos,n_fns), tmin(n_eos,n_fns), tmax(n_eos,n_fns) ) + +fn_labels(1) = 'calculate_density_scalar()' +fn_labels(2) = 'calculate_density_array()' +fn_labels(3) = 'calculate_spec_vol_scalar()' +fn_labels(4) = 'calculate_spec_vol_array()' + +tmean(:,:) = 0. +tstd(:,:) = 0. +tmin(:,:) = 1.e9 +tmax(:,:) = 0. +do i = 1, nsamp +#ifdef PDF_ONLY + call run_one(list_of_EOS, nic, halo, nits, times(i)) +#else + call run_suite(list_of_EOS, nic, halo, nits, timings) + tmean(:,:) = tmean(:,:) + timings(:,:) + tstd(:,:) = tstd(:,:) + timings(:,:)**2 ! tstd contains sum or squares here + tmin(:,:) = min( tmin(:,:), timings(:,:) ) + tmax(:,:) = max( tmax(:,:), timings(:,:) ) +#endif +enddo +tmean(:,:) = tmean(:,:) / real(nsamp) +tstd(:,:) = tstd(:,:) / real(nsamp) ! convert to mean of squares +tstd(:,:) = tstd(:,:) - tmean(:,:)**2 ! convert to variance +tstd(:,:) = sqrt( tstd(:,:) * ( real(nsamp) / real(nsamp-1) ) ) ! Standard deviation + +#ifdef PDF_ONLY +open(newunit=i, file='times.txt', status='replace', action='write') +write(i,'(1pE9.3)') times(:) +close(i) +#else + +! Display results in YAML +write(*,'(a)') "{" +do i = 1, n_eos + do j = 1, n_fns + write(*,"(2x,5a)") '"MOM_EOS_', trim(get_EOS_name(list_of_EOS(i))), & + ' ', trim(fn_labels(j)), '": {' + write(*,"(4x,a,1pe11.4,',')") '"min": ',tmin(i,j) + write(*,"(4x,a,1pe11.4,',')") '"mean":',tmean(i,j) + write(*,"(4x,a,1pe11.4,',')") '"std": ',tstd(i,j) + write(*,"(4x,a,i7,',')") '"n_samples": ',nsamp + if (i*j.ne.n_eos*n_fns) then + write(*,"(4x,a,1pe11.4,'},')") '"max": ',tmax(i,j) + else + write(*,"(4x,a,1pe11.4,'}')") '"max": ',tmax(i,j) + endif + enddo +enddo +write(*,'(a)') "}" +#endif + +contains + +subroutine run_suite(EOS_list, nic, halo, nits, timings) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timings(n_eos,n_fns) !< The average time taken for nits calls + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: e, i, dom(2) + real :: start, finish, T, S, P, rho + real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + + T = 10. + S = 35. + P = 2000.e4 + + ! Time the scalar interface + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_density(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,1) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits*nic ! Calling nic* to make similar cost to array call + call calculate_spec_vol(T, S, P, rho, EOS) + enddo + call cpu_time(finish) + timings(e,2) = (finish - start) / real(nits) + + enddo + + ! Time the "dom" interface, 1D array + halos + T1(:) = T + S1(:) = S + P1(:) = P + dom(:) = [1+halo,nic+halo] + + do e = 1, n_eos + call EOS_manual_init(EOS, form_of_EOS=EOS_list(e), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,3) = (finish - start) / real(nits) + + call cpu_time(start) + do i = 1, nits + call calculate_spec_vol(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timings(e,4) = (finish - start) / real(nits) + + enddo + +end subroutine run_suite + +!> Return timing for just one fixed call to explore the PDF +subroutine run_one(EOS_list, nic, halo, nits, timing) + integer, intent(in) :: EOS_list(n_eos) !< IDs of EOS forms to loop over + integer, intent(in) :: nic !< Width of computational domain + integer, intent(in) :: halo !< Width of halo to add on either end + integer, intent(in) :: nits !< Number of calls to sample + !! (large enough that the CPU timers can resolve + !! the loop) + real, intent(out) :: timing !< The average time taken for nits calls + !! First index corresponds to EOS + !! Second index: 1 = scalar args, + !! 2 = array args without halo, + !! 3 = array args with halo and "dom". + type(EOS_type) :: EOS + integer :: i, dom(2) + real :: start, finish + real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + + ! Time the scalar interface + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + ! Time the "dom" interface, 1D array + halos + T1(:) = 10. + S1(:) = 35. + P1(:) = 2000.e4 + dom(:) = [1+halo,nic+halo] + + call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & + Rho_T0_S0=1030., dRho_dT=0.2, dRho_dS=-0.7) + + call cpu_time(start) + do i = 1, nits + call calculate_density(T1, S1, P1, rho1, EOS, dom) + enddo + call cpu_time(finish) + timing = (finish-start)/real(nits) + +end subroutine run_one + +end program time_MOM_EOS diff --git a/config_src/drivers/unit_tests/test_MOM_EOS.F90 b/config_src/drivers/unit_tests/test_MOM_EOS.F90 new file mode 100644 index 0000000000..070bec04f6 --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_EOS.F90 @@ -0,0 +1,10 @@ +program test_MOM_EOS + +use MOM_EOS, only : EOS_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( EOS_unit_tests(.true.) ) stop 1 + +end program test_MOM_EOS diff --git a/config_src/drivers/unit_tests/MOM_unit_test_driver.F90 b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 similarity index 96% rename from config_src/drivers/unit_tests/MOM_unit_test_driver.F90 rename to config_src/drivers/unit_tests/test_MOM_file_parser.F90 index eafa8fa722..55f57d5fc2 100644 --- a/config_src/drivers/unit_tests/MOM_unit_test_driver.F90 +++ b/config_src/drivers/unit_tests/test_MOM_file_parser.F90 @@ -1,4 +1,4 @@ -program MOM_unit_tests +program test_MOM_file_parser use MPI use MOM_domains, only : MOM_infra_init @@ -62,4 +62,4 @@ program MOM_unit_tests close(io_unit, status='delete') endif -end program MOM_unit_tests +end program test_MOM_file_parser diff --git a/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 new file mode 100644 index 0000000000..3e5eec64fc --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_mixedlayer_restrat.F90 @@ -0,0 +1,10 @@ +program test_MOM_mixedlayer_restrat + +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( mixedlayer_restrat_unit_tests(.true.) ) stop 1 + +end program test_MOM_mixedlayer_restrat diff --git a/config_src/drivers/unit_tests/test_MOM_string_functions.F90 b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 new file mode 100644 index 0000000000..2376afbbae --- /dev/null +++ b/config_src/drivers/unit_tests/test_MOM_string_functions.F90 @@ -0,0 +1,10 @@ +program test_MOM_string_functions + +use MOM_string_functions, only : string_functions_unit_tests +use MOM_error_handler, only : set_skip_mpi + +call set_skip_mpi(.true.) ! This unit tests is not expecting MPI to be used + +if ( string_functions_unit_tests(.true.) ) stop 1 + +end program test_MOM_string_functions diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index c68dc7b661..2087cd86e5 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -84,6 +84,7 @@ module MOM_EOS public gsw_sp_from_sr public gsw_pt_from_ct public query_compressible +public get_EOS_name ! 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 @@ -181,6 +182,10 @@ module MOM_EOS 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 +!> A list of all the available EOS +integer, dimension(9), public :: list_of_EOS = (/ EOS_LINEAR, EOS_UNESCO, & + EOS_WRIGHT, EOS_WRIGHT_FULL, EOS_WRIGHT_REDUCED, & + EOS_TEOS10, EOS_ROQUET_RHO, EOS_ROQUET_SPV, EOS_JACKETT06 /) 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 @@ -1679,6 +1684,36 @@ logical function query_compressible(EOS) query_compressible = EOS%compressible end function query_compressible +!> Returns the string identifying the equation of state with enumeration "id" +function get_EOS_name(id) result (eos_name) + integer, optional, intent(in) :: id !< Enumerated ID + character(:), allocatable :: eos_name !< The name of the EOS + + select case (id) + case (EOS_LINEAR) + eos_name = EOS_LINEAR_STRING + case (EOS_UNESCO) + eos_name = EOS_UNESCO_STRING + case (EOS_WRIGHT) + eos_name = EOS_WRIGHT_STRING + case (EOS_WRIGHT_REDUCED) + eos_name = EOS_WRIGHT_RED_STRING + case (EOS_WRIGHT_FULL) + eos_name = EOS_WRIGHT_FULL_STRING + case (EOS_TEOS10) + eos_name = EOS_TEOS10_STRING + case (EOS_ROQUET_RHO) + eos_name = EOS_ROQUET_RHO_STRING + case (EOS_ROQUET_SPV) + eos_name = EOS_ROQUET_SPV_STRING + case (EOS_JACKETT06) + eos_name = EOS_JACKETT06_STRING + case default + call MOM_error(FATAL, "get_EOS_name: something went wrong internally - enumeration is not valid.") + end select + +end function get_EOS_name + !> Initializes EOS_type by allocating and reading parameters. The scaling factors in !! US are stored in EOS for later use. subroutine EOS_init(param_file, EOS, US) @@ -2249,7 +2284,11 @@ logical function EOS_unit_tests(verbose) 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.") + if (EOS_unit_tests) then + call MOM_error(WARNING, "EOS_unit_tests: One or more EOS tests have failed!") + else + if (verbose) call MOM_mesg("EOS_unit_tests: All EOS consistency tests have passed.") + endif end function EOS_unit_tests diff --git a/src/framework/MOM_error_handler.F90 b/src/framework/MOM_error_handler.F90 index d61e82b32c..b113050572 100644 --- a/src/framework/MOM_error_handler.F90 +++ b/src/framework/MOM_error_handler.F90 @@ -10,6 +10,11 @@ module MOM_error_handler use posix, only : sigjmp_buf, siglongjmp use posix, only : sleep +! MOM_error_infra does not provide stderr . We only use stderr in this module +! *IF* FMS has not been initialized. Further, stderr is only used internally and +! not made public. Other modules should obtain stderr from MOM_io. +use iso_fortran_env, only : stderr=>error_unit + implicit none ; private ! These routines are found in this module. @@ -20,7 +25,7 @@ module MOM_error_handler public :: is_root_pe, stdlog, stdout !> Integer parameters encoding the severity of an error message public :: NOTE, WARNING, FATAL -public :: disable_fatal_errors, enable_fatal_errors +public :: disable_fatal_errors, enable_fatal_errors, set_skip_mpi integer :: verbosity = 6 !< Verbosity level: @@ -58,6 +63,11 @@ module MOM_error_handler !< The default signal handler used before signal() setup (usually SIG_DFT) type(sigjmp_buf) :: prior_env !< Buffer containing the program state to be recovered by longjmp +logical :: skip_mpi_dep = .false. + !< If true, bypass any calls that require FMS (MPI) to have been initialized. + !! Use s/r set_skip_mpi() to change this flag. By default, set_skip_mpi() does not + !! need to be called and this flag is false so that FMS (and MPI) should be + !! initialized. contains @@ -72,11 +82,15 @@ subroutine MOM_mesg(message, verb, all_print) integer :: verb_msg logical :: write_msg - write_msg = is_root_pe() + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif if (present(all_print)) write_msg = write_msg .or. all_print verb_msg = 2 ; if (present(verb)) verb_msg = verb - if (write_msg .and. (verbosity >= verb_msg)) call MOM_err(NOTE, message) + if (write_msg .and. (verbosity >= verb_msg)) call loc_MOM_err(NOTE, message) end subroutine MOM_mesg @@ -121,6 +135,14 @@ subroutine enable_fatal_errors() dummy => signal(sig, prior_handler) end subroutine enable_fatal_errors +!> Enable/disable skipping MPI dependent behaviors +subroutine set_skip_mpi(skip) + logical, intent(in) :: skip !< State to assign + + skip_mpi_dep = skip + +end subroutine set_skip_mpi + !> This provides a convenient interface for writing an error message !! with run-time filter based on a verbosity and the severity of the error. subroutine MOM_error(level, message, all_print) @@ -128,19 +150,21 @@ subroutine MOM_error(level, message, all_print) character(len=*), intent(in) :: message !< A message to write out logical, optional, intent(in) :: all_print !< If present and true, any PEs are !! able to write this message. - ! This provides a convenient interface for writing an error message - ! with run-time filter based on a verbosity. logical :: write_msg integer :: rc - write_msg = is_root_pe() + if (skip_mpi_dep) then + write_msg = .true. + else + write_msg = is_root_pe() + endif if (present(all_print)) write_msg = write_msg .or. all_print select case (level) case (NOTE) - if (write_msg.and.verbosity>=2) call MOM_err(NOTE, message) + if (write_msg.and.verbosity>=2) call loc_MOM_err(NOTE, message) case (WARNING) - if (write_msg.and.verbosity>=1) call MOM_err(WARNING, message) + if (write_msg.and.verbosity>=1) call loc_MOM_err(WARNING, message) case (FATAL) if (ignore_fatal) then print *, "(FATAL): " // message @@ -151,12 +175,33 @@ subroutine MOM_error(level, message, all_print) ! In practice, the signal will take control before sleep() completes. rc = sleep(3) endif - if (verbosity>=0) call MOM_err(FATAL, message) + if (verbosity>=0) call loc_MOM_err(FATAL, message) case default - call MOM_err(level, message) + call loc_MOM_err(level, message) end select end subroutine MOM_error +!> A private routine through which all error/warning/note messages are written +!! by this module. +subroutine loc_MOM_err(level, message) + integer, intent(in) :: level !< The severity level of this message + character(len=*), intent(in) :: message !< A message to write out + + if (.not. skip_mpi_dep) then + call MOM_err(level, message) + else + ! FMS (and therefore MPI) have not been initialized + write(stdout(),'(a)') trim(message) ! Send message to stdout + select case (level) + case (WARNING) + write(stderr,'("WARNING ",a)') trim(message) ! Additionally send message to stderr + case (FATAL) + write(stderr,'("ERROR: ",a)') trim(message) ! Additionally send message to stderr + end select + endif + +end subroutine loc_MOM_err + !> This subroutine sets the level of verbosity filtering MOM error messages subroutine MOM_set_verbosity(verb) integer, intent(in) :: verb !< A level of verbosity to set @@ -202,10 +247,10 @@ subroutine callTree_enter(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'loop '//trim(mesg)//trim(nAsString)) else - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel-1)//'---> '//trim(mesg)) endif endif @@ -217,7 +262,7 @@ subroutine callTree_leave(mesg) if (callTreeIndentLevel<1) write(0,*) 'callTree_leave: error callTreeIndentLevel=',callTreeIndentLevel,trim(mesg) callTreeIndentLevel = callTreeIndentLevel - 1 if (verbosity<6) return - if (is_root_pe()) call MOM_err(NOTE, 'callTree: '// & + if (is_root_pe()) call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'<--- '//trim(mesg)) end subroutine callTree_leave @@ -233,10 +278,10 @@ subroutine callTree_waypoint(mesg,n) nAsString = '' if (present(n)) then write(nAsString(1:8),'(i8)') n - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'loop '//trim(mesg)//trim(nAsString)) else - call MOM_err(NOTE, 'callTree: '// & + call loc_MOM_err(NOTE, 'callTree: '// & repeat(' ',callTreeIndentLevel)//'o '//trim(mesg)) endif endif diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 1f73653aa3..e21c33beaf 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1794,6 +1794,8 @@ subroutine mixedlayer_restrat_register_restarts(HI, GV, US, param_file, CS, rest end subroutine mixedlayer_restrat_register_restarts +!> Returns true if a unit test of functions in MOM_mixedlayer_restrat fail. +!! Returns false otherwise. logical function mixedlayer_restrat_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables From 753cab308dc6d87bd17dd4df3f95664158c2deec Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Nov 2023 08:29:43 -0500 Subject: [PATCH 479/629] +Refactor ALE_remap_velocities Refactored ALE_remap_velocities to separate the code setting the thicknesses at velocity points from the code that actually does the remapping. This includes the creation of the new public routines ALE_remap_set_h_vel and ALE_remap_set_h_vel_via_dz and the replacement the pair of tracer point thickness arguments to ALE_remap_velocities and remap_dyn_split_RK2_aux_vars with a pair of the old and new thicknesses at the velocity points and the elimination of several arguments to these routines that are no longer being used. There are also new internal routines ALE_remap_set_h_vel_partial and ALE_remap_set_h_vel_OBC to apply modifications to the velocity point thicknesses with OBCs and one runtime option. The runtime variable REMAP_UV_USING_OLD_ALG has effectively been moved from MOM_ALE.F90 to MOM.F90, although it is still being read in MOM_ALE_init for use with the accelerated regridding during initialization. All answers are bitwise identical, but there are two new public interfaces and changes to the arguments to two other public interfaces and a run-time parameter was moved between modules resulting in changes to some MOM_parameter_doc files. --- src/ALE/MOM_ALE.F90 | 381 +++++++++++++++++++--------- src/core/MOM.F90 | 58 ++++- src/core/MOM_dynamics_split_RK2.F90 | 27 +- 3 files changed, 335 insertions(+), 131 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index e1c8e6911e..77ee1192a2 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -129,6 +129,7 @@ module MOM_ALE public ALE_remap_scalar public ALE_remap_tracers public ALE_remap_velocities +public ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz public ALE_remap_interface_vals public ALE_remap_vertex_vals public ALE_PLM_edge_values @@ -597,6 +598,15 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_orig ! The original layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: T ! local temporary temperatures [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: S ! local temporary salinities [S ~> ppt] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_old_u ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_old_v ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + ! we have to keep track of the total dzInterface if for some reason ! we're using the old remapping algorithm for u/v real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: dzInterface ! Interface height changes within @@ -607,7 +617,8 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d nz = GV%ke ! initial total interface displacement due to successive regridding - dzIntTotal(:,:,:) = 0. + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = 0. call create_group_pass(pass_T_S_h, T, G%domain) call create_group_pass(pass_T_S_h, S, G%domain) @@ -647,7 +658,8 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d if (allocated(tv_local%SpV_avg)) call calc_derived_thermo(tv_local, h, G, GV, US, halo=1) call regridding_main(CS%remapCS, CS%regridCS, G, GV, US, h_loc, tv_local, h, dzInterface) - dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) + if (CS%remap_uv_using_old_alg) & + dzIntTotal(:,:,:) = dzIntTotal(:,:,:) + dzInterface(:,:,:) ! remap from original grid onto new grid do j = G%jsc-1,G%jec+1 ; do i = G%isc-1,G%iec+1 @@ -663,7 +675,15 @@ subroutine ALE_regrid_accelerated(CS, G, GV, US, h, tv, n_itt, u, v, OBC, Reg, d ! remap all state variables (including those that weren't needed for regridding) call ALE_remap_tracers(CS, G, GV, h_orig, h, Reg) - call ALE_remap_velocities(CS, G, GV, h_orig, h, u, v, OBC, dzIntTotal) + + call ALE_remap_set_h_vel(CS, G, GV, h_orig, h_old_u, h_old_v, OBC) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS, G, GV, h, h_new_u, h_new_v, OBC, h_orig, dzIntTotal) + else + call ALE_remap_set_h_vel(CS, G, GV, h, h_new_u, h_new_v, OBC) + endif + + call ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v) ! save total dzregrid for diags if needed? if (present(dzRegrid)) dzRegrid(:,:,:) = dzIntTotal(:,:,:) @@ -808,36 +828,222 @@ subroutine ALE_remap_tracers(CS, G, GV, h_old, h_new, Reg, debug, dt, PCM_cell) end subroutine ALE_remap_tracers -!> This routine remaps velocity components between the old and the new grids, -!! with thicknesses at velocity points taken to be arithmetic averages of tracer thicknesses. -!! This routine may be called during initialization of the model at time=0, to -!! remap initial conditions to the model grid. It is also called during a -!! time step to update the state. -subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, debug, dt) +!> This routine sets the thicknesses at velocity points used for vertical remapping. +subroutine ALE_remap_set_h_vel(CS, G, GV, h_new, h_u, h_v, OBC, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) + endif ; enddo ; enddo ; enddo + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_new, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel + +!> This routine sets the thicknesses at velocity points used for vertical remapping using a +!! combination of the old grid and interface movements. +subroutine ALE_remap_set_h_vel_via_dz(CS, G, GV, h_new, h_u, h_v, OBC, h_old, dzInterface, debug) type(ALE_CS), intent(in) :: CS !< ALE control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_old !< Thickness of source grid - !! [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness of destination grid - !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old !< Thickness of source grid when generating + !! the destination grid via the old + !! algorithm [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: dzInterface !< Change in interface position + intent(in) :: dzInterface !< Change in interface position !! [H ~> m or kg m-2] - logical, optional, intent(in) :: debug !< If true, show the call tree - real, optional, intent(in) :: dt !< time step for diagnostics [T ~> s] + logical, optional, intent(in) :: debug !< If true, show the call tree + ! Local variables + logical :: show_call_tree + integer :: i, j, k + + show_call_tree = .false. + if (present(debug)) show_call_tree = debug + if (show_call_tree) call callTree_enter("ALE_remap_set_h_vel()") + + ! Build the u- and v-velocity grid thicknesses for remapping using the old grid and interface movement. + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_u(I,j,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i+1,j,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i+1,j,k+1) )) ) + endif ; enddo ; enddo ; enddo + + !$OMP parallel do default(shared) + do k=1,GV%ke ; do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_v(i,J,k) = max( 0., 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) + & + 0.5 * (( dzInterface(i,j,k) + dzInterface(i,j+1,k) ) - & + ( dzInterface(i,j,k+1) + dzInterface(i,j+1,k+1) )) ) + endif ; enddo ; enddo ; enddo + + ! Mask out blocked portions of velocity cells. + if (CS%partial_cell_vel_remap) call ALE_remap_set_h_vel_partial(CS, G, GV, h_old, h_u, h_v) + + ! Take open boundary conditions into account. + if (associated(OBC)) call ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + + if (show_call_tree) call callTree_leave("ALE_remap_set_h_vel()") + +end subroutine ALE_remap_set_h_vel_via_dz + +!> Mask out the thicknesses at velocity points where they are below the minimum depth +!! at adjacent tracer points +subroutine ALE_remap_set_h_vel_partial(CS, G, GV, h_mask, h_u, h_v) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_mask !< Thickness at tracer points + !! used to apply the partial + !! cell masking [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: h_tot ! The vertically summed thicknesses [H ~> m or kg m-2] real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] - real, dimension(GV%ke+1) :: dz ! The change in interface heights interpolated to - ! a velocity point [H ~> m or kg m-2] - logical :: PCM(GV%ke) ! If true, do PCM remapping from a cell. + integer :: i, j, k + + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + h_tot(i,j) = h_tot(i,j) + h_mask(i,j,k) + enddo ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) + call apply_partial_cell_mask(h_u(I,j,:), h_mask_vel) + endif ; enddo ; enddo + + !$OMP parallel do default(shared) private(h_mask_vel) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then + h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) + call apply_partial_cell_mask(h_v(i,J,:), h_mask_vel) + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_partial + +! Reset thicknesses at velocity points on open boundary condition segments +subroutine ALE_remap_set_h_vel_OBC(G, GV, h_new, h_u, h_v, OBC) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_new !< Thickness at tracer points of the + !! grid being interpolated to velocity + !! points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h_u !< Grid thickness at zonal velocity + !! points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: h_v !< Grid thickness at meridional velocity + !! points [H ~> m or kg m-2] + type(ocean_OBC_type), pointer :: OBC !< Open boundary structure + + ! Local variables + integer :: i, j, k, nz + + if (.not.associated(OBC)) return + + nz = GV%ke + + ! Take open boundary conditions into account. + !$OMP parallel do default(shared) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (OBC%segnum_u(I,j) /= 0) then + if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then + do k=1,nz ; h_u(I,j,k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) + do k=1,nz ; h_u(I,j,k) = h_new(i+1,j,k) ; enddo + endif + endif ; enddo ; enddo + + !$OMP parallel do default(shared) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (OBC%segnum_v(i,J) /= 0) then + if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then + do k=1,nz ; h_v(i,J,k) = h_new(i,j,k) ; enddo + else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) + do k=1,nz ; h_v(i,J,k) = h_new(i,j+1,k) ; enddo + endif + endif ; enddo ; enddo + +end subroutine ALE_remap_set_h_vel_OBC + +!> This routine remaps velocity components between the old and the new grids, +!! with thicknesses at velocity points taken to be arithmetic averages of tracer thicknesses. +!! This routine may be called during initialization of the model at time=0, to +!! remap initial conditions to the model grid. It is also called during a +!! time step to update the state. +subroutine ALE_remap_velocities(CS, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, debug) + type(ALE_CS), intent(in) :: CS !< ALE control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + logical, optional, intent(in) :: debug !< If true, show the call tree + + ! Local variables + real :: h_mask_vel ! A depth below which the thicknesses at a velocity point are masked out [H ~> m or kg m-2] real :: u_src(GV%ke) ! A column of u-velocities on the source grid [L T-1 ~> m s-1] real :: u_tgt(GV%ke) ! A column of u-velocities on the target grid [L T-1 ~> m s-1] real :: v_src(GV%ke) ! A column of v-velocities on the source grid [L T-1 ~> m s-1] @@ -852,11 +1058,6 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, if (present(debug)) show_call_tree = debug if (show_call_tree) call callTree_enter("ALE_remap_velocities()") - ! If remap_uv_using_old_alg is .true. and u or v is requested, then we must have dzInterface. Otherwise, - ! u and v can be remapped without dzInterface - if (CS%remap_uv_using_old_alg .and. .not.present(dzInterface) ) call MOM_error(FATAL, & - "ALE_remap_velocities: dzInterface must be present if using old algorithm.") - if (CS%answer_date >= 20190101) then h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff elseif (GV%Boussinesq) then @@ -867,107 +1068,55 @@ subroutine ALE_remap_velocities(CS, G, GV, h_old, h_new, u, v, OBC, dzInterface, nz = GV%ke - if (CS%partial_cell_vel_remap) then - h_tot(:,:) = 0.0 - do k=1,GV%ke ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 - h_tot(i,j) = h_tot(i,j) + h_old(i,j,k) - enddo ; enddo ; enddo - endif + ! --- Remap u profiles from the source vertical grid onto the new target grid. - ! Remap u velocity component - if ( .true. ) then - - !$OMP parallel do default(shared) private(h1,h2,dz,u_src,h_mask_vel,u_tgt) - do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then - ! Build the start and final grids - do k=1,nz - h1(k) = 0.5*(h_old(i,j,k) + h_old(i+1,j,k)) - h2(k) = 0.5*(h_new(i,j,k) + h_new(i+1,j,k)) - enddo - if (CS%remap_uv_using_old_alg) then - dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i+1,j,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) - enddo - endif + !$OMP parallel do default(shared) private(h1,h2,u_src,h_mask_vel,u_tgt) + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (G%mask2dCu(I,j)>0.) then + ! Make a 1-d copy of the start and final grids and the source velocity + do k=1,nz + h1(k) = h_old_u(I,j,k) + h2(k) = h_new_u(I,j,k) + u_src(k) = u(I,j,k) + enddo - if (CS%partial_cell_vel_remap) then - h_mask_vel = min(h_tot(i,j), h_tot(i+1,j)) - call apply_partial_cell_mask(h1, h_mask_vel) - call apply_partial_cell_mask(h2, h_mask_vel) - endif + call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & + h_neglect, h_neglect_edge) - if (associated(OBC)) then ; if (OBC%segnum_u(I,j) /= 0) then - if (OBC%segment(OBC%segnum_u(I,j))%direction == OBC_DIRECTION_E) then - do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo - else ! (OBC%segment(n)%direction == OBC_DIRECTION_W) - do k=1,nz ; h1(k) = h_old(i+1,j,k) ; h2(k) = h_new(i+1,j,k) ; enddo - endif - endif ; endif + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) & + call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) - ! --- Remap u profiles from the source vertical grid onto the new target grid. - do k=1,nz - u_src(k) = u(I,j,k) - enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, u_src, nz, h2, u_tgt, & - h_neglect, h_neglect_edge) + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + u(I,j,k) = u_tgt(k) + enddo !k + endif ; enddo ; enddo - if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then - call mask_near_bottom_vel(u_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) - endif + if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") - do k=1,nz - u(I,j,k) = u_tgt(k) - enddo !k - endif ; enddo ; enddo - endif - if (show_call_tree) call callTree_waypoint("u remapped (ALE_remap_velocities)") + ! --- Remap v profiles from the source vertical grid onto the new target grid. - ! Remap v velocity component - if ( .true. ) then - !$OMP parallel do default(shared) private(h1,h2,v_src,dz,h_mask_vel,v_tgt) - do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then - ! Build the start and final grids - do k=1,nz - h1(k) = 0.5*(h_old(i,j,k) + h_old(i,j+1,k)) - h2(k) = 0.5*(h_new(i,j,k) + h_new(i,j+1,k)) - enddo - if (CS%remap_uv_using_old_alg) then - dz(:) = 0.5 * ( dzInterface(i,j,:) + dzInterface(i,j+1,:) ) - do k = 1, nz - h2(k) = max( 0., h1(k) + ( dz(k) - dz(k+1) ) ) - enddo - endif - if (CS%partial_cell_vel_remap) then - h_mask_vel = min(h_tot(i,j), h_tot(i,j+1)) - call apply_partial_cell_mask(h1, h_mask_vel) - call apply_partial_cell_mask(h2, h_mask_vel) - endif - if (associated(OBC)) then ; if (OBC%segnum_v(i,J) /= 0) then - if (OBC%segment(OBC%segnum_v(i,J))%direction == OBC_DIRECTION_N) then - do k=1,nz ; h1(k) = h_old(i,j,k) ; h2(k) = h_new(i,j,k) ; enddo - else ! (OBC%segment(n)%direction == OBC_DIRECTION_S) - do k=1,nz ; h1(k) = h_old(i,j+1,k) ; h2(k) = h_new(i,j+1,k) ; enddo - endif - endif ; endif + !$OMP parallel do default(shared) private(h1,h2,v_src,h_mask_vel,v_tgt) + do J=G%JscB,G%JecB ; do i=G%isc,G%iec ; if (G%mask2dCv(i,J)>0.) then - ! --- Remap v profiles from the source vertical grid onto the new target grid. - do k=1,nz - v_src(k) = v(i,J,k) - enddo - call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & - h_neglect, h_neglect_edge) + do k=1,nz + h1(k) = h_old_v(i,J,k) + h2(k) = h_new_v(i,J,k) + v_src(k) = v(i,J,k) + enddo - if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then - call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) - endif + call remapping_core_h(CS%vel_remapCS, nz, h1, v_src, nz, h2, v_tgt, & + h_neglect, h_neglect_edge) - do k=1,nz - v(i,J,k) = v_tgt(k) - enddo !k - endif ; enddo ; enddo - endif + if ((CS%BBL_h_vel_mask > 0.0) .and. (CS%h_vel_mask > 0.0)) then + call mask_near_bottom_vel(v_tgt, h2, CS%BBL_h_vel_mask, CS%h_vel_mask, nz) + endif + + ! Copy the column of new velocities back to the 3-d array + do k=1,nz + v(i,J,k) = v_tgt(k) + enddo !k + endif ; enddo ; enddo if (show_call_tree) call callTree_waypoint("v remapped (ALE_remap_velocities)") if (show_call_tree) call callTree_leave("ALE_remap_velocities()") diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ae794e02e2..bcba4d37c7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -54,6 +54,7 @@ module MOM use MOM_ALE, only : ALE_getCoordinate, ALE_getCoordinateUnits, ALE_writeCoordinateFile use MOM_ALE, only : ALE_updateVerticalGridType, ALE_remap_init_conds, pre_ALE_adjustments use MOM_ALE, only : ALE_remap_tracers, ALE_remap_velocities +use MOM_ALE, only : ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz use MOM_ALE, only : ALE_update_regrid_weights, pre_ALE_diagnostics, ALE_register_diags use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS @@ -253,6 +254,8 @@ module MOM logical :: remap_aux_vars !< If true, apply ALE remapping to all of the auxiliary 3-D !! variables that are needed to reproduce across restarts, !! similarly to what is done with the primary state variables. + logical :: remap_uv_using_old_alg !< If true, use the old "remapping via a delta z" method for + !! velocities. If false, remap between two grids described by thicknesses. type(MOM_stoch_eos_CS) :: stoch_eos_CS !< structure containing random pattern for stoch EOS logical :: alternate_first_direction !< If true, alternate whether the x- or y-direction @@ -1499,6 +1502,14 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & real :: h_new(SZI_(G),SZJ_(G),SZK_(GV)) ! Layer thicknesses after regridding [H ~> m or kg m-2] real :: dzRegrid(SZI_(G),SZJ_(G),SZK_(GV)+1) ! The change in grid interface positions due to regridding, ! in the same units as thicknesses [H ~> m or kg m-2] + real :: h_old_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Source grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_old_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Source grid thickness at meridional + ! velocity points [H ~> m or kg m-2] + real :: h_new_u(SZIB_(G),SZJ_(G),SZK_(GV)) ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real :: h_new_v(SZI_(G),SZJB_(G),SZK_(GV)) ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] logical :: PCM_cell(SZI_(G),SZJ_(G),SZK_(GV)) ! If true, PCM remapping should be used in a cell. logical :: use_ice_shelf ! Needed for selecting the right ALE interface. logical :: showCallTree @@ -1620,12 +1631,23 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (showCallTree) call callTree_waypoint("new grid generated") ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, h, h_new, CS%tracer_Reg, showCallTree, dtdia, PCM_cell) - call ALE_remap_velocities(CS%ALE_CSp, G, GV, h, h_new, u, v, CS%OBC, dzRegrid, showCallTree, dtdia) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h, h_old_u, h_old_v, CS%OBC, debug=showCallTree) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, h, dzRegrid, showCallTree) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=showCallTree) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, u, v, showCallTree) + if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%remap_aux_vars) then if (CS%split) & - call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h, h_new, CS%ALE_CSp, CS%OBC, dzRegrid) + call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h_old_u, h_old_v, h_new_u, h_new_v, CS%ALE_CSp) if (associated(CS%OBC)) then call pass_var(h, G%Domain, complete=.false.) @@ -2025,6 +2047,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & real, allocatable, dimension(:,:,:) :: h_new ! Layer thicknesses after regridding [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: dzRegrid ! The change in grid interface positions due to regridding, ! in the same units as thicknesses [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_u ! Source grid thickness at zonal velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_old_v ! Source grid thickness at meridional velocity + ! points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_u ! Destination grid thickness at zonal + ! velocity points [H ~> m or kg m-2] + real, allocatable, dimension(:,:,:) :: h_new_v ! Destination grid thickness at meridional + ! velocity points [H ~> m or kg m-2] logical, allocatable, dimension(:,:,:) :: PCM_cell ! If true, PCM remapping should be used in a cell. type(group_pass_type) :: tmp_pass_uv_T_S_h, pass_uv_T_S_h @@ -2197,6 +2226,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "USE_REGRIDDING", CS%use_ALE_algorithm, & "If True, use the ALE algorithm (regridding/remapping). "//& "If False, use the layered isopycnal algorithm.", default=.false. ) + call get_param(param_file, "MOM", "REMAP_UV_USING_OLD_ALG", CS%remap_uv_using_old_alg, & + "If true, uses the old remapping-via-a-delta-z method for "//& + "remapping u and v. If false, uses the new method that remaps "//& + "between grids described by an old and new thickness.", & + default=.false., do_not_log=.not.CS%use_ALE_algorithm) call get_param(param_file, "MOM", "REMAP_AUXILIARY_VARS", CS%remap_aux_vars, & "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& "variables that are needed to reproduce across restarts, similarly to "//& @@ -2996,6 +3030,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & allocate(h_new(isd:ied, jsd:jed, nz), source=0.0) allocate(dzRegrid(isd:ied, jsd:jed, nz+1), source=0.0) allocate(PCM_cell(isd:ied, jsd:jed, nz), source=.false.) + allocate(h_old_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_new_u(IsdB:IedB, jsd:jed, nz), source=0.0) + allocate(h_old_v(isd:ied, JsdB:JedB, nz), source=0.0) + allocate(h_new_v(isd:ied, JsdB:JedB, nz), source=0.0) if (use_ice_shelf) then call ALE_regrid(G, GV, US, CS%h, h_new, dzRegrid, CS%tv, CS%ALE_CSp, CS%frac_shelf_h, PCM_cell) else @@ -3005,7 +3043,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (callTree_showQuery()) call callTree_waypoint("new grid generated") ! Remap all variables from the old grid h onto the new grid h_new call ALE_remap_tracers(CS%ALE_CSp, G, GV, CS%h, h_new, CS%tracer_Reg, CS%debug, PCM_cell=PCM_cell) - call ALE_remap_velocities(CS%ALE_CSp, G, GV, CS%h, h_new, CS%u, CS%v, CS%OBC, dzRegrid, debug=CS%debug) + + ! Determine the old and new grid thicknesses at velocity points. + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, CS%h, h_old_u, h_old_v, CS%OBC, debug=CS%debug) + if (CS%remap_uv_using_old_alg) then + call ALE_remap_set_h_vel_via_dz(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, CS%h, dzRegrid, CS%debug) + else + call ALE_remap_set_h_vel(CS%ALE_CSp, G, GV, h_new, h_new_u, h_new_v, CS%OBC, debug=CS%debug) + endif + + ! Remap the velocity components. + call ALE_remap_velocities(CS%ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u, CS%v, CS%debug) + if (allocated(CS%tv%SpV_avg)) CS%tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. ! Replace the old grid with new one. All remapping must be done at this point. @@ -3013,7 +3062,8 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 CS%h(i,j,k) = h_new(i,j,k) enddo ; enddo ; enddo - deallocate(h_new, dzRegrid, PCM_cell) + + deallocate(h_new, dzRegrid, PCM_cell, h_old_u, h_new_u, h_old_v, h_new_v) call cpu_clock_begin(id_clock_pass_init) call create_group_pass(tmp_pass_uv_T_S_h, CS%u, CS%v, G%Domain) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 36ba8b60f8..debc63cb46 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -1261,29 +1261,34 @@ end subroutine register_restarts_dyn_split_RK2 !> This subroutine does remapping for the auxiliary restart variables that are used !! with the split RK2 time stepping scheme. -subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old, h_new, ALE_CSp, OBC, dzRegrid) +subroutine remap_dyn_split_RK2_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(MOM_dyn_split_RK2_CS), pointer :: CS !< module control structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_old !< Thickness of source grid [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_new !< Thickness of destination grid [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping - type(ocean_OBC_type), pointer :: OBC !< OBC control structure to use when remapping - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1), & - optional, intent(in) :: dzRegrid !< Change in interface position [H ~> m or kg m-2] if (.not.CS%remap_aux) return if (CS%store_CAu) then - call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%u_av, CS%v_av, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) - call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%CAu_pred, CS%CAv_pred, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) endif - call ALE_remap_velocities(ALE_CSp, G, GV, h_old, h_new, CS%diffu, CS%diffv, OBC, dzRegrid) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) end subroutine remap_dyn_split_RK2_aux_vars From cce4b3da5e26b3ee2cae6e683988410340abad1b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 8 Nov 2023 18:04:32 -0500 Subject: [PATCH 480/629] Fix a bug that left OBC%debug uninitialized This commit fixes a bug to ensure that OBC%debug is always being set when OBCs are in use. After a recent commit, the value of OBC%debug was not being set and was being left in an indeterminate whenever DEBUG_OBC=False or DEBUG=False and DEBUG_OBC was unspecified. This would lead to the model writing out a number of checksums in some cases with open boundary conditions enabled, depending on what value was inherited by the uninitialized OBC%debug. Although this does not change any answers, it will avoid a problem that will write out a large volume of undesired output and greatly slow down configurations with open boundary conditions. --- src/core/MOM_open_boundary.F90 | 21 +++++++++------------ 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 5cf7c92fe9..7bfb6479b2 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -426,7 +426,7 @@ subroutine open_boundary_config(G, US, param_file, OBC) ! Local variables integer :: l ! For looping over segments - logical :: debug_OBC, mask_outside, reentrant_x, reentrant_y + logical :: debug, debug_OBC, mask_outside, reentrant_x, reentrant_y character(len=15) :: segment_param_str ! The run-time parameter name for each segment character(len=1024) :: segment_str ! The contents (rhs) for parameter "segment_param_str" character(len=200) :: config1 ! String for OBC_USER_CONFIG @@ -528,25 +528,22 @@ subroutine open_boundary_config(G, US, param_file, OBC) OBC%add_tide_constituents = .false. endif - call get_param(param_file, mdl, "DEBUG", debug_OBC, default=.false.) - call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug_OBC, & - do_not_log=.not.debug_OBC) - if (debug_OBC) then - call log_param(param_file, mdl, "DEBUG_OBC", debug_OBC, & + call get_param(param_file, mdl, "DEBUG", debug, default=.false.) + ! This extra get_param call is to enable logging if either DEBUG or DEBUG_OBC are true. + call get_param(param_file, mdl, "DEBUG_OBC", debug_OBC, default=debug) + call get_param(param_file, mdl, "DEBUG_OBC", OBC%debug, & "If true, do additional calls to help debug the performance "//& - "of the open boundary condition code.", default=.false., & - debuggingParam=.true.) - OBC%debug = debug_OBC - endif + "of the open boundary condition code.", & + default=debug, do_not_log=.not.(debug_OBC.or.debug), debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_THICK", OBC%silly_h, & "A silly value of thicknesses used outside of open boundary "//& "conditions for debugging.", units="m", default=0.0, scale=US%m_to_Z, & - do_not_log=.not.debug_OBC, debuggingParam=.true.) + do_not_log=.not.OBC%debug, debuggingParam=.true.) call get_param(param_file, mdl, "OBC_SILLY_VEL", OBC%silly_u, & "A silly value of velocities used outside of open boundary "//& "conditions for debugging.", units="m/s", default=0.0, scale=US%m_s_to_L_T, & - do_not_log=.not.debug_OBC, debuggingParam=.true.) + do_not_log=.not.OBC%debug, debuggingParam=.true.) reentrant_x = .false. call get_param(param_file, mdl, "REENTRANT_X", reentrant_x, default=.true.) reentrant_y = .false. From f4c95ec4b81e2958c151be101d2b15b0de28f910 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 14 Nov 2023 20:38:01 -0500 Subject: [PATCH 481/629] Revert post_data fix to CFC concentration The most recent NCAR -> GFDL merge created an error (courtesy of myself) which left the CFC concentration units in the post_data call, even though these are now handled at registration. This patch restores this expression and removes the unit conversion from post_data. --- src/tracer/MOM_CFC_cap.F90 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 38777346a1..16506b41c3 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -404,8 +404,7 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! If needed, write out any desired diagnostics from tracer sources & sinks here. do m=1,NTR if (CS%CFC_data(m)%id_cmor > 0) & - call post_data(CS%CFC_data(m)%id_cmor, & - (GV%Rho0*US%R_to_kg_m3)*CS%CFC_data(m)%conc, CS%diag) + call post_data(CS%CFC_data(m)%id_cmor, CS%CFC_data(m)%conc, CS%diag) if (CS%CFC_data(m)%id_sfc_flux > 0) & call post_data(CS%CFC_data(m)%id_sfc_flux, CS%CFC_data(m)%sfc_flux, CS%diag) From 7ef6a57252ba9132496b4e67aafa09d47fe7eafd Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 21 Nov 2023 12:05:19 -0900 Subject: [PATCH 482/629] Fix the saltFluxAdded diagnoistic, broken in #401 --- src/core/MOM_forcing_type.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index dcbf440292..b8b3174b4a 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -361,6 +361,7 @@ module MOM_forcing_type integer :: id_saltflux = -1 integer :: id_saltFluxIn = -1 integer :: id_saltFluxAdded = -1 + integer :: id_saltFluxBehind = -1 integer :: id_total_saltflux = -1 integer :: id_total_saltFluxIn = -1 @@ -2099,7 +2100,7 @@ subroutine register_forcing_type_diags(Time, diag, US, use_temperature, handles, diag%axesT1,Time,'Salt flux into ocean at surface due to restoring or flux adjustment', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) - handles%id_saltFluxAdded = register_diag_field('ocean_model', 'salt_left_behind', & + handles%id_saltFluxBehind = register_diag_field('ocean_model', 'salt_left_behind', & diag%axesT1,Time,'Salt left in ocean at surface due to ice formation', & units='kg m-2 s-1', conversion=US%RZ_T_to_kg_m2s) @@ -3130,6 +3131,9 @@ subroutine forcing_diagnostics(fluxes_in, sfc_state, G_in, US, time_end, diag, h call post_data(handles%id_total_saltFluxIn, total_transport, diag) endif + if (handles%id_saltFluxBehind > 0 .and. associated(fluxes%salt_left_behind)) & + call post_data(handles%id_saltFluxBehind, fluxes%salt_left_behind, diag) + if (handles%id_saltFluxGlobalAdj > 0) & call post_data(handles%id_saltFluxGlobalAdj, fluxes%saltFluxGlobalAdj, diag) if (handles%id_vPrecGlobalAdj > 0) & From d8579d2922a5807955ba40fccb0550707e772823 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Mon, 2 Oct 2023 13:32:46 -0400 Subject: [PATCH 483/629] Use a class to deliver elemental procedures for EOS - Added a base class in MOM_EOS_base_type.F90 - All EOS modules now extend this base class - This reduces replicated code between the EOS modules - All existing APIs in MOM_EOS now avoid branching for the type of EOS and ultimately pass through to a low-level elemental function implementation of the actual EOS - Added a new elemental function exposed by MOM_EOS (currently not used in the main model) - There is a speed up over the previous form of EOS due to the reduced branching - For some functions, a local implementation of the base class member is needed to gain performance. I deliberately did not implement this optimization for UNESCO or Jackett06 so that the generic implementation of the base class is utilized and we have code coverage. --- src/equation_of_state/MOM_EOS.F90 | 594 ++++------- src/equation_of_state/MOM_EOS_Jackett06.F90 | 736 +++++++------- src/equation_of_state/MOM_EOS_Roquet_SpV.F90 | 925 +++++++++--------- src/equation_of_state/MOM_EOS_Roquet_rho.F90 | 788 ++++++++------- src/equation_of_state/MOM_EOS_TEOS10.F90 | 504 ++++------ src/equation_of_state/MOM_EOS_UNESCO.F90 | 814 +++++++-------- src/equation_of_state/MOM_EOS_Wright.F90 | 718 +++++--------- src/equation_of_state/MOM_EOS_Wright_full.F90 | 632 ++++++------ src/equation_of_state/MOM_EOS_Wright_red.F90 | 610 +++++------- src/equation_of_state/MOM_EOS_base_type.F90 | 464 +++++++++ src/equation_of_state/MOM_EOS_linear.F90 | 507 +++++----- src/tracer/MOM_neutral_diffusion.F90 | 2 +- 12 files changed, 3446 insertions(+), 3848 deletions(-) create mode 100644 src/equation_of_state/MOM_EOS_base_type.F90 diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 2087cd86e5..a68e3b2229 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -3,50 +3,20 @@ module MOM_EOS ! This file is part of MOM6. See LICENSE.md for the license. -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, 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, 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, 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, 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 -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_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 -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_base_type, only : EOS_base +use MOM_EOS_linear, only : linear_EOS, avg_spec_vol_linear +use MOM_EOS_linear, only : int_density_dz_linear, int_spec_vol_dp_linear +use MOM_EOS_Wright, only : buggy_Wright_EOS, avg_spec_vol_buggy_Wright +use MOM_EOS_Wright, only : int_density_dz_wright, int_spec_vol_dp_wright +use MOM_EOS_Wright_full, only : Wright_full_EOS, avg_spec_vol_Wright_full +use MOM_EOS_Wright_full, only : int_density_dz_wright_full, int_spec_vol_dp_wright_full +use MOM_EOS_Wright_red, only : Wright_red_EOS, avg_spec_vol_Wright_red +use MOM_EOS_Wright_red, only : int_density_dz_wright_red, int_spec_vol_dp_wright_red +use MOM_EOS_Jackett06, only : Jackett06_EOS +use MOM_EOS_UNESCO, only : UNESCO_EOS +use MOM_EOS_Roquet_rho, only : Roquet_rho_EOS +use MOM_EOS_Roquet_SpV, only : Roquet_SpV_EOS +use MOM_EOS_TEOS10, only : TEOS10_EOS 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 @@ -54,7 +24,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_io, only : stdout, stderr use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type @@ -71,6 +41,7 @@ module MOM_EOS public analytic_int_specific_vol_dp public average_specific_vol public calculate_compress +public calculate_density_elem public calculate_density public calculate_density_derivs public calculate_density_second_derivs @@ -78,7 +49,6 @@ module MOM_EOS public calculate_specific_vol_derivs public calculate_TFreeze public convert_temp_salt_for_TEOS10 -public extract_member_EOS public cons_temp_to_pot_temp public abs_saln_to_prac_saln public gsw_sp_from_sr @@ -169,7 +139,9 @@ module MOM_EOS real :: ppt_to_S = 1. !< A constant that translates parts per thousand to the units of salinity [S ppt-1 ~> 1] real :: S_to_ppt = 1. !< A constant that translates the units of salinity to parts per thousand [ppt S-1 ~> 1] -! logical :: test_EOS = .true. ! If true, test the equation of state + !> The instance of the actual equation of state + class(EOS_base), allocatable :: type + end type EOS_type ! The named integers that might be stored in eqn_of_state_type%form_of_EOS. @@ -213,6 +185,42 @@ module MOM_EOS contains +!> Density of sea water (in-situ if pressure is local) [R ~> kg m-3] +!! +!! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and +!! density can be rescaled with the values stored in EOS. If the scale argument is present the density +!! scaling uses the product of the two scaling factors. +real elemental function calculate_density_elem(EOS, T, S, pressure, rho_ref, scale) + type(EOS_type), intent(in) :: EOS !< Equation of state structure + real, intent(in) :: T !< Potential temperature referenced to the surface [C ~> degC] + real, intent(in) :: S !< Salinity [S ~> ppt] + real, intent(in) :: pressure !< Pressure [R L2 T-2 ~> Pa] + real, optional, intent(in) :: rho_ref !< A reference density [R ~> kg m-3] + real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in + !! combination with scaling stored in EOS [various] + real :: Ta ! An array of temperatures [degC] + real :: Sa ! An array of salinities [ppt] + real :: pres ! An mks version of the pressure to use [Pa] + real :: rho_mks ! An mks version of the density to be returned [kg m-3] + real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] + + pres = EOS%RL2_T2_to_Pa * pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + + if (present(rho_ref)) then + rho_mks = EOS%type%density_anomaly_elem(Ta, Sa, pres, EOS%R_to_kg_m3*rho_ref) + else + rho_mks = EOS%type%density_elem(Ta, Sa, pres) + endif + + ! Rescale the output density to the desired units. + rho_scale = EOS%kg_m3_to_R + if (present(scale)) rho_scale = rho_scale * scale + calculate_density_elem = rho_scale * rho_mks + +end function calculate_density_elem + !> Calls the appropriate subroutine to calculate density of sea water for scalar inputs. !! If rho_ref is present, the anomaly with respect to rho_ref is returned. The pressure and !! density can be rescaled with the values stored in EOS. If the scale argument is present the density @@ -227,24 +235,26 @@ subroutine calculate_density_scalar(T, S, pressure, rho, EOS, rho_ref, scale) real, optional, intent(in) :: scale !< A multiplicative factor by which to scale output density in !! combination with scaling stored in EOS [various] - real :: Ta(1) ! An array of temperatures [degC] - real :: Sa(1) ! An array of salinities [ppt] - real :: pres(1) ! An mks version of the pressure to use [Pa] - real :: rho_mks(1) ! An mks version of the density to be returned [kg m-3] + real :: Ta ! An array of temperatures [degC] + real :: Sa ! An array of salinities [ppt] + real :: pres ! An mks version of the pressure to use [Pa] + real :: rho_mks ! An mks version of the density to be returned [kg m-3] real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] - pres(1) = EOS%RL2_T2_to_Pa * pressure - Ta(1) = EOS%C_to_degC * T ; Sa(1) = EOS%S_to_ppt * S + pres = EOS%RL2_T2_to_Pa * pressure + Ta = EOS%C_to_degC * T + Sa = EOS%S_to_ppt * S + if (present(rho_ref)) then - call calculate_density_array(Ta, Sa, pres, rho_mks, 1, 1, EOS, EOS%R_to_kg_m3*rho_ref) + rho_mks = EOS%type%density_anomaly_elem(Ta, Sa, pres, EOS%R_to_kg_m3*rho_ref) else - call calculate_density_array(Ta, Sa, pres, rho_mks, 1, 1, EOS) + rho_mks = EOS%type%density_elem(Ta, Sa, pres) endif ! Rescale the output density to the desired units. rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale - rho = rho_scale * rho_mks(1) + rho = rho_scale * rho_mks end subroutine calculate_density_scalar @@ -283,52 +293,6 @@ subroutine calculate_stanley_density_scalar(T, S, pressure, Tvar, TScov, Svar, r end subroutine calculate_stanley_density_scalar -!> Calls the appropriate subroutine to calculate the density of sea water for 1-D array inputs. -!! If rho_ref is present, the anomaly with respect to rho_ref is returned. -subroutine calculate_density_array(T, S, pressure, rho, start, npts, EOS, rho_ref, 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(inout) :: rho !< Density (in-situ if pressure is local) [kg m-3] or other - !! units if rescaled via a scale argument - 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] - 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) - case (EOS_UNESCO) - 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_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) - 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) - 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 - - if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 - rho(j) = scale * rho(j) - enddo ; endif ; endif - -end subroutine calculate_density_array - !> Calls the appropriate subroutine to calculate 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. @@ -358,7 +322,7 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) if ((EOS%RL2_T2_to_Pa == 1.0) .and. (EOS%R_to_kg_m3 == 1.0) .and. & (EOS%C_to_degC == 1.0) .and. (EOS%S_to_ppt == 1.0)) then - call calculate_density_array(T, S, pressure, rho, is, npts, EOS, rho_ref=rho_ref) + call EOS%type%calculate_density_array(T, S, pressure, rho, is, npts, rho_ref=rho_ref) else ! This is the same as above, but with some extra work to rescale variables. do i=is,ie pres(i) = EOS%RL2_T2_to_Pa * pressure(i) @@ -366,9 +330,9 @@ subroutine calculate_density_1d(T, S, pressure, rho, EOS, dom, rho_ref, scale) Sa(i) = EOS%S_to_ppt * S(i) enddo if (present(rho_ref)) then - call calculate_density_array(Ta, Sa, pres, rho, is, npts, EOS, rho_ref=EOS%R_to_kg_m3*rho_ref) + call EOS%type%calculate_density_array(Ta, Sa, pres, rho, is, npts, rho_ref=EOS%R_to_kg_m3*rho_ref) else - call calculate_density_array(Ta, Sa, pres, rho, is, npts, EOS) + call EOS%type%calculate_density_array(Ta, Sa, pres, rho, is, npts) endif endif @@ -446,34 +410,10 @@ subroutine calculate_spec_vol_array(T, S, pressure, specvol, start, npts, EOS, s real, dimension(size(specvol)) :: rho ! Density [kg m-3] integer :: j - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - 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) - 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_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) - 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 - specvol(:) = 1.0 / rho(:) - 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 + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_spec_vol_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_spec_vol_array(T, S, pressure, specvol, start, npts, spv_ref) if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 specvol(j) = scale * specvol(j) @@ -751,29 +691,10 @@ subroutine calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, star ! Local variables integer :: j - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - call calculate_density_derivs_linear(T, S, pressure, drho_dT, drho_dS, EOS%Rho_T0_S0, & - EOS%dRho_dT, EOS%dRho_dS, start, npts) - case (EOS_UNESCO) - 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_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) - 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) - 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 + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_derivs_array: EOS%form_of_EOS is not valid.") + + call EOS%type%calculate_density_derivs_array(T, S, pressure, drho_dT, drho_dS, start, npts) if (present(scale)) then ; if (scale /= 1.0) then ; do j=start,start+npts-1 drho_dT(j) = scale * drho_dT(j) @@ -864,25 +785,7 @@ subroutine calculate_density_derivs_scalar(T, S, pressure, drho_dT, drho_dS, EOS 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(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(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_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) - 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) - drho_dT = dR_dT(1); drho_dS = dR_dS(1) - end select + call EOS%type%calculate_density_derivs_scalar(Ta(1), Sa(1), pres(1), drho_dT, drho_dS) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale @@ -923,6 +826,9 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d real :: rho_scale ! A factor to convert density from kg m-3 to the desired units [R m3 kg-1 ~> 1] integer :: i, is, ie, npts + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") + if (present(dom)) then is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is else @@ -930,84 +836,16 @@ subroutine calculate_density_second_derivs_1d(T, S, pressure, drho_dS_dS, drho_d endif if ((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 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) - 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) - 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) - 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_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, & - 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) - 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 + call EOS%type%calculate_density_second_derivs_array(T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) else 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 - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - 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) - 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) - 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) - 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_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, & - 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) - 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 + call EOS%type%calculate_density_second_derivs_array(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP, is, npts) endif rho_scale = EOS%kg_m3_to_R @@ -1064,46 +902,15 @@ subroutine calculate_density_second_derivs_scalar(T, S, pressure, drho_dS_dS, dr real :: Ta ! Temperature converted to [degC] real :: Sa ! Salinity converted to [ppt] + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_density_second_derivs: EOS%form_of_EOS is not valid.") + pres = EOS%RL2_T2_to_Pa*pressure Ta = EOS%C_to_degC * T Sa = EOS%S_to_ppt * S - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - 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) - 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) - 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) - 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_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, & - 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) - 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 + call EOS%type%calculate_density_second_derivs_scalar(Ta, Sa, pres, drho_dS_dS, drho_dS_dT, & + drho_dT_dT, drho_dS_dP, drho_dT_dP) rho_scale = EOS%kg_m3_to_R if (present(scale)) rho_scale = rho_scale * scale @@ -1147,40 +954,10 @@ subroutine calculate_spec_vol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start integer, intent(in) :: npts !< The number of values to calculate type(EOS_type), intent(in) :: EOS !< Equation of state structure - ! Local variables - real, dimension(size(T)) :: rho ! In situ density [kg m-3] - real, dimension(size(T)) :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] - real, dimension(size(T)) :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] - integer :: j + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_spec_vol_derivs_array: EOS%form_of_EOS is not valid.") - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - 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_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) - call calculate_specvol_derivs_wright_full(T, S, pressure, dSV_dT, dSV_dS, start, npts) - 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) - 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) - 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 + call EOS%type%calculate_specvol_derivs_array(T, S, pressure, dSV_dT, dSV_dS, start, npts) end subroutine calculate_spec_vol_derivs_array @@ -1258,6 +1035,9 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) real, dimension(size(T)) :: Sa ! Salinity converted to [ppt] integer :: i, is, ie, npts + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_compress_1d: EOS%form_of_EOS is not valid.") + if (present(dom)) then is = dom(1) ; ie = dom(2) ; npts = 1 + ie - is else @@ -1270,29 +1050,7 @@ subroutine calculate_compress_1d(T, S, pressure, rho, drho_dp, EOS, dom) Sa(i) = EOS%S_to_ppt * S(i) enddo - select case (EOS%form_of_EOS) - case (EOS_LINEAR) - 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) - 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_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) - 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) - 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 + call EOS%type%calculate_compress_array(Ta, Sa, pres, rho, drho_dp, is, npts) if (EOS%kg_m3_to_R /= 1.0) then ; do i=is,ie rho(i) = EOS%kg_m3_to_R * rho(i) @@ -1383,7 +1141,7 @@ subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) 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) + call avg_spec_vol_buggy_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) @@ -1403,7 +1161,7 @@ subroutine average_specific_vol(T, S, p_t, dp, SpV_avg, EOS, dom, scale) 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) + call avg_spec_vol_buggy_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) @@ -1434,28 +1192,10 @@ subroutine EoS_fit_range(EOS, T_min, T_max, S_min, S_max, p_min, p_max) 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_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) - 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) - 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 + if (.not. allocated(EOS%type)) call MOM_error(FATAL, & + "calculate_compress: EOS%form_of_EOS is not valid.") + + call EOS%type%EoS_fit_range(T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range @@ -1738,27 +1478,27 @@ subroutine EOS_init(param_file, EOS, US) '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 + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR) case (EOS_UNESCO_STRING) - EOS%form_of_EOS = EOS_UNESCO + call EOS_manual_init(EOS, form_of_EOS=EOS_UNESCO) case (EOS_JACKETT_STRING) - EOS%form_of_EOS = EOS_UNESCO + call EOS_manual_init(EOS, form_of_EOS=EOS_UNESCO) case (EOS_WRIGHT_STRING) - EOS%form_of_EOS = EOS_WRIGHT + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT) case (EOS_WRIGHT_RED_STRING) - EOS%form_of_EOS = EOS_WRIGHT_REDUCED + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT_REDUCED) case (EOS_WRIGHT_FULL_STRING) - EOS%form_of_EOS = EOS_WRIGHT_FULL + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT_FULL) case (EOS_TEOS10_STRING) - EOS%form_of_EOS = EOS_TEOS10 + call EOS_manual_init(EOS, form_of_EOS=EOS_TEOS10) case (EOS_NEMO_STRING) - EOS%form_of_EOS = EOS_ROQUET_RHO + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_RHO) case (EOS_ROQUET_RHO_STRING) - EOS%form_of_EOS = EOS_ROQUET_RHO + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_RHO) case (EOS_ROQUET_SPV_STRING) - EOS%form_of_EOS = EOS_ROQUET_SPV + call EOS_manual_init(EOS, form_of_EOS=EOS_ROQUET_SPV) case (EOS_JACKETT06_STRING) - EOS%form_of_EOS = EOS_JACKETT06 + call EOS_manual_init(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.") @@ -1779,6 +1519,7 @@ subroutine EOS_init(param_file, EOS, US) "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& "this is the partial derivative of density with "//& "salinity.", units="kg m-3 PSU-1", default=0.8) + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=EOS%Rho_T0_S0, dRho_dT=EOS%dRho_dT, dRho_dS=EOS%dRho_dS) 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, & @@ -1857,7 +1598,8 @@ end subroutine EOS_init !> Manually initialized an EOS type (intended for unit testing of routines which need a specific EOS) subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Compressible, & - Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp) + Rho_T0_S0, drho_dT, dRho_dS, TFr_S0_P0, dTFr_dS, dTFr_dp, & + use_Wright_2nd_deriv_bug) type(EOS_type), intent(inout) :: EOS !< Equation of state structure integer, optional, intent(in) :: form_of_EOS !< A coded integer indicating the equation of state to use. integer, optional, intent(in) :: form_of_TFreeze !< A coded integer indicating the expression for @@ -1875,8 +1617,36 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co !! in [degC ppt-1] real , optional, intent(in) :: dTFr_dp !< The derivative of freezing point with pressure !! in [degC Pa-1] + logical, optional, intent(in) :: use_Wright_2nd_deriv_bug !< Allow the Wright 2nd deriv bug - if (present(form_of_EOS )) EOS%form_of_EOS = form_of_EOS + if (present(form_of_EOS)) then + EOS%form_of_EOS = form_of_EOS + if (allocated(EOS%type)) deallocate(EOS%type) ! Needed during testing which re-initializes + select case (EOS%form_of_EOS) + case (EOS_LINEAR) + allocate(linear_EOS :: EOS%type) + case (EOS_UNESCO) + allocate(UNESCO_EOS :: EOS%type) + case (EOS_WRIGHT) + allocate(buggy_Wright_EOS :: EOS%type) + case (EOS_WRIGHT_FULL) + allocate(Wright_full_EOS :: EOS%type) + case (EOS_WRIGHT_REDUCED) + allocate(Wright_red_EOS :: EOS%type) + case (EOS_JACKETT06) + allocate(Jackett06_EOS :: EOS%type) + case (EOS_TEOS10) + allocate(TEOS10_EOS :: EOS%type) + case (EOS_ROQUET_RHO) + allocate(Roquet_rho_EOS :: EOS%type) + case (EOS_ROQUET_SPV) + allocate(Roquet_SpV_EOS :: EOS%type) + end select + select type (t => EOS%type) + type is (linear_EOS) + call t%set_params_linear(Rho_T0_S0, dRho_dT, dRho_dS) + end select + endif if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze if (present(EOS_quadrature )) EOS%EOS_quadrature = EOS_quadrature if (present(Compressible )) EOS%Compressible = Compressible @@ -1886,6 +1656,7 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co if (present(TFr_S0_P0 )) EOS%TFr_S0_P0 = TFr_S0_P0 if (present(dTFr_dS )) EOS%dTFr_dS = dTFr_dS if (present(dTFr_dp )) EOS%dTFr_dp = dTFr_dp + if (present(use_Wright_2nd_deriv_bug)) EOS%use_Wright_2nd_deriv_bug = use_Wright_2nd_deriv_bug end subroutine EOS_manual_init @@ -1902,11 +1673,8 @@ subroutine EOS_use_linear(Rho_T0_S0, dRho_dT, dRho_dS, EOS, use_quadrature) !! code for the integrals of density. type(EOS_type), intent(inout) :: EOS !< Equation of state structure - EOS%form_of_EOS = EOS_LINEAR + call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=Rho_T0_S0, dRho_dT=dRho_dT, dRho_dS=dRho_dS) EOS%Compressible = .false. - EOS%Rho_T0_S0 = Rho_T0_S0 - EOS%dRho_dT = dRho_dT - EOS%dRho_dS = dRho_dS EOS%EOS_quadrature = .false. if (present(use_quadrature)) EOS%EOS_quadrature = use_quadrature @@ -2125,40 +1893,6 @@ logical function EOS_quadrature(EOS) 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 - 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. - logical, optional, intent(out) :: EOS_quadrature !< If true, always use the generic (quadrature) - !! 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 - !! in [kg m-3 degC-1] - real , optional, intent(out) :: dRho_dS !< Partial derivative of density with salinity - !! in [kg m-3 ppt-1] - real , optional, intent(out) :: TFr_S0_P0 !< The freezing potential temperature at S=0, P=0 [degC] - real , optional, intent(out) :: dTFr_dS !< The derivative of freezing point with salinity - !! [degC PSU-1] - real , optional, intent(out) :: dTFr_dp !< The derivative of freezing point with pressure - !! [degC Pa-1] - - if (present(form_of_EOS )) form_of_EOS = EOS%form_of_EOS - if (present(form_of_TFreeze)) form_of_TFreeze = EOS%form_of_TFreeze - if (present(EOS_quadrature )) EOS_quadrature = EOS%EOS_quadrature - if (present(Compressible )) Compressible = EOS%Compressible - if (present(Rho_T0_S0 )) Rho_T0_S0 = EOS%Rho_T0_S0 - if (present(drho_dT )) drho_dT = EOS%drho_dT - if (present(dRho_dS )) dRho_dS = EOS%dRho_dS - if (present(TFr_S0_P0 )) TFr_S0_P0 = EOS%TFr_S0_P0 - if (present(dTFr_dS )) dTFr_dS = EOS%dTFr_dS - if (present(dTFr_dp )) dTFr_dp = EOS%dTFr_dp - -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. @@ -2202,11 +1936,13 @@ logical function EOS_unit_tests(verbose) ! 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) + call EOS_manual_init(EOS_tmp, form_of_EOS=EOS_WRIGHT, use_Wright_2nd_deriv_bug=.true.) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "WRIGHT", & 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 + ! These last test is a known failure and since MPI is not necessarily initializaed when running these tests + ! we need to avoid flagging the fails. + !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_ROQUET_RHO) fail = test_EOS_consistency(25.0, 35.0, 1.0e7, EOS_tmp, verbose, "ROQUET_RHO", & @@ -2416,9 +2152,9 @@ subroutine write_check_msg(var_name, val, val_chk, val_tol, test_OK) 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)) + write(stdout,*) 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)) + write(stderr,*) trim(var_name)//" disagrees with its check value :"//trim(mesg) endif end subroutine write_check_msg @@ -2616,9 +2352,9 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & 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 if (test_OK) then - call MOM_mesg("The values of "//trim(EOS_name)//" rho and 1/spv agree. "//trim(mesg)) + write(stdout,*) "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)) + write(stderr,*) "The values of "//trim(EOS_name)//" rho and 1/spv disagree. "//trim(mesg) endif endif endif @@ -2630,8 +2366,8 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & 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)) + write(stderr,*) "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 @@ -2641,8 +2377,8 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & 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)) + write(stderr,*) "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 @@ -2689,9 +2425,9 @@ logical function test_EOS_consistency(T_test, S_test, p_test, EOS, verbose, & 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)) + write(stderr,*) "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)) + write(stdout,*) "The values of "//trim(EOS_name)//" SpV_avg agree: "//trim(mesg) endif endif OK = OK .and. test_OK @@ -2776,9 +2512,9 @@ logical function check_FD(val, val_fd, tol, verbose, field_name, order) ! 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)) + write(stderr,*) "The values of "//trim(field_name)//" disagree. "//trim(mesg) elseif (verbose) then - call MOM_mesg("The values of "//trim(field_name)//" agree: "//trim(mesg)) + write(stdout,*) "The values of "//trim(field_name)//" agree: "//trim(mesg) endif end function check_FD diff --git a/src/equation_of_state/MOM_EOS_Jackett06.F90 b/src/equation_of_state/MOM_EOS_Jackett06.F90 index 119edee4f0..1ef7456e96 100644 --- a/src/equation_of_state/MOM_EOS_Jackett06.F90 +++ b/src/equation_of_state/MOM_EOS_Jackett06.F90 @@ -3,40 +3,11 @@ module MOM_EOS_Jackett06 ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_hor_index, only : hor_index_type +use MOM_EOS_base_type, only : EOS_base 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, 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 -!! 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 +public Jackett06_EOS !>@{ 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]. @@ -73,21 +44,76 @@ module MOM_EOS_Jackett06 RD620 = 1.4716275472242334d-09 ! Density denominator S^1.5 T^2 coefficient [degC-2 PSU-1.5] !>@} +!> The EOS_base implementation of the Jackett et al, 2006, equation of state +type, extends (EOS_base) :: Jackett06_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Jackett06 + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Jackett06 + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Jackett06 + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Jackett06 + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Jackett06 + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Jackett06 + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Jackett06 + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Jackett06 + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Jackett06 + +end type Jackett06_EOS + contains -!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!> In situ density of sea water using Jackett et al., 2006 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Jackett06(this, T, S, pressure) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + + ! 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] + + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + I_den = 1.0 / den + + density_elem_Jackett06 = (RN000 + num_STP)*I_den + +end function density_elem_Jackett06 + +!> In situ density anomaly of sea water using Jackett et al., 2006 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Jackett06(this, T, S, pressure, rho_ref) + class(Jackett06_EOS), intent(in) :: this !< This EOS + 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(in) :: rho_ref !< A reference density [kg m-3]. ! Local variables real :: num_STP ! State dependent part of the numerator of the rational expresion @@ -99,43 +125,32 @@ subroutine calculate_density_array_Jackett(T, S, pres, rho, start, npts, rho_ref 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) + S1_2 = sqrt(max(0.0,s)) + T2 = T*T - 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 + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + I_den = 1.0 / den - rho0 = RN000 - if (present(rho_ref)) rho0 = RN000 - rho_ref*den + rho0 = RN000 - rho_ref*den - rho(j) = (rho0 + num_STP)*I_den - enddo + density_anomaly_elem_Jackett06 = (rho0 + num_STP)*I_den -end subroutine calculate_density_array_Jackett +end function density_anomaly_elem_Jackett06 -!> Computes the Jackett et al. in situ specific volume of sea water for 1-d array inputs and outputs. +!> In situ specific volume of sea water using Jackett et al., 2006 [m3 kg-1] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Jackett06(this, T, S, pressure) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. ! Local variables real :: num_STP ! State dependent part of the numerator of the rational expresion @@ -145,99 +160,72 @@ subroutine calculate_spec_vol_array_Jackett(T, S, pres, specvol, start, npts, sp 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. + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den_STP = (T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) + I_num = 1.0 / (RN000 + num_STP) + + spec_vol_elem_Jackett06 = (1.0 + den_STP) * I_num + +end function spec_vol_elem_Jackett06 + +!> In situ specific volume anomaly of sea water using Jackett et al., 2006 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Jackett06(this, T, S, pressure, spv_ref) + class(Jackett06_EOS), intent(in) :: this !< This EOS + 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(in) :: spv_ref !< A reference specific volume [m3 kg-1]. ! 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 :: 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 = 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. + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num_STP = (T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) + den_STP = (T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) + I_num = 1.0 / (RN000 + num_STP) + + ! This form is slightly more complicated, but it cancels the leading terms better. + spec_vol_anomaly_elem_Jackett06 = ((1.0 - spv_ref*RN000) + (den_STP - spv_ref*num_STP)) * I_num + +end function spec_vol_anomaly_elem_Jackett06 + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using Jackett et al., 2006 +elemental subroutine calculate_density_derivs_elem_Jackett06(this, T, S, pressure, drho_dT, drho_dS) + class(Jackett06_EOS), intent(in) :: this !< This EOS + 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 - 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 + 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] @@ -245,94 +233,50 @@ subroutine calculate_specvol_derivs_Jackett06(T, S, pres, dSV_dT, dSV_dS, start, 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 + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_denom2 = 1.0 / den**2 + + ! rho = num / den + drho_dT = (dnum_dT * den - num * dden_dT) * I_denom2 + drho_dS = (dnum_dS * den - num * dden_dS) * I_denom2 + +end subroutine calculate_density_derivs_elem_Jackett06 + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using Jackett et al., 2006 +elemental subroutine calculate_density_second_derivs_elem_Jackett06(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, 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 + real, 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 + real, 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 + real, 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 + real, 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] @@ -365,186 +309,159 @@ subroutine calculate_density_second_derivs_array_Jackett(T, S, P, drho_ds_ds, dr ! 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]. + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + ! rho = num*I_den + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dnum_dp = RN001 + ((T2*RN021 + S*RN101) + pressure*(2.*RN002 + T2*(2.*RN022))) + d2num_dT2 = 2.*RN020 + T*(6.*RN030) + pressure*(2.*RN021 + pressure*(2.*RN022)) + d2num_dT_dS = RN110 + d2num_dS2 = 2.*RN200 + d2num_dT_dp = T*(2.*RN021 + pressure*(4.*RN022)) + d2num_dS_dp = RN101 + + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + dden_dp = RD001 + pressure*T*(T2*(2.*RD032) + pressure*(3.*RD013)) + + d2den_dT2 = (((2.*RD020) + T*((6.*RD030) + T*(12.*RD040))) + & + S*(T*(6.*RD130) + S1_2*(2.*RD620)) ) + pressure**2*(T*(6.*RD032)) + d2den_dT_dS = (RD110 + T2*3.*RD130) + (T*S1_2)*(3.0*RD620) + d2den_dT_dp = pressure*(T2*(6.*RD032) + pressure*(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 = (dnum_dp * den - num * dden_dp) / den**2 + ! drho_dT = (dnum_dT * den - num * dden_dT) / den**2 + ! drho_dS = (dnum_dS * den - num * dden_dS) / den**2 + drho_dS_dS = (den*(den*d2num_dS2 - 2.*dnum_dS*dden_dS) + num*(2.*dden_dS**2 - den*d2den_dS2)) * I_denom3 + drho_dS_dt = (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 = (den*(den*d2num_dT2 - 2.*dnum_dT*dden_dT) + num*(2.*dden_dT**2 - den*d2den_dT2)) * I_denom3 + + drho_dS_dp = (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 = (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 + +end subroutine calculate_density_second_derivs_elem_Jackett06 + +!> Calculate second derivatives of density with respect to temperature, salinity, and pressure, +!! using Jackett et al., 2006 +elemental subroutine calculate_specvol_derivs_elem_Jackett06(this, T, S, pressure, dSV_dT, dSV_dS) + class(Jackett06_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-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) :: 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) + 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] -end subroutine calculate_density_scalar_Jackett + S1_2 = sqrt(max(0.0,s)) + T2 = T*T + + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + + dnum_dT = ((RN010 + T*(2.*RN020 + T*(3.*RN030))) + S*RN110) + & + pressure*T*(2.*RN021 + pressure*(2.*RN022)) + dnum_dS = (RN100 + (T*RN110 + S*(2.*RN200))) + pressure*RN101 + dden_dT = ((RD010 + T*((2.*RD020) + T*((3.*RD030) + T*(4.*RD040)))) + & + S*((RD110 + T2*(3.*RD130)) + S1_2*T*(2.*RD620)) ) + & + pressure**2*(T2*3.*RD032 + pressure*RD013) + dden_dS = RD100 + (T*(RD110 + T2*RD130) + S1_2*(1.5*RD600 + T2*(1.5*RD620))) + I_num2 = 1.0 / num**2 + + ! SV = den / num + dSV_dT = (num * dden_dT - dnum_dT * den) * I_num2 + dSV_dS = (num * dden_dS - dnum_dS * den) * I_num2 + +end subroutine calculate_specvol_derivs_elem_Jackett06 + +!> 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 Jackett et al., 2006 +elemental subroutine calculate_compress_elem_Jackett06(this, T, S, pressure, rho, drho_dp) + class(Jackett06_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] + ! 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 -!> 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]. + S1_2 = sqrt(max(0.0,s)) + T2 = T*T - ! 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] + num = RN000 + ((T*(RN010 + T*(RN020 + T*RN030)) + & + S*(RN100 + (T*RN110 + S*RN200)) ) + & + pressure*(RN001 + ((T2*RN021 + S*RN101) + pressure*(RN002 + T2*RN022))) ) + den = 1.0 + ((T*(RD010 + T*(RD020 + T*(RD030 + T* RD040))) + & + S*(RD100 + (T*(RD110 + T2*RD130) + S1_2*(RD600 + T2*RD620))) ) + & + pressure*(RD001 + pressure*T*(T2*RD032 + pressure*RD013)) ) + dnum_dp = RN001 + ((T2*RN021 + S*RN101) + pressure*(2.*RN002 + T2*(2.*RN022))) + dden_dp = RD001 + pressure*T*(T2*(2.*RD032) + pressure*(3.*RD013)) - 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 + I_den = 1.0 / den + rho = num * I_den + drho_dp = (dnum_dp * den - num * dden_dp) * I_den**2 -!> 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 +end subroutine calculate_compress_elem_Jackett06 !> 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) +subroutine EoS_fit_range_Jackett06(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Jackett06_EOS), intent(in) :: this !< This EOS 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] @@ -563,6 +480,7 @@ subroutine EoS_fit_range_Jackett06(T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range_Jackett06 + !> \namespace mom_eos_Jackett06 !! !! \section section_EOS_Jackett06 Jackett et al. 2006 (Hycom-25-term) 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 b6133442db..205b6e2b55 100644 --- a/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 +++ b/src/equation_of_state/MOM_EOS_Roquet_SpV.F90 @@ -3,42 +3,11 @@ 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 +use MOM_EOS_base_type, only : EOS_base 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, 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], -!! 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 +public Roquet_SpV_EOS 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 @@ -184,48 +153,109 @@ module MOM_EOS_Roquet_Spv real, parameter :: BET003 = 0.5*SPV103*r1_S0 ! dSpV_dS fit P**3 coef. [m3 kg-1 ppt-1 Pa-3] !>@} +!> The EOS_base implementation of the Roquet et al., 2015, equation of state +type, extends (EOS_base) :: Roquet_SpV_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Roquet_SpV + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Roquet_SpV + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Roquet_SpV + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Roquet_SpV + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Roquet_SpV + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Roquet_SpV + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Roquet_SpV + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Roquet_SpV + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Roquet_SpV + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Roquet_SpV + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Roquet_SpV + +end type Roquet_SpV_EOS + contains -!> Computes the Roquet et al. in situ specific volume of sea water for scalar inputs and outputs. +!> Roquet et al. in situ specific volume of sea water [m3 kg-1] !! -!! 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] +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Roquet_SpV(this, T, S, pressure) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< pressure [Pa] ! 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) :: 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] + 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 Pa-1] + real :: SV_TS2 ! A temperature and salinity dependent specific volume contribution that is + ! 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 Pa-3] + real :: SV_0S0 ! Salinity dependent specific volume at the surface pressure and zero temperature [m3 kg-1] - T0(1) = T ; S0(1) = S ; pres0(1) = pressure + ! The following algorithm was published by Roquet et al. (2015), intended for use in non-Boussinesq ocean models. - call calculate_spec_vol_array_Roquet_SpV(T0, S0, pres0, spv0, 1, 1, spv_ref) - specvol = spv0(1) + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure -end subroutine calculate_spec_vol_scalar_Roquet_SpV + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. -!> Computes the Roquet et al. in situ specific volume of sea water for 1-d array inputs and outputs. + 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)) + spec_vol_elem_Roquet_SpV = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] + +end function spec_vol_elem_Roquet_SpV + +!> Roquet et al. in situ specific volume anomaly of sea water [m3 kg-1] !! -!! 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] +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Roquet_SpV(this, T, S, pressure, spv_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + 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) :: spv_ref !< A reference specific volume [m3 kg-1] ! Local variables real :: zp ! Pressure [Pa] @@ -244,118 +274,90 @@ subroutine calculate_spec_vol_array_Roquet_SpV(T, S, pressure, specvol, start, n real :: SV_TS3 ! A temperature and salinity dependent specific volume contribution that is ! 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) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. -!> 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] + 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)) )) )) )) ) ) - 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) :: 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] + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) - T0(1) = T - S0(1) = S - pres0(1) = pressure + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) - if (present(rho_ref)) then - 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, pres0, spv, 1, 1) - rho = 1.0 / spv(1) - endif + SV_0S0 = SV_0S0 - spv_ref -end subroutine calculate_density_scalar_Roquet_SpV + SV_TS = (SV_TS0 + SV_0S0) + zp*(SV_TS1 + zp*(SV_TS2 + zp*SV_TS3)) + spec_vol_anomaly_elem_Roquet_SpV = SV_TS + SV_00p ! In situ specific volume [m3 kg-1] -!> 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] +end function spec_vol_anomaly_elem_Roquet_SpV + +!> Roquet in situ density [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Roquet_SpV(this, T, S, pressure) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] ! Local variables - real, dimension(size(T)) :: spv ! The specific volume [m3 kg-1] - integer :: j + real :: spv ! The specific volume [m3 kg-1] - 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 + spv = spec_vol_elem_Roquet_SpV(this, T, S, pressure) + density_elem_Roquet_SpV = 1.0 / spv ! In situ density [kg m-3] -end subroutine calculate_density_array_Roquet_SpV +end function density_elem_Roquet_SpV + +!> Roquet in situ density anomaly [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Roquet_SpV(this, T, S, pressure, rho_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + 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) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + real :: spv ! The specific volume [m3 kg-1] + + spv = spec_vol_anomaly_elem_Roquet_SpV(this, T, S, pressure, spv_ref=1.0/rho_ref) + density_anomaly_elem_Roquet_SpV = -rho_ref**2*spv / (rho_ref*spv + 1.0) ! In situ density [kg m-3] + +end function density_anomaly_elem_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 +elemental subroutine calculate_specvol_derivs_elem_Roquet_SpV(this, T, S, pressure, dSV_dT, dSV_dS) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: 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 + real, intent(inout) :: 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 [Pa] real :: zt ! Conservative temperature [degC] @@ -377,127 +379,91 @@ subroutine calculate_specvol_derivs_Roquet_SpV(T, S, pressure, dSV_dT, dSV_dS, s ! 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 Pa-3] proportional to pressure**3 - integer :: j - - do j=start,start+npts-1 - ! Conversions to the units used here. - zt = T(j) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + 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 = 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 = (dSVdzs0 + zp*(dSVdzs1 + zp*(dSVdzs2 + zp * dSVdzs3))) / zs + +end subroutine calculate_specvol_derivs_elem_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 +elemental subroutine calculate_density_derivs_elem_Roquet_SpV(this, T, S, pressure, drho_dT, drho_dS) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + 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] - 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 + real :: 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 + real :: dSV_dS ! The partial derivative of specific volume with ! absolute salinity [m3 kg-1 ppt-1] + real :: specvol ! The specific volume [m3 kg-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) :: 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 - ! with absolute salinity [kg m-3 ppt-1] - - T0(1) = T - S0(1) = S - pres0(1) = pressure - - 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 + call this%calculate_specvol_derivs_elem(T, S, pressure, dSV_dT, dSV_dS) + + specvol = this%spec_vol_elem(T, S, pressure) + rho = 1.0 / specvol + drho_dT = -dSv_dT * rho**2 + drho_dS = -dSv_dS * rho**2 + +end subroutine calculate_density_derivs_elem_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 +elemental subroutine calculate_compress_elem_Roquet_SpV(this, T, S, pressure, rho, drho_dp) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) !! [s2 m-2] - integer, intent(in) :: start !< The starting index for calculations - integer, intent(in) :: npts !< The number of values to calculate ! Local variables real :: zp ! Pressure [Pa] @@ -521,73 +487,67 @@ subroutine calculate_compress_Roquet_SpV(T, S, pressure, rho, drho_dp, start, np ! 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 ! 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) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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. + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure - 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)) )) )) ) + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. - 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_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_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) + 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_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) + SV_0S0 = SPV000 + zs*(SPV100 + zs*(SPV200 + zs*(SPV300 + zs*(SPV400 + zs*(SPV500 + zs*SPV600))))) - 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] + SV_00p = zp*(V00 + zp*(V01 + zp*(V02 + zp*(V03 + zp*(V04 + zp*V05))))) - 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 ! [m3 kg-1 Pa-1] - drho_dp(j) = -dSpecVol_dp * rho(j)**2 ! Compressibility [s2 m-2] + 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 = 1.0 / (SV_TS + SV_00p) ! In situ density [kg m-3] - enddo -end subroutine calculate_compress_Roquet_SpV + 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 ! [m3 kg-1 Pa-1] + drho_dp = -dSpecVol_dp * rho**2 ! Compressibility [s2 m-2] +end subroutine calculate_compress_elem_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 !< The starting index for calculations - integer, intent(in ) :: npts !< The number of values to calculate - +elemental subroutine calc_spec_vol_second_derivs_elem_Roquet_SpV(T, S, P, & + dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, dSV_ds_dp, dSV_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(inout) :: dSV_ds_ds !< Second derivative of specific volume with respect + !! to salinity [m3 kg-1 ppt-2] + real, intent(inout) :: dSV_ds_dt !< Second derivative of specific volume with respect + !! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real, intent(inout) :: dSV_dt_dt !< Second derivative of specific volume with respect + !! to temperature [m3 kg-1 degC-2] + real, intent(inout) :: dSV_ds_dp !< Second derivative of specific volume with respect to pressure + !! and salinity [m3 kg-1 ppt-1 Pa-1] + real, intent(inout) :: dSV_dt_dp !< Second derivative of specific volume with respect to pressure + !! and temperature [m3 kg-1 degC-1 Pa-1] ! Local variables real :: zp ! Pressure [Pa] real :: zt ! Conservative temperature [degC] @@ -598,186 +558,135 @@ subroutine calc_spec_vol_second_derivs_array_Roquet_SpV(T, S, P, dSV_ds_ds, dSV_ 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) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) * ((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) - - ! 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) - - ! 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) - enddo - -end subroutine calc_spec_vol_second_derivs_array_Roquet_SpV + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = P + + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + 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 = (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 = (0.5*r1_S0) * ((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 = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) + + ! 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 = ((d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2)) * I_s) * (0.5*r1_S0) + + ! 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 = d2SV_p0 + zp*(d2SV_p1 + zp*d2SV_p2) + +end subroutine calc_spec_vol_second_derivs_elem_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 !< 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] - 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) +elemental subroutine calculate_density_second_derivs_elem_Roquet_SpV(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Second derivative of density with respect + !! to salinity [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Second derivative of density with respect + !! to salinity and temperature [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Second derivative of density with respect + !! to temperature [kg m-3 degC-2] + real, 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, 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] - 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 + real :: rho ! The in situ density [kg m-3] + real :: drho_dp ! The partial derivative of density with pressure + ! (also the inverse of the square of sound speed) [s2 m-2] + real :: dSV_dT ! The partial derivative of specific volume with + ! conservative temperature [m3 kg-1 degC-1] + real :: dSV_dS ! The partial derivative of specific volume with + ! absolute salinity [m3 kg-1 ppt-1] + real :: dSV_ds_ds ! Second derivative of specific volume with respect + ! to salinity [m3 kg-1 ppt-2] + real :: dSV_ds_dt ! Second derivative of specific volume with respect + ! to salinity and temperature [m3 kg-1 ppt-1 degC-1] + real :: dSV_dt_dt ! Second derivative of specific volume with respect + ! to temperature [m3 kg-1 degC-2] + real :: dSV_ds_dp ! Second derivative of specific volume with respect to pressure + ! and salinity [m3 kg-1 ppt-1 Pa-1] + real :: dSV_dt_dp ! Second derivative of specific volume with respect to pressure + ! and temperature [m3 kg-1 degC-1 Pa-1] + + call calc_spec_vol_second_derivs_elem_Roquet_SpV(T, S, pressure, & + dSV_ds_ds, dSV_ds_dt, dSV_dt_dt, dSV_ds_dp, dSV_dt_dp) + call this%calculate_specvol_derivs_elem(T, S, pressure, dSV_dT, dSV_dS) + call this%calculate_compress_elem(T, S, pressure, rho, drho_dp) + + ! Find drho_ds_ds + drho_dS_dS = rho**2 * (2.0*rho*dSV_dS**2 - dSV_dS_dS) + + ! Find drho_ds_dt + drho_ds_dt = rho**2 * (2.0*rho*(dSV_dT*dSV_dS) - dSV_dS_dT) + + ! Find drho_dt_dt + drho_dT_dT = rho**2 * (2.0*rho*dSV_dT**2 - dSV_dT_dT) + + ! Find drho_ds_dp + drho_ds_dp = -rho * (2.0*dSV_dS * drho_dp + rho * dSV_dS_dp) + + ! Find drho_dt_dp + drho_dt_dp = -rho * (2.0*dSV_dT * drho_dp + rho * dSV_dT_dp) + +end subroutine calculate_density_second_derivs_elem_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) +subroutine EoS_fit_range_Roquet_SpV(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS 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] @@ -794,6 +703,58 @@ subroutine EoS_fit_range_Roquet_SpV(T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range_Roquet_SpV +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Roquet_SpV(this, T, S, pressure, rho, start, npts, rho_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Roquet_SpV(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Roquet_SpV(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Roquet_SpV + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Roquet_SpV(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Roquet_SpV_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Roquet_SpV(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Roquet_SpV(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_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_Roquet_rho.F90 b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 index 6d7a7a143e..1a5cc7b49c 100644 --- a/src/equation_of_state/MOM_EOS_Roquet_rho.F90 +++ b/src/equation_of_state/MOM_EOS_Roquet_rho.F90 @@ -3,34 +3,11 @@ module MOM_EOS_Roquet_rho ! 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 +use MOM_EOS_base_type, only : EOS_base implicit none ; private -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_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_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_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 +public Roquet_rho_EOS 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 @@ -177,43 +154,46 @@ module MOM_EOS_Roquet_rho real, parameter :: BET003 = 0.5*EOS103*r1_S0 ! drho_dS fit P**3 coef. [kg m-3 ppt-1 Pa-3] !>@} +!> The EOS_base implementation of the Roquet et al., 2015, equation of state +type, extends (EOS_base) :: Roquet_rho_EOS + contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Roquet_rho + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Roquet_rho + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Roquet_rho + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Roquet_rho + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Roquet_rho + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Roquet_rho + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Roquet_rho + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Roquet_rho + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Roquet_rho + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Roquet_rho + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Roquet_rho + +end type Roquet_rho_EOS -!> 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, pres, rho, rho_ref) - real, intent(in) :: T !< Conservative temperature [degC] - real, intent(in) :: S !< Absolute salinity [g kg-1] - 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) :: 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 - pres0(1) = pres - - call calculate_density_array_Roquet_rho(T0, S0, pres0, rho0, 1, 1, rho_ref) - rho = rho0(1) - -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, 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) :: 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] +contains + +!> In situ density of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Roquet_rho(this, T, S, pressure) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] ! Local variables real :: zp ! Pressure [Pa] @@ -229,58 +209,143 @@ subroutine calculate_density_array_Roquet_rho(T, S, pres, rho, start, npts, rho_ 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) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) - 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)) )) )) )) ) ) - - rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) - - rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) - - if (present(rho_ref)) rho0S0 = rho0S0 - rho_ref - - 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_Roquet_rho + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + 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)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + density_elem_Roquet_rho = rhoTS + rho00p ! In situ density [kg m-3] + +end function density_elem_Roquet_rho + +!> In situ density anomaly of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Roquet_rho(this, T, S, pressure, rho_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + 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) :: rho_ref !< A reference density [kg m-3] + + ! Local variables + 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 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] + + ! The following algorithm was published by Roquet et al. (2015), intended for use with NEMO. + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + 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)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rho0S0 = rho0S0 - rho_ref + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + density_anomaly_elem_Roquet_rho = rhoTS + rho00p ! In situ density [kg m-3] + +end function density_anomaly_elem_Roquet_rho + +!> In situ specific volume of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Roquet_rho(this, T, S, pressure) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + + spec_vol_elem_Roquet_rho = 1. / density_elem_Roquet_rho(this, T, S, pressure) + +end function spec_vol_elem_Roquet_rho + +!> In situ specific volume anomaly of sea water from Roquet et al., 2015 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Roquet_rho(this, T, S, pressure, spv_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + 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) :: spv_ref !< A reference specific volume [m3 kg-1] + + spec_vol_anomaly_elem_Roquet_rho = 1. / density_elem_Roquet_rho(this, T, S, pressure) + spec_vol_anomaly_elem_Roquet_rho = spec_vol_anomaly_elem_Roquet_rho - spv_ref + +end function spec_vol_anomaly_elem_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, 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(:) :: 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 - !! 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 +elemental subroutine calculate_density_derivs_elem_Roquet_rho(this, T, S, pressure, drho_dT, drho_dS) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + 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 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] ! Local variables real :: zp ! Pressure [Pa] @@ -303,93 +368,176 @@ subroutine calculate_density_derivs_array_Roquet_rho(T, S, pres, drho_dT, drho_d ! 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 Pa-3] proportional to pressure**3 - integer :: j - do j=start,start+npts-1 - ! Conversions to the units used here. - zt = T(j) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 - 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) = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs - enddo - -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, pres, drho_dt, drho_ds) - real, intent(in) :: T !< Conservative temperature [degC] - real, intent(in) :: S !< Absolute salinity [g kg-1] - 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 - !! absolute salinity [kg m-3 ppt-1] + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + ! 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 = 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 = (dRdzs0 + zp*(dRdzs1 + zp*(dRdzs2 + zp * dRdzs3))) / zs + +end subroutine calculate_density_derivs_elem_Roquet_rho + +!> Second derivatives of density with respect to temperature, salinity, and pressure +elemental subroutine calculate_density_second_derivs_elem_Roquet_rho(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 ppt-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 ppt-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, intent(inout) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] + real, 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] + + ! Local variables + 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] + real :: d2R_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] + + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure + + ! 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. + + I_s = 1.0 / zs + + ! Find drho_ds_ds + 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 = (0.5*r1_S0)**2 * ((d2R_p0 + zp*(d2R_p1 + zp*(d2R_p2 + zp*d2R_p3))) * I_s) + + ! Find drho_ds_dt + 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 = (0.5*r1_S0) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) + + ! Find drho_dt_dt + 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 = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) + + ! Find drho_ds_dp + 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 = ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) * (0.5*r1_S0) + + ! Find drho_dt_dp + 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 = (d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) + +end subroutine calculate_density_second_derivs_elem_Roquet_rho + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the density polynomial fit EOS from Roquet et al. (2015). +elemental subroutine calculate_specvol_derivs_elem_Roquet_rho(this, T, S, pressure, dSV_dT, dSV_dS) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 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) :: 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 - ! with absolute salinity [kg m-3 ppt-1] - - T0(1) = T - S0(1) = S - pres0(1) = pres - - 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 + real :: rho ! In situ density [kg m-3] + real :: dRho_dT ! Derivative of density with temperature [kg m-3 degC-1] + real :: dRho_dS ! Derivative of density with salinity [kg m-3 ppt-1] + + call this%calculate_density_derivs_elem(T, S, pressure, drho_dT, drho_dS) + rho = this%density_elem(T, S, pressure) + dSV_dT = -dRho_DT/(rho**2) + dSV_dS = -dRho_DS/(rho**2) + +end subroutine calculate_specvol_derivs_elem_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_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(:) :: 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 +elemental subroutine calculate_compress_elem_Roquet_rho(this, T, S, pressure, rho, drho_dp) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure !! (also the inverse of the square of sound speed) !! [s2 m-2] - integer, intent(in) :: start !< The starting index for calculations - integer, intent(in) :: npts !< The number of values to calculate - ! Local variables real :: zp ! Pressure [Pa] real :: zt ! Conservative temperature [degC] @@ -406,195 +554,51 @@ subroutine calculate_compress_Roquet_rho(T, S, pres, rho, drho_dp, start, npts) 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) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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) - 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)) )) )) )) ) ) - - rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) - - rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) - - rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) - rho(j) = rhoTS + rho00p ! In situ density [kg m-3] - - 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 ! 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. -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 [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 - !! 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 !< The starting index for calculations - integer, intent(in ) :: npts !< The number of values to calculate + ! Conversions to the units used here. + zt = T + zs = SQRT( ABS( S + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [nondim] + zp = pressure - ! Local variables - 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] - real :: d2R_p3 ! A contribution to one of the second derivatives that is proportional to pressure**3 [various] - integer :: 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 = gsw_ct_from_pt(S,T) ! Convert potential temp to conservative temp [degC] + ! zs = SQRT( ABS( gsw_sr_from_sp(S) + rdeltaS ) * r1_S0 ) ! Convert S from practical to absolute salinity. - do j = start,start+npts-1 - ! Conversions to the units used here. - zt = T(j) - zs = SQRT( ABS( S(j) + rdeltaS ) * r1_S0 ) ! square root of normalized salinity plus an offset [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 = 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 - 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 - 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) * ((d2R_p0 + zp*(d2R_p1 + zp*d2R_p2)) * I_s) - - ! Find drho_dt_dt - 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)) - - ! Find drho_ds_dp - 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) - - ! Find drho_dt_dp - 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)) - enddo - -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_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 [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] = [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 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_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_Roquet_rho + 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)) )) )) )) ) ) + + rho0S0 = EOS000 + zs*(EOS100 + zs*(EOS200 + zs*(EOS300 + zs*(EOS400 + zs*(EOS500 + zs*EOS600))))) + + rho00p = zp*(R00 + zp*(R01 + zp*(R02 + zp*(R03 + zp*(R04 + zp*R05))))) + + rhoTS = (rhoTS0 + rho0S0) + zp*(rhoTS1 + zp*(rhoTS2 + zp*rhoTS3)) + rho = rhoTS + rho00p ! In situ density [kg m-3] + + 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 = drhoTS_dp + drho00p_dp ! Compressibility [s2 m-2] + +end subroutine calculate_compress_elem_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_Roquet_rho(T_min, T_max, S_min, S_max, p_min, p_max) +subroutine EoS_fit_range_Roquet_rho(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS 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] @@ -611,6 +615,58 @@ subroutine EoS_fit_range_Roquet_rho(T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range_Roquet_rho +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Roquet_rho(this, T, S, pressure, rho, start, npts, rho_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Roquet_rho(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Roquet_rho(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Roquet_rho + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Roquet_rho(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Roquet_rho_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Roquet_rho(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Roquet_rho(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Roquet_rho + !> \namespace mom_eos_Roquet_rho !! !! \section section_EOS_Roquet_rho Roquet_rho equation of state diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index 22faa495b4..3f138e20bb 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -3,216 +3,167 @@ module MOM_EOS_TEOS10 ! 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 TEOS10 functions * -!*********************************************************************** - use gsw_mod_toolbox, only : gsw_sp_from_sr, gsw_pt_from_ct use gsw_mod_toolbox, only : gsw_rho, gsw_specvol use gsw_mod_toolbox, only : gsw_rho_first_derivatives, gsw_specvol_first_derivatives use gsw_mod_toolbox, only : gsw_rho_second_derivatives -!use gsw_mod_toolbox, only : gsw_sr_from_sp, gsw_ct_from_pt +use MOM_EOS_base_type, only : EOS_base implicit none ; private -public calculate_compress_teos10, calculate_density_teos10, calculate_spec_vol_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 -!! a reference density, from absolute salinity (g/kg), conservative temperature (in deg C), -!! and pressure [Pa], using the TEOS10 expressions. -interface calculate_density_teos10 - module procedure calculate_density_scalar_teos10, calculate_density_array_teos10 -end interface calculate_density_teos10 - -!> 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 (in g/kg), conservative temperature -!! (in deg C), and pressure [Pa], using the TEOS10 expressions. -interface calculate_spec_vol_teos10 - module procedure calculate_spec_vol_scalar_teos10, calculate_spec_vol_array_teos10 -end interface calculate_spec_vol_teos10 - -!> For a given thermodynamic state, return the derivatives of density with conservative temperature -!! and absolute salinity, using the TEOS10 expressions. -interface calculate_density_derivs_teos10 - module procedure calculate_density_derivs_scalar_teos10, calculate_density_derivs_array_teos10 -end interface calculate_density_derivs_teos10 - -!> For a given thermodynamic state, return the second derivatives of density with various combinations -!! of conservative temperature, absolute salinity, and pressure, using the TEOS10 expressions. -interface calculate_density_second_derivs_teos10 - module procedure calculate_density_second_derivs_scalar_teos10, calculate_density_second_derivs_array_teos10 -end interface calculate_density_second_derivs_teos10 +public TEOS10_EOS real, parameter :: Pa2db = 1.e-4 !< The conversion factor from Pa to dbar [dbar Pa-1] -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 expression from the TEOS10 website. -subroutine calculate_density_scalar_teos10(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]. - - ! 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) :: 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_teos10(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) - -end subroutine calculate_density_scalar_teos10 - -!> 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 expression from the -!! TEOS10 website. -subroutine calculate_density_array_teos10(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]. - - ! Local variables - real :: zs ! Absolute salinity [g kg-1] - real :: zt ! Conservative temperature [degC] - real :: zp ! Pressure converted to decibars [dbar] - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - rho(j) = 1000.0 - else - rho(j) = gsw_rho(zs,zt,zp) - endif - if (present(rho_ref)) rho(j) = rho(j) - rho_ref - enddo -end subroutine calculate_density_array_teos10 - -!> This subroutine computes 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], using the TEOS10 equation of state. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_scalar_teos10(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 absolute 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_teos10(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_teos10 - - -!> This subroutine computes 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], using the TEOS10 equation of state. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_array_teos10(T, S, pressure, specvol, start, npts, spv_ref) - real, dimension(:), intent(in) :: T !< Conservative temperature [degC]. - real, dimension(:), intent(in) :: S !< salinity [g kg-1]. - 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]. - - ! Local variables - real :: zs ! Absolute salinity [g kg-1] - real :: zt ! Conservative temperature [degC] - real :: zp ! Pressure converted to decibars [dbar] - integer :: j +!> The EOS_base implementation of the TEOS10 equation of state +type, extends (EOS_base) :: TEOS10_EOS - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_TEOS10 + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_TEOS10 + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_TEOS10 + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_TEOS10 + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_TEOS10 + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_TEOS10 + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_TEOS10 + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_TEOS10 + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_TEOS10 + +end type TEOS10_EOS - if (S(j) < -1.0e-10) then - specvol(j) = 0.001 !Can we assume safely that this is a missing value? - else - specvol(j) = gsw_specvol(zs,zt,zp) - endif - if (present(spv_ref)) specvol(j) = specvol(j) - spv_ref - enddo +contains -end subroutine calculate_spec_vol_array_teos10 +!> GSW in situ density [kg m-3] +real elemental function density_elem_TEOS10(this, T, S, pressure) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! density_elem_TEOS10 = 1000.0 +! else +! density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) + +end function density_elem_TEOS10 + +!> GSW in situ density anomaly [kg m-3] +real elemental function density_anomaly_elem_TEOS10(this, T, S, pressure, rho_ref) + class(TEOS10_EOS), intent(in) :: this !< This EOS + 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) :: rho_ref !< A reference density [kg m-3]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! density_elem_TEOS10 = 1000.0 +! else +! density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + density_anomaly_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) + density_anomaly_elem_TEOS10 = density_anomaly_elem_TEOS10 - rho_ref + +end function density_anomaly_elem_TEOS10 + +!> GSW in situ specific volume [m3 kg-1] +real elemental function spec_vol_elem_TEOS10(this, T, S, pressure) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Conservative temperature [degC]. + real, intent(in) :: S !< Absolute salinity [g kg-1]. + real, intent(in) :: pressure !< pressure [Pa]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! spec_vol_elem_TEOS10 = 0.001 +! else +! spec_vol_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + spec_vol_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) + +end function spec_vol_elem_TEOS10 + +!> GSW in situ specific volume anomaly [m3 kg-1] +real elemental function spec_vol_anomaly_elem_TEOS10(this, T, S, pressure, spv_ref) + class(TEOS10_EOS), intent(in) :: this !< This EOS + 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) :: spv_ref !< A reference specific volume [m3 kg-1]. + + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA +! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? +! spec_vol_elem_TEOS10 = 0.001 +! else +! spec_vol_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) +! endif + + spec_vol_anomaly_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) - spv_ref + +end function spec_vol_anomaly_elem_TEOS10 !> For a given thermodynamic state, calculate the derivatives of density with conservative !! temperature and absolute salinity, using the TEOS10 expressions. -subroutine calculate_density_derivs_array_teos10(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 (g/kg)-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - +elemental subroutine calculate_density_derivs_elem_TEOS10(this, T, S, pressure, drho_dT, drho_dS) + class(TEOS10_EOS), intent(in) :: this !< This EOS + 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 real :: zs ! Absolute salinity [g kg-1] real :: zt ! Conservative temperature [degC] real :: zp ! Pressure converted to decibars [dbar] - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - 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 - else - call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS(j), drho_dct=drho_dT(j)) - endif - enddo - -end subroutine calculate_density_derivs_array_teos10 -!> For a given thermodynamic state, calculate the derivatives of density with conservative -!! temperature and absolute salinity, using the TEOS10 expressions. -subroutine calculate_density_derivs_scalar_teos10(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 (g/kg)-1]. + !Conversions + zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp + zp = pressure* Pa2db !Convert pressure from Pascal to decibar + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! drho_dT = 0.0 ; drho_dS = 0.0 + !else + call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) + !endif + +end subroutine calculate_density_derivs_elem_TEOS10 +!> Calculate the 5 second derivatives of the equation of state for scalar inputs +elemental subroutine calculate_density_second_derivs_elem_TEOS10(this, T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, 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, 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] ! Local variables real :: zs ! Absolute salinity [g kg-1] real :: zt ! Conservative temperature [degC] @@ -222,60 +173,28 @@ subroutine calculate_density_derivs_scalar_teos10(T, S, pressure, drho_dT, drho_ zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if (S < -1.0e-10) return !Can we assume safely that this is a missing value? - call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) -end subroutine calculate_density_derivs_scalar_teos10 + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! drho_dS_dS = 0.0 ; drho_dS_dT = 0.0 ; drho_dT_dT = 0.0 + ! drho_dS_dP = 0.0 ; drho_dT_dP = 0.0 + !else + call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & + rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) + !endif + +end subroutine calculate_density_second_derivs_elem_TEOS10 !> For a given thermodynamic state, calculate the derivatives of specific volume with conservative !! temperature and absolute salinity, using the TEOS10 expressions. -subroutine calculate_specvol_derivs_teos10(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(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! conservative temperature [m3 kg-1 degC-1]. - real, intent(out), dimension(:) :: dSV_dS !< The partial derivative of specific volume with - !! absolute salinity [m3 kg-1 (g/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 :: zs ! Absolute salinity [g kg-1] - real :: zt ! Conservative temperature [degC] - real :: zp ! Pressure converted to decibars [dbar] - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - dSV_dT(j) = 0.0 ; dSV_dS(j) = 0.0 - else - call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS(j), v_ct=dSV_dT(j)) - endif - enddo - -end subroutine calculate_specvol_derivs_teos10 - -!> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, 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) :: pressure !< pressure [Pa]. - real, intent(out) :: drho_dS_dS !< Partial derivative of beta with respect - !! to S [kg m-3 (g/kg)-2] - real, intent(out) :: drho_dS_dT !< Partial derivative of beta with respect - !! to T [kg m-3 (g/kg)-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 (g/kg)-1 Pa-1] = [s2 m-2 (g/kg)-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] - +elemental subroutine calculate_specvol_derivs_elem_TEOS10(this, T, S, pressure, dSV_dT, dSV_dS) + class(TEOS10_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] ! Local variables real :: zs ! Absolute salinity [g kg-1] real :: zt ! Conservative temperature [degC] @@ -285,94 +204,54 @@ subroutine calculate_density_second_derivs_scalar_teos10(T, S, pressure, drho_dS zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp zp = pressure* Pa2db !Convert pressure from Pascal to decibar - if (S < -1.0e-10) return !Can we assume safely that this is a missing value? - call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & - rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! dSV_dT = 0.0 ; dSV_dS = 0.0 + !else + call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS, v_ct=dSV_dT) + !endif -end subroutine calculate_density_second_derivs_scalar_teos10 - -!> Calculate the 5 second derivatives of the equation of state for scalar inputs -subroutine calculate_density_second_derivs_array_teos10(T, S, pressure, 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) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: drho_dS_dS !< Partial derivative of beta with respect - !! to S [kg m-3 (g/kg)-2] - real, dimension(:), intent(out) :: drho_dS_dT !< Partial derivative of beta with respect - !! to T [kg m-3 (g/kg)-1 degC-1] - real, dimension(:), intent(out) :: drho_dT_dT !< Partial derivative of alpha with respect - !! to T [kg m-3 degC-2] - real, dimension(:), intent(out) :: drho_dS_dP !< Partial derivative of beta with respect - !! to pressure [kg m-3 (g/kg)-1 Pa-1] = [s2 m-2 (g/kg)-1] - real, dimension(:), 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] - integer, intent(in) :: start !< The starting point in the arrays. - 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] - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - if (S(j) < -1.0e-10) then !Can we assume safely that this is a missing value? - drho_dS_dS(j) = 0.0 ; drho_dS_dT(j) = 0.0 ; drho_dT_dT(j) = 0.0 - drho_dS_dP(j) = 0.0 ; drho_dT_dP(j) = 0.0 - else - call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS(j), rho_sa_ct=drho_dS_dT(j), & - rho_ct_ct=drho_dT_dT(j), rho_sa_p=drho_dS_dP(j), rho_ct_p=drho_dT_dP(j)) - endif - enddo - -end subroutine calculate_density_second_derivs_array_teos10 +end subroutine calculate_specvol_derivs_elem_TEOS10 !> 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 absolute salinity (sal [g kg-1]), !! conservative temperature (T [degC]), and pressure [Pa]. It uses the !! subroutines from TEOS10 website -subroutine calculate_compress_teos10(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 point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. +elemental subroutine calculate_compress_elem_TEOS10(this, T, S, pressure, rho, drho_dp) + class(TEOS10_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] ! Local variables real :: zs ! Absolute salinity [g kg-1] real :: zt ! Conservative temperature [degC] real :: zp ! Pressure converted to decibars [dbar] - integer :: j - - do j=start,start+npts-1 - !Conversions - zs = S(j) !gsw_sr_from_sp(S(j)) !Convert practical salinity to absolute salinity - zt = T(j) !gsw_ct_from_pt(S(j),T(j)) !Convert potential temp to conservative temp - zp = pressure(j)* Pa2db !Convert pressure from Pascal to decibar - 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 - else - rho(j) = gsw_rho(zs,zt,zp) - call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp(j)) - endif - enddo -end subroutine calculate_compress_teos10 + !Conversions + zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity + zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp + zp = pressure* Pa2db !Convert pressure from Pascal to decibar + !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA + !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? + ! rho = 1000.0 ; drho_dp = 0.0 + !else + rho = gsw_rho(zs,zt,zp) + call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp) + !endif + +end subroutine calculate_compress_elem_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) +subroutine EoS_fit_range_teos10(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(TEOS10_EOS), intent(in) :: this !< This EOS 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] @@ -389,4 +268,11 @@ subroutine EoS_fit_range_teos10(T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range_teos10 +!> \namespace mom_eos_teos10 +!! +!! \section section_EOS_TEOS10 TEOS10 equation of state +!! +!! The TEOS10 equation of state is implemented via the GSW toolbox. We recommend using the +!! Roquet et al. forms of this equation of state. + 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 984b4a7217..6051c0fb0a 100644 --- a/src/equation_of_state/MOM_EOS_UNESCO.F90 +++ b/src/equation_of_state/MOM_EOS_UNESCO.F90 @@ -3,33 +3,11 @@ module MOM_EOS_UNESCO ! This file is part of MOM6. See LICENSE.md for the license. -implicit none ; private - -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, 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], -!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). -interface calculate_density_UNESCO - module procedure calculate_density_scalar_UNESCO, calculate_density_array_UNESCO -end interface calculate_density_UNESCO +use MOM_EOS_base_type, only : EOS_base -!> 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 [PSU], potential temperature [degC], and -!! pressure [Pa], using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). -interface calculate_spec_vol_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 +implicit none ; private +public UNESCO_EOS !>@{ 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. @@ -84,46 +62,80 @@ module MOM_EOS_UNESCO real, parameter :: S122 = 6.207323e-10 ! A coefficient in the secant bulk modulus fit [bar-1 degC-2 PSU-1] !>@} +!> The EOS_base implementation of the UNESCO equation of state +type, extends (EOS_base) :: UNESCO_EOS + contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_UNESCO + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_UNESCO + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_UNESCO + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_UNESCO + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_UNESCO + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_UNESCO + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_UNESCO + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_UNESCO + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_UNESCO + +end type UNESCO_EOS -!> 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], -!! 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] +contains + +!> In situ density as fit by Jackett and McDougall, 1995 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_UNESCO(this, T, S, pressure) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] ! 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 in situ density [kg m-3] + 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] - T0(1) = T - S0(1) = S - pressure0(1) = pressure + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) - call calculate_density_array_UNESCO(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) + ! Compute rho(s,theta,p=0) - (same as rho(s,t_insitu,p=0) ). + 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 -end subroutine calculate_density_scalar_UNESCO + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + 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)) )) ) -!> 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], -!! 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 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] + density_elem_UNESCO = rho0*ks / (ks - p1) + +end function density_elem_UNESCO + +!> In situ density anomaly as fit by Jackett and McDougall, 1995 [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_UNESCO(this, T, S, pressure, rho_ref) + class(UNESCO_EOS), intent(in) :: this !< This EOS + 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(in) :: rho_ref !< A reference density [kg m-3] ! Local variables real :: t1 ! A copy of the temperature at a point [degC] @@ -133,121 +145,111 @@ subroutine calculate_density_array_UNESCO(T, S, pressure, rho, start, npts, rho_ 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 - 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) ). + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(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=0) - (same as rho(s,t_insitu,p=0) ). + 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. + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + 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)) )) ) - 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)) )) ) + density_anomaly_elem_UNESCO = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) - if (present(rho_ref)) then - rho(j) = ((R00 - rho_ref)*ks + (sig0*ks + p1*rho_ref)) / (ks - p1) - else - rho(j) = rho0*ks / (ks - p1) - endif - enddo -end subroutine calculate_density_array_UNESCO +end function density_anomaly_elem_UNESCO -!> 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], -!! 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] +!> In situ specific volume as fit by Jackett and McDougall, 1995 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_UNESCO(this, T, S, pressure) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] ! 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] + 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] - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(s1) - call calculate_spec_vol_array_UNESCO(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_UNESCO + ! Compute rho(s,theta,p=0), which is the same as rho(s,t_insitu,p=0). + 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)) ) -!> 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], -!! 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 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] + ! Compute rho(s,theta,p), first calculating the secant bulk modulus. + 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)) )) ) + + spec_vol_elem_UNESCO = (ks - p1) / (rho0*ks) + +end function spec_vol_elem_UNESCO + +!> In situ specific volume anomaly as fit by Jackett and McDougall, 1995 [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_UNESCO(this, T, S, pressure, spv_ref) + class(UNESCO_EOS), intent(in) :: this !< This EOS + 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(in) :: spv_ref !< A reference specific volume [m3 kg-1] ! 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]l553 + 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] - 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) + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 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), which is the same as rho(s,t_insitu,p=0). + 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)) ) - 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 = (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)) )) ) - ! Compute rho(s,theta,p), first calculating the secant bulk modulus. - - 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) - else - specvol(j) = (ks - p1) / (rho0*ks) - endif - enddo -end subroutine calculate_spec_vol_array_UNESCO + spec_vol_anomaly_elem_UNESCO = (ks*(1.0 - (rho0*spv_ref)) - p1) / (rho0*ks) +end function spec_vol_anomaly_elem_UNESCO !> 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(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 PSU-1] - integer, intent(in) :: start !< The starting index for calculations - integer, intent(in) :: npts !< The number of values to calculate - +elemental subroutine calculate_density_derivs_elem_UNESCO(this, T, S, pressure, drho_dT, drho_dS) + class(UNESCO_EOS), intent(in) :: this !< This EOS + 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 real :: t1 ! A copy of the temperature at a point [degC] real :: s1 ! A copy of the salinity at a point [PSU] @@ -260,56 +262,172 @@ subroutine calculate_density_derivs_UNESCO(T, S, pressure, drho_dT, drho_dS, sta real :: dks_dT ! Derivative of ks with T [bar degC-1] real :: dks_dS ! Derivative of ks with S [bar psu-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) 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)) ) - - 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 - -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. + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 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)) ) + + I_denom = 1.0 / (ks - p1) + drho_dT = (ks*drho0_dT - dks_dT*((rho0*p1)*I_denom)) * I_denom + drho_dS = (ks*drho0_dS - dks_dS*((rho0*p1)*I_denom)) * I_denom + +end subroutine calculate_density_derivs_elem_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) +elemental subroutine calculate_density_second_derivs_elem_UNESCO(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, 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, 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] + + ! 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] + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 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*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*(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 = 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 = (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: + ! 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 = 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 = 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 = 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 = (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 = (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) ) ) + +end subroutine calculate_density_second_derivs_elem_UNESCO + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the UNESCO (1981) equation of state, as refit by Jackett and McDougall (1995). +elemental subroutine calculate_specvol_derivs_elem_UNESCO(this, T, S, pressure, dSV_dT, dSV_dS) + class(UNESCO_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] ! Local variables real :: t1 ! A copy of the temperature at a point [degC] real :: s1 ! A copy of the salinity at a point [PSU] @@ -322,59 +440,53 @@ subroutine calculate_specvol_derivs_UNESCO(T, S, pressure, dSV_dT, dSV_dS, start 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_specvol_derivs_UNESCO + + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 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 = (ks - p1) / (rho0*ks) = 1/rho0 - p1/(rho0*ks) + I_denom2 = 1.0 / (rho0*ks)**2 + dSV_dT = ((p1*rho0)*dks_dT + ((p1 - ks)*ks)*drho0_dT) * I_denom2 + dSV_dS = ((p1*rho0)*dks_dS + ((p1 - ks)*ks)*drho0_dS) * I_denom2 + +end subroutine calculate_specvol_derivs_elem_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) !! 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] - 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 - +elemental subroutine calculate_compress_elem_UNESCO(this, T, S, pressure, rho, drho_dp) + class(UNESCO_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] ! Local variables real :: t1 ! A copy of the temperature at a point [degC] real :: s1 ! A copy of the salinity at a point [PSU] @@ -387,209 +499,39 @@ subroutine calculate_compress_UNESCO(T, S, pressure, rho, drho_dp, start, npts) 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 - 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). + p1 = pressure*1.0e-5 ; t1 = T + s1 = max(S, 0.0) ; s12 = sqrt(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=0), which is the same as rho(s,t_insitu,p=0). - ! Calculate the secant bulk modulus and its derivative with pressure. - 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)) ) + 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)) ) - ks = ks_0 + p1*(ks_1 + p1*ks_2) - dks_dp = ks_1 + 2.0*p1*ks_2 - I_denom = 1.0 / (ks - p1) + ! Calculate the secant bulk modulus and its derivative with pressure. + 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)) ) - ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. - 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 * ((rho0 * (ks - p1*dks_dp)) * I_denom**2) - enddo -end subroutine calculate_compress_UNESCO + ks = ks_0 + p1*(ks_1 + p1*ks_2) + dks_dp = ks_1 + 2.0*p1*ks_2 + I_denom = 1.0 / (ks - p1) -!> 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 + ! Compute the in situ density, rho(s,theta,p), and its derivative with pressure. + rho = rho0*ks * I_denom + ! The factor of 1.0e-5 is because pressure here is in bars, not Pa. + drho_dp = 1.0e-5 * ((rho0 * (ks - p1*dks_dp)) * I_denom**2) - ! 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*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*(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 = 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 = (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: - ! 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 -!! 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( 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 +end subroutine calculate_compress_elem_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) +subroutine EoS_fit_range_UNESCO(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(UNESCO_EOS), intent(in) :: this !< This EOS 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] diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index d8dee28aa2..8b6d6495d1 100644 --- a/src/equation_of_state/MOM_EOS_Wright.F90 +++ b/src/equation_of_state/MOM_EOS_Wright.F90 @@ -1,52 +1,17 @@ -!> The equation of state using the Wright 1997 expressions +!> The equation of state using a poor implementation (missing parenthesis and bugs) of the +!! reduced range Wright 1997 expressions module MOM_EOS_Wright ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_EOS_base_type, only : EOS_base use MOM_hor_index, only : hor_index_type implicit none ; private -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, avg_spec_vol_Wright +public buggy_Wright_EOS 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 -!! 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 - -!> 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 - module procedure calculate_spec_vol_scalar_wright, calculate_spec_vol_array_wright -end interface calculate_spec_vol_wright - -!> 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 - -!> Compute the second derivatives of density with various combinations -!! 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 +public avg_spec_vol_buggy_Wright !>@{ 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]. @@ -71,48 +36,68 @@ module MOM_EOS_Wright real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] !>@} +!> The EOS_base implementation of the Wright 1997 equation of state with some bugs +type, extends (EOS_base) :: buggy_Wright_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_buggy_Wright + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_buggy_Wright + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_buggy_Wright + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_buggy_Wright + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_buggy_Wright + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_buggy_Wright + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_buggy_Wright + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_buggy_Wright + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_buggy_Wright + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_buggy_Wright + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_buggy_Wright + +end type buggy_Wright_EOS + contains -!> Computes the in situ density of sea water for scalar inputs and outputs. +!> In situ density of sea water using a buggy implementation of Wright, 1997 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_buggy_Wright(this, T, S, pressure) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. ! 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 + 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] - call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*(b2 + b3*T) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*(c2 + c3*T) + c5*S) + density_elem_buggy_Wright = (pressure + p0) / (lambda + al0*(pressure + p0)) -end subroutine calculate_density_scalar_wright +end function density_elem_buggy_Wright -!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!> In situ density anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_buggy_Wright(this, T, S, pressure, rho_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + 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(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] @@ -122,173 +107,116 @@ subroutine calculate_density_array_wright(T, S, pressure, rho, start, npts, rho_ 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. + pa_000 = (b0*(1.0 - a0*rho_ref) - rho_ref*c0) + al_TS = a1*T +a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) + + ! The following two expressions are mathematically equivalent. + ! wright_density = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_buggy_Wright = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) + +end function density_anomaly_elem_buggy_Wright + +!> In situ specific volume of sea water using a buggy implementation of Wright, 1997 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_buggy_Wright(this, T, S, pressure) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. ! 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] + 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] - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) - call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_wright + spec_vol_elem_buggy_Wright = (lambda + al0*(pressure + p0)) / (pressure + p0) -!> Computes the Wright in situ specific volume of sea water for 1-d array inputs and outputs. +end function spec_vol_elem_buggy_Wright + +!> In situ specific volume anomaly of sea water using a buggy implementation of Wright, 1997 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_buggy_Wright(this, T, S, pressure, spv_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + 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(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. + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + spec_vol_anomaly_elem_buggy_Wright = (lambda + (al0 - spv_ref)*(pressure + p0)) / (pressure + p0) + +end function spec_vol_anomaly_elem_buggy_Wright + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the buggy implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_buggy_Wright(this, T, S, pressure, drho_dT, drho_dS) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + 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 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 -!> 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 + al0 = (a0 + a1*T) + a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0)) + I_denom2 = I_denom2 *I_denom2 + drho_dT = I_denom2 * & + (lambda* (b1 + T*(2.0*b2 + 3.0*b3*T) + b5*S) - & + (pressure+p0) * ( (pressure+p0)*a1 + & + (c1 + T*(c2*2.0 + c3*3.0*T) + c5*S) )) + drho_dS = I_denom2 * (lambda* (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_buggy_Wright + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_buggy_Wright(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, 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 + real, 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 + real, 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 + real, 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 + real, 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] @@ -300,257 +228,98 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh 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] - 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))) ! 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)) - 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 - ! 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 - 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 calc_dens_second_derivs_buggy_array_wright - -!> 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 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] - 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 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 -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]. - 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. - + z0 = T*(b1 + b5*S + T*(b2 + b3*T)) + z1 = (b0 + pressure + b4*S + z0) + z3 = (b1 + b5*S + T*(2.*b2 + 2.*b3*T)) ! BUG: This should be z3 = b1 + b5*S + T*(2.*b2 + 3.*b3*T) + z4 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T))) + z5 = (b1 + b5*S + T*(b2 + b3*T) + T*(b2 + 2.*b3*T)) + z6 = c1 + c5*S + T*(c2 + c3*T) + T*(c2 + 2.*c3*T) + z7 = (c4 + c5*T + a2*z1) + z8 = (c1 + c5*S + T*(2.*c2 + 3.*c3*T) + a1*z1) + z9 = (a0 + a2*S + a1*T) + z10 = (b4 + b5*T) + z11 = (z10*z4 - z1*z7) + z2 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T)) + z9*z1) + z2_2 = z2*z2 + z2_3 = z2_2*z2 + + drho_ds_ds = (z10*(c4 + c5*T) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T + z9*z10 + a2*z1)*z11)/z2_3 + drho_ds_dt = (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) should be (2.*b2 + 6.*b3*T) + drho_dt_dt = (z3*z6 - z1*(2.*c2 + 6.*c3*T + a1*z5) + (2.*b2 + 4.*b3*T)*z4 - z5*z8)/z2_2 - & + (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 + drho_ds_dp = (-c4 - c5*T - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 + drho_dt_dp = (-c1 - c5*S - T*(2.*c2 + 3.*c3*T) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 + +end subroutine calculate_density_second_derivs_elem_buggy_Wright + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_buggy_Wright(this, T, S, pressure, dSV_dT, dSV_dS) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] ! 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 - -!> 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]. - 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. +! al0 = (a0 + a1*T) + a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = (a1 + I_denom * (c1 + T*((2.0*c2 + 3.0*c3*T)) + c5*S)) - & + (I_denom**2 * lambda) * (b1 + T*((2.0*b2 + 3.0*b3*T)) + b5*S) + dSV_dS = (a2 + I_denom * (c4 + c5*T)) - & + (I_denom**2 * lambda) * (b4 + b5*T) + +end subroutine calculate_specvol_derivs_elem_buggy_Wright + +!> 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 poor implementation of the equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_buggy_Wright(this, T, S, pressure, rho, drho_dp) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. ! 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)) + al0 = (a0 + a1*T) +a2*S + p0 = (b0 + b4*S) + T * (b1 + T*((b2 + b3*T)) + b5*S) + lambda = (c0 +c4*S) + T * (c1 + T*((c2 + c3*T)) + c5*S) - 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 + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom * I_denom + +end subroutine calculate_compress_elem_buggy_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) +subroutine avg_spec_vol_buggy_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]. @@ -581,12 +350,13 @@ subroutine avg_spec_vol_Wright(T, S, p_t, dp, SpV_avg, start, npts) 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 +end subroutine avg_spec_vol_buggy_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) +subroutine EoS_fit_range_buggy_Wright(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS 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] @@ -601,7 +371,7 @@ subroutine EoS_fit_range_Wright(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 = 5.0e7 -end subroutine EoS_fit_range_Wright +end subroutine EoS_fit_range_buggy_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 @@ -1102,6 +872,58 @@ 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 +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_buggy_Wright(this, T, S, pressure, rho, start, npts, rho_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_buggy_Wright(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_buggy_Wright(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_buggy_Wright + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_buggy_Wright(this, T, S, pressure, specvol, start, npts, spv_ref) + class(buggy_Wright_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_buggy_Wright(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_buggy_Wright(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_buggy_Wright + !> \namespace 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 107ced3f5b..31b82e6190 100644 --- a/src/equation_of_state/MOM_EOS_Wright_full.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_full.F90 @@ -1,45 +1,17 @@ -!> The equation of state using the Wright 1997 expressions +!> The equation of state using the Wright 1997 expressions with full range of data. module MOM_EOS_Wright_full ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_EOS_base_type, only : EOS_base use MOM_hor_index, only : hor_index_type implicit none ; private -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 +public Wright_full_EOS 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 -!! temperature (in degrees Celsius [degC]), and pressure [Pa], using the expressions from -!! 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 - -!> 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 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 - -!> 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 - -!> 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 -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]. @@ -63,119 +35,124 @@ module MOM_EOS_Wright_full real, parameter :: c5 = -2.765195 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] !>@} +!> The EOS_base implementation of the full range Wright 1997 equation of state +type, extends (EOS_base) :: Wright_full_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Wright_full + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Wright_full + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Wright_full + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Wright_full + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Wright_full + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Wright_full + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Wright_full + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Wright_full + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Wright_full + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Wright_full + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Wright_full + +end type Wright_full_EOS + contains -!> Computes the in situ density of sea water for scalar inputs and outputs. +!> In situ density of sea water using a full range fit by Wright, 1997 [kg m-3] !! -!! 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]. - 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 is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Wright_full(this, T, S, pressure) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] ! 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 + 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] - call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + density_elem_Wright_full = (pressure + p0) / (lambda + al0*(pressure + p0)) -end subroutine calculate_density_scalar_wright +end function density_elem_Wright_full -!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!> In situ density anomaly of sea water using a full range fit by Wright, 1997 [kg m-3] !! -!! 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]. - 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Wright_full(this, T, S, pressure, rho_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + 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(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 + pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + al_TS = a1*T + a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) -end subroutine calculate_density_array_wright + ! The following two expressions are mathematically equivalent. + ! rho = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_Wright_full = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) -!> Computes the Wright in situ specific volume of sea water for scalar inputs and outputs. +end function density_anomaly_elem_Wright_full + +!> In situ specific volume of sea water using a full range fit by Wright, 1997 [kg m-3] !! -!! 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]. - 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Wright_full(this, T, S, pressure) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] ! 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] + 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], 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] - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + spec_vol_elem_Wright_full = al0 + lambda / (pressure + p0) - call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_wright +end function spec_vol_elem_Wright_full -!> Computes the Wright in situ specific volume of sea water for 1-d array inputs and outputs. +!> In situ specific volume anomaly of sea water using a full range fit by Wright, 1997 [kg m-3] !! -!! 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 - !! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Wright_full(this, T, S, pressure, spv_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + 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(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] @@ -185,109 +162,63 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, 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 - - 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 -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. + lam_000 = c0 + (a0 - spv_ref)*b0 + al_TS = a1*T + a2*S + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lambda = lam_000 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + spec_vol_anomaly_elem_Wright_full = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + +end function spec_vol_anomaly_elem_Wright_full + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_Wright_full(this, T, S, pressure, drho_dT, drho_dS) + class(Wright_full_EOS), intent(in) :: this !< This EOS + 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 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 + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0))**2 + drho_dT = I_denom2 * (lambda * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S)) - & + (pressure+p0) * ( (pressure+p0)*a1 + (c1 + (T*(c2*2.0 + c3*3.0*T) + c5*S)) )) + drho_dS = I_denom2 * (lambda * (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_Wright_full + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_Wright_full(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, 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, 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] ! 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] @@ -304,152 +235,99 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh 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_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. + al0 = a0 + (a1*T + a2*S) + p_p0 = pressure + ( b0 + (b4*S + T*(b1 + (b5*S + T*(b2 + b3*T)))) ) ! P + p0 + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + dp0_dT = b1 + (b5*S + T*(2.*b2 + 3.*b3*T)) + dp0_dS = b4 + b5*T + dlam_dT = c1 + (c5*S + T*(2.*c2 + 3.*c3*T)) + dlam_dS = c4 + c5*T + 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 = p_p0 / (lambda + al0*p_p0) + ! drho_dp = lambda * I_denom2 + ! drho_dT = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt = ((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 = 2.*((b2 + 3.*b3*T)*lambda - p_p0*((c2 + 3.*c3*T) + 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 = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Wright_full + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_Wright_full(this,T, S, pressure, dSV_dT, dSV_dS) + class(Wright_full_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] ! 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_full - -!> 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]. - 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. + ! al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = a1 + I_denom * ((c1 + (T*(2.0*c2 + 3.0*c3*T) + c5*S)) - & + (I_denom * lambda) * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S))) + dSV_dS = a2 + I_denom * ((c4 + c5*T) - & + (I_denom * lambda) * (b4 + b5*T)) + +end subroutine calculate_specvol_derivs_elem_Wright_full + +!> 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 full range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_Wright_full(this, T, S, pressure, rho, drho_dp) + class(Wright_full_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2] ! 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))) ) + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) - 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_full + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom**2 + +end subroutine calculate_compress_elem_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 @@ -474,7 +352,7 @@ subroutine avg_spec_vol_Wright_full(T, S, p_t, dp, SpV_avg, start, npts) 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) + ! alpha = al0 + lambda / (pressure + 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))) ) @@ -485,12 +363,14 @@ subroutine avg_spec_vol_Wright_full(T, S, p_t, dp, SpV_avg, start, npts) 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. -subroutine EoS_fit_range_Wright_full(T_min, T_max, S_min, S_max, p_min, p_max) +subroutine EoS_fit_range_Wright_full(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Wright_full_EOS), intent(in) :: this !< This EOS 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] @@ -673,7 +553,7 @@ subroutine int_density_dz_wright_full(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & 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 = (pressure + p0) / (lambda + al0*(pressure + 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)))) @@ -905,7 +785,7 @@ subroutine int_spec_vol_dp_wright_full(T, S, p_t, p_b, spv_ref, HI, dza, & ! "dP_neglect must be present if useMassWghtInterp is present and true.") endif ; endif - ! alpha(j) = (lambda + al0*(pressure(j) + p0)) / (pressure(j) + p0) + ! alpha = (lambda + al0*(pressure + p0)) / (pressure + 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))) ) ) @@ -1009,6 +889,58 @@ 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 +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Wright_full(this, T, S, pressure, rho, start, npts, rho_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Wright_full(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Wright_full(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Wright_full + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Wright_full(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Wright_full_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Wright_full(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Wright_full(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Wright_full + !> \namespace mom_eos_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 5553112274..65bdb9e521 100644 --- a/src/equation_of_state/MOM_EOS_Wright_red.F90 +++ b/src/equation_of_state/MOM_EOS_Wright_red.F90 @@ -1,45 +1,17 @@ -!> The equation of state using the Wright 1997 expressions +!> The equation of state using the Wright 1997 expressions with reduced range of data. module MOM_EOS_Wright_red ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_EOS_base_type, only : EOS_base use MOM_hor_index, only : hor_index_type implicit none ; private -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 +public Wright_red_EOS 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 -!! 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]. @@ -63,119 +35,124 @@ module MOM_EOS_Wright_red real, parameter :: c5 = -3.079464 ! A parameter in the Wright lambda fit [m2 s-2 degC-1 PSU-1] !>@} +!> The EOS_base implementation of the reduced range Wright 1997 equation of state +type, extends (EOS_base) :: Wright_red_EOS + +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_Wright_red + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_Wright_red + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_Wright_red + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_Wright_red + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_Wright_red + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_Wright_red + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_Wright_red + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_Wright_red + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_Wright_red + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_Wright_red + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_Wright_red + +end type Wright_red_EOS + contains -!> Computes the in situ density of sea water for scalar inputs and outputs. +!> In situ density of sea water using a reduced range fit by Wright, 1997 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_elem_Wright_red(this, T, S, pressure) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC]. + real, intent(in) :: S !< salinity [PSU]. + real, intent(in) :: pressure !< pressure [Pa]. ! 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 + 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] - call calculate_density_array_wright(T0, S0, pressure0, rho0, 1, 1, rho_ref) - rho = rho0(1) + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + density_elem_Wright_red = (pressure + p0) / (lambda + al0*(pressure + p0)) -end subroutine calculate_density_scalar_wright +end function density_elem_Wright_red -!> Computes the in situ density of sea water for 1-d array inputs and outputs. +!> In situ density anomaly of sea water using a reduced range fit by Wright, 1997 [kg m-3] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function density_anomaly_elem_Wright_red(this, T, S, pressure, rho_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + 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(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 + pa_000 = b0*(1.0 - a0*rho_ref) - rho_ref*c0 + al_TS = a1*T + a2*S + al0 = a0 + al_TS + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lam_TS = c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) -end subroutine calculate_density_array_wright + ! The following two expressions are mathematically equivalent. + ! rho = (b0 + p0_TSp) / ((c0 + lam_TS) + al0*(b0 + p0_TSp)) - rho_ref + density_anomaly_elem_Wright_red = & + (pa_000 + (p_TSp - rho_ref*(p_TSp*al0 + (b0*al_TS + lam_TS)))) / & + ( (c0 + lam_TS) + al0*(b0 + p_TSp) ) -!> Computes the Wright in situ specific volume of sea water for scalar inputs and outputs. +end function density_anomaly_elem_Wright_red + +!> In situ specific volume of sea water using a reduced range fit by Wright, 1997 [m3 kg-1] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_elem_Wright_red(this, T, S, pressure) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface [degC] + real, intent(in) :: S !< salinity [PSU] + real, intent(in) :: pressure !< pressure [Pa] ! 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] + 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], 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] - T0(1) = T ; S0(1) = S ; pressure0(1) = pressure + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + spec_vol_elem_Wright_red = al0 + lambda / (pressure + p0) - call calculate_spec_vol_array_wright(T0, S0, pressure0, spv0, 1, 1, spv_ref) - specvol = spv0(1) -end subroutine calculate_spec_vol_scalar_wright +end function spec_vol_elem_Wright_red -!> Computes the Wright in situ specific volume of sea water for 1-d array inputs and outputs. +!> In situ specific volume anomaly of sea water using a reduced range fit by Wright, 1997 [m3 kg-1] !! -!! 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]. +!! This is an elemental function that can be applied to any combination of scalar and array inputs. +real elemental function spec_vol_anomaly_elem_Wright_red(this, T, S, pressure, spv_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + 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(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] @@ -185,108 +162,64 @@ subroutine calculate_spec_vol_array_wright(T, S, pressure, specvol, start, npts, 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 - 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 -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. + al_TS = a1*T + a2*S + p_TSp = pressure + (b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S))) + lambda = lam_000 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + ! This is equivalent to the expression below minus spv_ref, but less sensitive to roundoff. + spec_vol_anomaly_elem_Wright_red = al_TS + (lambda + (a0 - spv_ref)*p_TSp) / (b0 + p_TSp) + +end function spec_vol_anomaly_elem_Wright_red + +!> Calculate the partial derivatives of density with potential temperature and salinity +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_derivs_elem_Wright_red(this, T, S, pressure, drho_dT, drho_dS) + class(Wright_red_EOS), intent(in) :: this !< This EOS + 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 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 + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + I_denom2 = 1.0 / (lambda + al0*(pressure + p0))**2 + drho_dT = I_denom2 * (lambda * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S)) - & + (pressure+p0) * ( (pressure+p0)*a1 + (c1 + (T*(c2*2.0 + c3*3.0*T) + c5*S)) )) + drho_dS = I_denom2 * (lambda * (b4 + b5*T) - & + (pressure+p0) * ( (pressure+p0)*a2 + (c4 + c5*T) )) + +end subroutine calculate_density_derivs_elem_Wright_red + +!> Second derivatives of density with respect to temperature, salinity, and pressure, +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_density_second_derivs_elem_Wright_red(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, 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 + real, 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 + real, 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 + real, 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 + real, 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] @@ -304,152 +237,100 @@ subroutine calculate_density_second_derivs_array_wright(T, S, P, drho_ds_ds, drh 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. + al0 = a0 + (a1*T + a2*S) + p_p0 = pressure + ( b0 + (b4*S + T*(b1 + (b5*S + T*(b2 + b3*T)))) ) ! P + p0 + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + dp0_dT = b1 + (b5*S + T*(2.*b2 + 3.*b3*T)) + dp0_dS = b4 + b5*T + dlam_dT = c1 + (c5*S + T*(2.*c2 + 3.*c3*T)) + dlam_dS = c4 + c5*T + 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 = p_p0 / (lambda + al0*p_p0) + ! drho_dp = lambda * I_denom2 + ! drho_dT = (dp0_dT*lambda - p_p0*(dlam_dT + a1*p_p0)) * I_denom2 = dRdT_num * I_denom2 + ! drho_dS = (dp0_dS*lambda - p_p0*(dlam_dS + a2*p_p0)) * I_denom2 = dRdS_num * I_denom2 + drho_ds_ds = -2.*(p_p0*(a2*dp0_dS)) * I_denom2 - 2.*(dRdS_num*ddenom_dS) * I_denom3 + drho_ds_dt = ((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 = 2.*((b2 + 3.*b3*T)*lambda - p_p0*((c2 + 3.*c3*T) + 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 = dlam_dS * I_denom2 - 2.0 * lambda * (dlam_dS + a2*p_p0 + al0*dp0_ds) * Idenom3 + drho_ds_dp = (-dlam_dS - 2.*a2*p_p0) * I_denom2 - (2.*al0*dRdS_num) * I_denom3 + drho_dt_dp = (-dlam_dT - 2.*a1*p_p0) * I_denom2 - (2.*al0*dRdT_num) * I_denom3 + +end subroutine calculate_density_second_derivs_elem_Wright_red + +!> Calculate the partial derivatives of specific volume with temperature and salinity +!! using the reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_specvol_derivs_elem_Wright_red(this, T, S, pressure, dSV_dT, dSV_dS) + class(Wright_red_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] ! 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. + !al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) + + ! SV = al0 + lambda / (pressure + p0) + + I_denom = 1.0 / (pressure + p0) + dSV_dT = a1 + I_denom * ((c1 + (T*(2.0*c2 + 3.0*c3*T) + c5*S)) - & + (I_denom * lambda) * (b1 + (T*(2.0*b2 + 3.0*b3*T) + b5*S))) + dSV_dS = a2 + I_denom * ((c4 + c5*T) - & + (I_denom * lambda) * (b4 + b5*T)) + +end subroutine calculate_specvol_derivs_elem_Wright_red + +!> 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 reduced range equation of state, as fit by Wright, 1997 +elemental subroutine calculate_compress_elem_Wright_red(this, T, S, pressure, rho, drho_dp) + class(Wright_red_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. ! 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))) ) + al0 = a0 + (a1*T + a2*S) + p0 = b0 + ( b4*S + T * (b1 + (T*(b2 + b3*T) + b5*S)) ) + lambda = c0 + ( c4*S + T * (c1 + (T*(c2 + c3*T) + c5*S)) ) - 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 + I_denom = 1.0 / (lambda + al0*(pressure + p0)) + rho = (pressure + p0) * I_denom + drho_dp = lambda * I_denom**2 + +end subroutine calculate_compress_elem_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 @@ -490,7 +371,8 @@ 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. -subroutine EoS_fit_range_Wright_red(T_min, T_max, S_min, S_max, p_min, p_max) +subroutine EoS_fit_range_Wright_red(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(Wright_red_EOS), intent(in) :: this !< This EOS 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] @@ -1009,6 +891,58 @@ 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 +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_Wright_red(this, T, S, pressure, rho, start, npts, rho_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_Wright_red(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_Wright_red(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_Wright_red + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_Wright_red(this, T, S, pressure, specvol, start, npts, spv_ref) + class(Wright_red_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_Wright_red(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_Wright_red(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_Wright_red + !> \namespace mom_eos_wright_red !! diff --git a/src/equation_of_state/MOM_EOS_base_type.F90 b/src/equation_of_state/MOM_EOS_base_type.F90 new file mode 100644 index 0000000000..a6e5a21309 --- /dev/null +++ b/src/equation_of_state/MOM_EOS_base_type.F90 @@ -0,0 +1,464 @@ +!> A generic type for equations of state +module MOM_EOS_base_type + +! This file is part of MOM6. See LICENSE.md for the license. + +implicit none ; private + +public EOS_base + +!> The base class for implementations of the equation of state +type, abstract :: EOS_base + +contains + + ! The following functions/subroutines are deferred and must be provided specifically by each EOS + + !> Deferred implementation of the in-situ density as an elemental function [kg m-3] + procedure(i_density_elem), deferred :: density_elem + !> Deferred implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure(i_density_anomaly_elem), deferred :: density_anomaly_elem + !> Deferred implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure(i_spec_vol_elem), deferred :: spec_vol_elem + !> Deferred implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure(i_spec_vol_anomaly_elem), deferred :: spec_vol_anomaly_elem + !> Deferred implementation of the calculation of derivatives of density + procedure(i_calculate_density_derivs_elem), deferred :: calculate_density_derivs_elem + !> Deferred implementation of the calculation of second derivatives of density + procedure(i_calculate_density_second_derivs_elem), deferred :: calculate_density_second_derivs_elem + !> Deferred implementation of the calculation of derivatives of specific volume + procedure(i_calculate_specvol_derivs_elem), deferred :: calculate_specvol_derivs_elem + !> Deferred implementation of the calculation of compressibility + procedure(i_calculate_compress_elem), deferred :: calculate_compress_elem + !> Deferred implementation of the range query function + procedure(i_EOS_fit_range), deferred :: EOS_fit_range + + ! The following functions/subroutines are shared across all EOS and provided by this module + !> Returns the in-situ density or density anomaly [kg m-3] + procedure :: density_fn => a_density_fn + !> Returns the in-situ specific volume or specific volume anomaly [m3 kg-1] + procedure :: spec_vol_fn => a_spec_vol_fn + !> Calculates the in-situ density or density anomaly for scalar inputs [m3 kg-1] + procedure :: calculate_density_scalar => a_calculate_density_scalar + !> Calculates the in-situ density or density anomaly for array inputs [m3 kg-1] + procedure :: calculate_density_array => a_calculate_density_array + !> Calculates the in-situ specific volume or specific volume anomaly for scalar inputs [m3 kg-1] + procedure :: calculate_spec_vol_scalar => a_calculate_spec_vol_scalar + !> Calculates the in-situ specific volume or specific volume anomaly for array inputs [m3 kg-1] + procedure :: calculate_spec_vol_array => a_calculate_spec_vol_array + !> Calculates the derivatives of density for scalar inputs + procedure :: calculate_density_derivs_scalar => a_calculate_density_derivs_scalar + !> Calculates the derivatives of density for array inputs + procedure :: calculate_density_derivs_array => a_calculate_density_derivs_array + !> Calculates the second derivatives of density for scalar inputs + procedure :: calculate_density_second_derivs_scalar => a_calculate_density_second_derivs_scalar + !> Calculates the second derivatives of density for array inputs + procedure :: calculate_density_second_derivs_array => a_calculate_density_second_derivs_array + !> Calculates the derivatives of specific volume for array inputs + procedure :: calculate_specvol_derivs_array => a_calculate_specvol_derivs_array + !> Calculates the compressibility for array inputs + procedure :: calculate_compress_array => a_calculate_compress_array + +end type EOS_base + +interface + + !> In situ density [kg m-3] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_density_elem(this, T, S, pressure) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + end function i_density_elem + + !> In situ density anomaly [kg m-3] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_density_anomaly_elem(this, T, S, pressure, rho_ref) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + 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(in) :: rho_ref !< A reference density [kg m-3] + + end function i_density_anomaly_elem + + !> In situ specific volume [m3 kg-1] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_spec_vol_elem(this, T, S, pressure) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + end function i_spec_vol_elem + + !> In situ specific volume anomaly [m3 kg-1] + !! + !! This is an elemental function that can be applied to any combination of scalar and array inputs. + real elemental function i_spec_vol_anomaly_elem(this, T, S, pressure, spv_ref) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + 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(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + end function i_spec_vol_anomaly_elem + + !> Calculate the partial derivatives of density with potential temperature and salinity + elemental subroutine i_calculate_density_derivs_elem(this, T, S, pressure, drho_dT, drho_dS) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + 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] + + end subroutine i_calculate_density_derivs_elem + + !> Calculate the partial derivatives of specific volume with temperature and salinity + elemental subroutine i_calculate_specvol_derivs_elem(this, T, S, pressure, dSV_dT, dSV_dS) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + + end subroutine i_calculate_specvol_derivs_elem + + !> Calculate second derivatives of density with respect to temperature, salinity, and pressure + elemental subroutine i_calculate_density_second_derivs_elem(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, 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, 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] + + end subroutine i_calculate_density_second_derivs_elem + + !> 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 + elemental subroutine i_calculate_compress_elem(this, T, S, pressure, rho, drho_dp) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure (or + !! the inverse of the square of sound speed) [s2 m-2] + + end subroutine i_calculate_compress_elem + + !> Return the range of temperatures, salinities and pressures for which the equations of state has been + !! fitted or is valid. Care should be taken when applying this equation of state outside of its fit range. + subroutine i_EOS_fit_range(this, T_min, T_max, S_min, S_max, p_min, p_max) + import :: EOS_base + class(EOS_base), intent(in) :: this !< This EOS + 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] + + end subroutine i_EOS_fit_range + +end interface + +contains + + !> In situ density [kg m-3] + real function a_density_fn(this, T, S, pressure, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, optional, intent(in) :: rho_ref !< A reference density [kg m-3] + + if (present(rho_ref)) then + a_density_fn = this%density_anomaly_elem(T, S, pressure, rho_ref) + else + a_density_fn = this%density_elem(T, S, pressure) + endif + + end function a_density_fn + + !> Calculate the in-situ density for scalar inputs and outputs. + subroutine a_calculate_density_scalar(this, T, S, pressure, rho, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + 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] + + if (present(rho_ref)) then + rho = this%density_anomaly_elem(T, S, pressure, rho_ref) + else + rho = this%density_elem(T, S, pressure) + endif + + end subroutine a_calculate_density_scalar + + !> Calculate the in-situ density for 1D arraya inputs and outputs. + subroutine a_calculate_density_array(this, T, S, pressure, rho, start, npts, rho_ref) + class(EOS_base), intent(in) :: this !< This EOS + 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 + integer :: js, je + + js = start + je = start+npts-1 + + if (present(rho_ref)) then + rho(js:je) = this%density_anomaly_elem(T(js:je), S(js:je), pressure(js:je), rho_ref) + else + rho(js:je) = this%density_elem(T(js:je), S(js:je), pressure(js:je)) + endif + + end subroutine a_calculate_density_array + + !> In situ specific volume [m3 kg-1] + real function a_spec_vol_fn(this, T, S, pressure, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1] + + if (present(spv_ref)) then + a_spec_vol_fn = this%spec_vol_anomaly_elem(T, S, pressure, spv_ref) + else + a_spec_vol_fn = this%spec_vol_elem(T, S, pressure) + endif + + end function a_spec_vol_fn + + !> Calculate the in-situ specific volume for scalar inputs and outputs. + subroutine a_calculate_spec_vol_scalar(this, T, S, pressure, specvol, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + 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] + + if (present(spv_ref)) then + specvol = this%spec_vol_anomaly_elem(T, S, pressure, spv_ref) + else + specvol = this%spec_vol_elem(T, S, pressure) + endif + + end subroutine a_calculate_spec_vol_scalar + + !> Calculate the in-situ specific volume for 1D array inputs and outputs. + subroutine a_calculate_spec_vol_array(this, T, S, pressure, specvol, start, npts, spv_ref) + class(EOS_base), intent(in) :: this !< This EOS + 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 + integer :: js, je + + js = start + je = start+npts-1 + + if (present(spv_ref)) then + specvol(js:je) = this%spec_vol_anomaly_elem(T(js:je), S(js:je), pressure(js:je), spv_ref) + else + specvol(js:je) = this%spec_vol_elem(T(js:je), S(js:je), pressure(js:je) ) + endif + + end subroutine a_calculate_spec_vol_array + + !> Calculate the derivatives of density with respect to temperature, salinity and pressure + !! for scalar inputs + subroutine a_calculate_density_derivs_scalar(this, T, S, P, drho_dT, drho_dS) + class(EOS_base), intent(in) :: this !< This EOS + 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_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] + + call this%calculate_density_derivs_elem(T, S, P, drho_dt, drho_ds) + + end subroutine a_calculate_density_derivs_scalar + + !> Calculate the derivatives of density with respect to temperature, salinity and pressure + !! for array inputs + subroutine a_calculate_density_derivs_array(this, T, S, pressure, drho_dT, drho_dS, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + 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) :: drho_dT !< The partial derivative of density with potential + !! temperature [kg m-3 degC-1] + real, dimension(:), intent(out) :: drho_dS !< The partial derivative of density with salinity, + !! 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 + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_density_derivs_elem(T(js:je), S(js:je), pressure(js:je), drho_dt(js:je), drho_ds(js:je)) + + end subroutine a_calculate_density_derivs_array + + !> Calculate the second derivatives of density with respect to temperature, salinity and pressure + !! for scalar inputs + subroutine a_calculate_density_second_derivs_scalar(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + class(EOS_base), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature referenced to 0 dbar + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< 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] + + call this%calculate_density_second_derivs_elem(T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp) + + end subroutine a_calculate_density_second_derivs_scalar + + !> Calculate the second derivatives of density with respect to temperature, salinity and pressure + !! for array inputs + subroutine a_calculate_density_second_derivs_array(this, T, S, pressure, & + drho_ds_ds, drho_ds_dt, drho_dt_dt, drho_ds_dp, drho_dt_dp, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature referenced to 0 dbar + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(out) :: drho_ds_ds !< Partial derivative of beta with respect + !! to S [kg m-3 PSU-2] + real, dimension(:), intent(out) :: drho_ds_dt !< Partial derivative of beta with respect + !! to T [kg m-3 PSU-1 degC-1] + real, dimension(:), intent(out) :: drho_dt_dt !< Partial derivative of alpha with respect + !! to T [kg m-3 degC-2] + real, dimension(:), intent(out) :: drho_ds_dp !< Partial derivative of beta with respect + !! to pressure [kg m-3 PSU-1 Pa-1] = [s2 m-2 PSU-1] + real, dimension(:), 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] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_density_second_derivs_elem(T(js:je), S(js:je), pressure(js:je), & + drho_ds_ds(js:je), drho_ds_dt(js:je), drho_dt_dt(js:je), & + drho_ds_dp(js:je), drho_dt_dp(js:je)) + + end subroutine a_calculate_density_second_derivs_array + + !> Calculate the partial derivatives of specific volume with temperature and salinity + !! for array inputs + subroutine a_calculate_specvol_derivs_array(this, T, S, pressure, dSV_dT, dSV_dS, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + real, dimension(:), intent(in) :: T !< Potential temperature [degC] + real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: pressure !< Pressure [Pa] + real, dimension(:), intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] + real, dimension(:), intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + integer, intent(in) :: start !< The starting index for calculations + integer, intent(in) :: npts !< The number of values to calculate + + ! Local variables + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_specvol_derivs_elem(T(js:je), S(js:je), pressure(js:je), & + dSV_dT(js:je), dSV_dS(js:je)) + + end subroutine a_calculate_specvol_derivs_array + + !> 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 for array inputs + subroutine a_calculate_compress_array(this, T, S, pressure, rho, drho_dp, start, npts) + class(EOS_base), intent(in) :: this !< This EOS + 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] + real, dimension(:), intent(out) :: drho_dp !< The partial derivative of density with pressure (or + !! 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 + integer :: js, je + + js = start + je = start+npts-1 + + call this%calculate_compress_elem(T(js:je), S(js:je), pressure(js:je), & + rho(js:je), drho_dp(js:je)) + + end subroutine a_calculate_compress_array + +!> \namespace mom_eos_base_type +!! +!! \section section_EOS_base_type Generic EOS type +!! + +end module MOM_EOS_base_type diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index b1dacf2780..e171aaa442 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -3,222 +3,153 @@ module MOM_EOS_linear ! This file is part of MOM6. See LICENSE.md for the license. +use MOM_EOS_base_type, only : EOS_base use MOM_hor_index, only : hor_index_type implicit none ; private -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 -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 linear_EOS +public int_density_dz_linear +public 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 -! 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 density of sea water (in [kg m-3]), or its anomaly from a reference density, -!! using a simple linear equation of state from salinity in practical salinity units ([PSU]), -!! potential temperature in degrees Celsius ([degC]) and pressure [Pa]. -interface calculate_density_linear - module procedure calculate_density_scalar_linear, calculate_density_array_linear -end interface calculate_density_linear - -!> Compute the specific volume of sea water (in [m3 kg-1]), or its anomaly from a reference value, -!! using a simple linear equation of state from salinity in practical salinity units ([PSU]), -!! potential temperature in degrees Celsius ([degC]) and pressure [Pa]. -interface calculate_spec_vol_linear - module procedure calculate_spec_vol_scalar_linear, calculate_spec_vol_array_linear -end interface calculate_spec_vol_linear - -!> For a given thermodynamic state, return the derivatives of density with temperature and -!! salinity using the simple linear equation of state -interface calculate_density_derivs_linear - module procedure calculate_density_derivs_scalar_linear, calculate_density_derivs_array_linear -end interface calculate_density_derivs_linear - -!> For a given thermodynamic state, return the second derivatives of density with various -!! combinations of temperature, salinity, and pressure. Note that with a simple linear -!! equation of state these second derivatives are all 0. -interface calculate_density_second_derivs_linear - module procedure calculate_density_second_derivs_scalar_linear, calculate_density_second_derivs_array_linear -end interface calculate_density_second_derivs_linear +!> The EOS_base implementation of a linear equation of state +type, extends (EOS_base) :: linear_EOS -contains - -!> This subroutine computes the density of sea water with a trivial -!! linear equation of state (in [kg m-3]) from salinity (sal [PSU]), -!! potential temperature (T [degC]), and pressure [Pa]. -subroutine calculate_density_scalar_linear(T, S, pressure, rho, & - Rho_T0_S0, dRho_dT, dRho_dS, 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, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature - !! [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity - !! in [kg m-3 ppt-1]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - - if (present(rho_ref)) then - rho = (Rho_T0_S0 - rho_ref) + (dRho_dT*T + dRho_dS*S) - else - rho = Rho_T0_S0 + dRho_dT*T + dRho_dS*S - endif - -end subroutine calculate_density_scalar_linear - -!> This subroutine computes the density of sea water with a trivial -!! linear equation of state (in [kg m-3]) from salinity (sal [PSU]), -!! potential temperature (T [degC]), and pressure [Pa]. -subroutine calculate_density_array_linear(T, S, pressure, rho, start, npts, & - Rho_T0_S0, dRho_dT, dRho_dS, 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, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature - !! [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity - !! in [kg m-3 ppt-1]. - real, optional, intent(in) :: rho_ref !< A reference density [kg m-3]. - ! Local variables - integer :: j + real :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. + real :: dRho_dT !< The derivative of density with temperature [kg m-3 degC-1]. + real :: dRho_dS !< The derivative of density with salinity [kg m-3 ppt-1]. - if (present(rho_ref)) then ; do j=start,start+npts-1 - rho(j) = (Rho_T0_S0 - rho_ref) + (dRho_dT*T(j) + dRho_dS*S(j)) - enddo ; else ; do j=start,start+npts-1 - rho(j) = Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j) - enddo ; endif +contains + !> Implementation of the in-situ density as an elemental function [kg m-3] + procedure :: density_elem => density_elem_linear + !> Implementation of the in-situ density anomaly as an elemental function [kg m-3] + procedure :: density_anomaly_elem => density_anomaly_elem_linear + !> Implementation of the in-situ specific volume as an elemental function [m3 kg-1] + procedure :: spec_vol_elem => spec_vol_elem_linear + !> Implementation of the in-situ specific volume anomaly as an elemental function [m3 kg-1] + procedure :: spec_vol_anomaly_elem => spec_vol_anomaly_elem_linear + !> Implementation of the calculation of derivatives of density + procedure :: calculate_density_derivs_elem => calculate_density_derivs_elem_linear + !> Implementation of the calculation of second derivatives of density + procedure :: calculate_density_second_derivs_elem => calculate_density_second_derivs_elem_linear + !> Implementation of the calculation of derivatives of specific volume + procedure :: calculate_specvol_derivs_elem => calculate_specvol_derivs_elem_linear + !> Implementation of the calculation of compressibility + procedure :: calculate_compress_elem => calculate_compress_elem_linear + !> Implementation of the range query function + procedure :: EOS_fit_range => EOS_fit_range_linear + + !> Instance specific function to set internal parameters + procedure :: set_params_linear => set_params_linear + + !> Local implementation of generic calculate_density_array for efficiency + procedure :: calculate_density_array => calculate_density_array_linear + !> Local implementation of generic calculate_spec_vol_array for efficiency + procedure :: calculate_spec_vol_array => calculate_spec_vol_array_linear + +end type linear_EOS -end subroutine calculate_density_array_linear +contains -!> 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], using a trivial linear equation of state for density. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_scalar_linear(T, S, pressure, specvol, & - Rho_T0_S0, dRho_dT, dRho_dS, spv_ref) - real, intent(in) :: T !< potential temperature relative to the surface +!> Density computed as a linear function of T and S [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function density_elem_linear(this, T, S, pressure) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature relative to the surface [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< Pressure [Pa] + + density_elem_linear = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + +end function density_elem_linear + +!> Density anomaly computed as a linear function of T and S [kg m-3] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function density_anomaly_elem_linear(this, T, S, pressure, rho_ref) + class(linear_EOS), intent(in) :: this !< This EOS + 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(in) :: rho_ref !< A reference density [kg m-3] + + density_anomaly_elem_linear = (this%Rho_T0_S0 - rho_ref) + (this%dRho_dT*T + this%dRho_dS*S) + +end function density_anomaly_elem_linear + +!> Specific volume using a linear equation of state for density [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function spec_vol_elem_linear(this, T, S, pressure) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< potential temperature relative to the surface + !! [degC]. + real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: pressure !< Pressure [Pa]. + + spec_vol_elem_linear = 1.0 / ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) + +end function spec_vol_elem_linear + +!> Specific volume anomaly using a linear equation of state for density [m3 kg-1] +!! +!! This is an elemental function that can be applied to any combination of +!! scalar and array inputs. +real elemental function spec_vol_anomaly_elem_linear(this, T, S, pressure, spv_ref) + class(linear_EOS), intent(in) :: this !< This EOS + 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(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + + spec_vol_anomaly_elem_linear = ((1.0 - this%Rho_T0_S0*spv_ref) - & + spv_ref*(this%dRho_dT*T + this%dRho_dS*S)) / & + ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) + +end function spec_vol_anomaly_elem_linear + +!> This subroutine calculates the partial derivatives of density +!! with potential temperature and salinity. +elemental subroutine calculate_density_derivs_elem_linear(this,T, S, pressure, dRho_dT, dRho_dS) + class(linear_EOS), intent(in) :: this !< This EOS + 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, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. + 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 [kg m-3 ppt-1]. - if (present(spv_ref)) then - 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)) - endif + drho_dT = this%dRho_dT + drho_dS = this%dRho_dS -end subroutine calculate_spec_vol_scalar_linear - -!> 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], using a trivial linear equation of state for density. -!! If spv_ref is present, specvol is an anomaly from spv_ref. -subroutine calculate_spec_vol_array_linear(T, S, pressure, specvol, start, npts, & - Rho_T0_S0, dRho_dT, dRho_dS, 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, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. - real, optional, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - ! Local variables - 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))) / & - ( 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))) - enddo ; endif - -end subroutine calculate_spec_vol_array_linear - -!> This subroutine calculates the partial derivatives of density * -!! with potential temperature and salinity. -subroutine calculate_density_derivs_array_linear(T, S, pressure, drho_dT_out, & - drho_dS_out, Rho_T0_S0, 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(out), dimension(:) :: drho_dT_out !< The partial derivative of density with - !! potential temperature [kg m-3 degC-1]. - real, intent(out), dimension(:) :: drho_dS_out !< The partial derivative of density with - !! salinity [kg m-3 ppt-1]. - 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]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - ! Local variables - integer :: j - - do j=start,start+npts-1 - drho_dT_out(j) = dRho_dT - drho_dS_out(j) = dRho_dS - enddo - -end subroutine calculate_density_derivs_array_linear - -!> This subroutine calculates the partial derivatives of density * -!! with potential temperature and salinity for a single point. -subroutine calculate_density_derivs_scalar_linear(T, S, pressure, drho_dT_out, & - drho_dS_out, Rho_T0_S0, 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_out !< The partial derivative of density with - !! potential temperature [kg m-3 degC-1]. - real, intent(out) :: drho_dS_out !< The partial derivative of density with - !! salinity [kg m-3 ppt-1]. - real, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3]. - real, intent(in) :: dRho_dT !< The derivatives of density with temperature [kg m-3 degC-1]. - real, intent(in) :: dRho_dS !< The derivatives of density with salinity [kg m-3 ppt-1]. - drho_dT_out = dRho_dT - drho_dS_out = dRho_dS - -end subroutine calculate_density_derivs_scalar_linear +end subroutine calculate_density_derivs_elem_linear !> This subroutine calculates the five, partial second derivatives of density w.r.t. !! potential temperature and salinity and pressure which for a linear equation of state should all be 0. -subroutine calculate_density_second_derivs_scalar_linear(T, S, pressure, drho_dS_dS, drho_dS_dT, & - drho_dT_dT, drho_dS_dP, drho_dT_dP) - 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_dS_dS !< The second derivative of density with - !! salinity [kg m-3 PSU-2]. - real, intent(out) :: drho_dS_dT !< The second derivative of density with - !! temperature and salinity [kg m-3 ppt-1 degC-1]. - real, intent(out) :: drho_dT_dT !< The second derivative of density with - !! temperature [kg m-3 degC-2]. - real, intent(out) :: drho_dS_dP !< The second derivative of density with - !! salinity and pressure [kg m-3 PSU-1 Pa-1]. - real, intent(out) :: drho_dT_dP !< The second derivative of density with - !! temperature and pressure [kg m-3 degC-1 Pa-1]. +elemental subroutine calculate_density_second_derivs_elem_linear(this, T, S, pressure, & + drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) + class(linear_EOS), intent(in) :: this !< This EOS + 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(inout) :: drho_dS_dS !< The second derivative of density with + !! salinity [kg m-3 PSU-2]. + real, intent(inout) :: drho_dS_dT !< The second derivative of density with + !! temperature and salinity [kg m-3 ppt-1 degC-1]. + real, intent(inout) :: drho_dT_dT !< The second derivative of density with + !! temperature [kg m-3 degC-2]. + real, intent(inout) :: drho_dS_dP !< The second derivative of density with + !! salinity and pressure [kg m-3 PSU-1 Pa-1]. + real, intent(inout) :: drho_dT_dP !< The second derivative of density with + !! temperature and pressure [kg m-3 degC-1 Pa-1]. drho_dS_dS = 0. drho_dS_dT = 0. @@ -226,98 +157,46 @@ subroutine calculate_density_second_derivs_scalar_linear(T, S, pressure, drho_dS drho_dS_dP = 0. drho_dT_dP = 0. -end subroutine calculate_density_second_derivs_scalar_linear - -!> This subroutine calculates the five, partial second derivatives of density w.r.t. -!! potential temperature and salinity and pressure which for a linear equation of state should all be 0. -subroutine calculate_density_second_derivs_array_linear(T, S,pressure, drho_dS_dS, drho_dS_dT, drho_dT_dT,& - drho_dS_dP, drho_dT_dP, 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) :: pressure !< pressure [Pa]. - real, dimension(:), intent(out) :: drho_dS_dS !< The second derivative of density with - !! salinity [kg m-3 PSU-2]. - real, dimension(:), intent(out) :: drho_dS_dT !< The second derivative of density with - !! temperature and salinity [kg m-3 ppt-1 degC-1]. - real, dimension(:), intent(out) :: drho_dT_dT !< The second derivative of density with - !! temperature [kg m-3 degC-2]. - real, dimension(:), intent(out) :: drho_dS_dP !< The second derivative of density with - !! salinity and pressure [kg m-3 PSU-1 Pa-1]. - real, dimension(:), intent(out) :: drho_dT_dP !< The second derivative of density with - !! temperature and pressure [kg m-3 degC-1 Pa-1]. - integer, intent(in) :: start !< The starting point in the arrays. - integer, intent(in) :: npts !< The number of values to calculate. - ! Local variables - integer :: j - do j=start,start+npts-1 - drho_dS_dS(j) = 0. - drho_dS_dT(j) = 0. - drho_dT_dT(j) = 0. - drho_dS_dP(j) = 0. - drho_dT_dP(j) = 0. - enddo - -end subroutine calculate_density_second_derivs_array_linear +end subroutine calculate_density_second_derivs_elem_linear !> Calculate the derivatives of specific volume with temperature and salinity -subroutine calculate_specvol_derivs_linear(T, S, pressure, dSV_dT, dSV_dS, & - start, npts, Rho_T0_S0, dRho_dT, dRho_dS) - 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(:) :: dSV_dS !< The partial derivative of specific volume with - !! salinity [m3 kg-1 PSU-1]. - real, intent(out), dimension(:) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature [m3 kg-1 degC-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]. +elemental subroutine calculate_specvol_derivs_elem_linear(this, T, S, pressure, dSV_dT, dSV_dS) + class(linear_EOS), intent(in) :: this !< This EOS + real, intent(in) :: T !< Potential temperature [degC] + real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: pressure !< pressure [Pa] + real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with + !! salinity [m3 kg-1 PSU-1] + real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with + !! potential temperature [m3 kg-1 degC-1] ! Local variables real :: I_rho2 - integer :: j - do j=start,start+npts-1 - ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j)) - I_rho2 = 1.0 / (Rho_T0_S0 + (dRho_dT*T(j) + dRho_dS*S(j)))**2 - dSV_dT(j) = -dRho_dT * I_rho2 - dSV_dS(j) = -dRho_dS * I_rho2 - enddo + ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T + dRho_dS*S) + I_rho2 = 1.0 / (this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S))**2 + dSV_dT = -this%dRho_dT * I_rho2 + dSV_dS = -this%dRho_dS * I_rho2 -end subroutine calculate_specvol_derivs_linear +end subroutine calculate_specvol_derivs_elem_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, & - Rho_T0_S0, dRho_dT, dRho_dS) - 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]. - 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. - 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 +elemental subroutine calculate_compress_elem_linear(this, T, S, pressure, rho, drho_dp) + class(linear_EOS), intent(in) :: this !< This EOS + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure + !! (also the inverse of the square of sound speed) + !! [s2 m-2]. - do j=start,start+npts-1 - rho(j) = Rho_T0_S0 + dRho_dT*T(j) + dRho_dS*S(j) - drho_dp(j) = 0.0 - enddo -end subroutine calculate_compress_linear + rho = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S + drho_dp = 0.0 + +end subroutine calculate_compress_elem_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) @@ -345,7 +224,8 @@ 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. -subroutine EoS_fit_range_linear(T_min, T_max, S_min, S_max, p_min, p_max) +subroutine EoS_fit_range_linear(this, T_min, T_max, S_min, S_max, p_min, p_max) + class(linear_EOS), intent(in) :: this !< This EOS 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] @@ -362,6 +242,21 @@ subroutine EoS_fit_range_linear(T_min, T_max, S_min, S_max, p_min, p_max) end subroutine EoS_fit_range_linear +!> Set coefficients for the linear equation of state +subroutine set_params_linear(this, Rho_T0_S0, dRho_dT, dRho_dS) + class(linear_EOS), intent(inout) :: this !< This EOS + real, optional, intent(in) :: Rho_T0_S0 !< The density at T=0, S=0 [kg m-3] + real, optional, intent(in) :: dRho_dT !< The derivative of density with temperature, + !! [kg m-3 degC-1] + real, optional, intent(in) :: dRho_dS !< The derivative of density with salinity, + !! in [kg m-3 ppt-1] + + if (present(Rho_T0_S0)) this%Rho_T0_S0 = Rho_T0_S0 + if (present(dRho_dT)) this%dRho_dT = dRho_dT + if (present(dRho_dS)) this%dRho_dS = dRho_dS + +end subroutine set_params_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. @@ -715,4 +610,56 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & enddo ; enddo ; endif end subroutine int_spec_vol_dp_linear +!> Calculate the in-situ density for 1D arraya inputs and outputs. +subroutine calculate_density_array_linear(this, T, S, pressure, rho, start, npts, rho_ref) + class(linear_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(rho_ref)) then + do j = start, start+npts-1 + rho(j) = density_anomaly_elem_linear(this, T(j), S(j), pressure(j), rho_ref) + enddo + else + do j = start, start+npts-1 + rho(j) = density_elem_linear(this, T(j), S(j), pressure(j)) + enddo + endif + +end subroutine calculate_density_array_linear + +!> Calculate the in-situ specific volume for 1D array inputs and outputs. +subroutine calculate_spec_vol_array_linear(this, T, S, pressure, specvol, start, npts, spv_ref) + class(linear_EOS), intent(in) :: this !< This EOS + 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 + integer :: j + + if (present(spv_ref)) then + do j = start, start+npts-1 + specvol(j) = spec_vol_anomaly_elem_linear(this, T(j), S(j), pressure(j), spv_ref) + enddo + else + do j = start, start+npts-1 + specvol(j) = spec_vol_elem_linear(this, T(j), S(j), pressure(j) ) + enddo + endif + +end subroutine calculate_spec_vol_array_linear + end module MOM_EOS_linear diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index bbca7ca9d6..fa45f9ed79 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -10,7 +10,7 @@ module MOM_neutral_diffusion use MOM_diag_mediator, only : post_data, register_diag_field use MOM_EOS, only : EOS_type, EOS_manual_init, EOS_domain use MOM_EOS, only : calculate_density, calculate_density_derivs -use MOM_EOS, only : extract_member_EOS, EOS_LINEAR, EOS_TEOS10, EOS_WRIGHT +use MOM_EOS, only : EOS_LINEAR use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_file_parser, only : openParameterBlock, closeParameterBlock From 7cc191a6f0d3cdc86c6007b94d41939ebf6879e7 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Wed, 15 Nov 2023 12:34:03 -0500 Subject: [PATCH 484/629] Add rule and workflow to compare results of micro-timing tests - Added rules to .testing/Makefile to invoke build.timing, run.timing for the "target" code checked out for regression tests - Appended to existing GH "perfmon" workflow --- .github/workflows/perfmon.yml | 22 ++++++++++++++++++++++ .testing/Makefile | 19 ++++++++++++++++++- 2 files changed, 40 insertions(+), 1 deletion(-) diff --git a/.github/workflows/perfmon.yml b/.github/workflows/perfmon.yml index 76140c9469..8fd314cee3 100644 --- a/.github/workflows/perfmon.yml +++ b/.github/workflows/perfmon.yml @@ -40,10 +40,26 @@ jobs: sudo sysctl -w kernel.perf_event_paranoid=2 make perf DO_REGRESSION_TESTS=true + # This job assumes that build/target_codebase was cloned above + - name: Compile timing tests for reference code + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j build.timing_target + MOM_TARGET_SLUG=$GITHUB_REPOSITORY + MOM_TARGET_LOCAL_BRANCH=$GITHUB_BASE_REF + DO_REGRESSION_TESTS=true + - name: Compile timing tests run: | make -j build.timing + # DO_REGERESSION_TESTS=true is needed here to set the internal macro TARGET_CODEBASE + - name: Run timing tests for reference code + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j run.timing_target + DO_REGRESSION_TESTS=true + - name: Run timing tests run: | make -j run.timing @@ -51,3 +67,9 @@ jobs: - name: Display timing results run: | make -j show.timing + + - name: Display comparison of timing results + if: ${{ github.event_name == 'pull_request' }} + run: >- + make -j compare.timing + DO_REGRESSION_TESTS=true diff --git a/.testing/Makefile b/.testing/Makefile index aabe51c8b6..f7101a3463 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -217,7 +217,6 @@ endif FMS_SOURCE = $(call SOURCE,deps/fms/src) - #--- # Rules @@ -684,6 +683,24 @@ show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) $(WORKSPACE)/work/timing/%.show: ./tools/disp_timing.py $(@:.show=.out) +# Invoke the above unit/timing rules for a "target" code +# Invoke with appropriate macros defines, i.e. +# make build.timing_target MOM_TARGET_URL=... MOM_TARGET_BRANCH=... TARGET_CODEBASE=build/target_codebase +# make run.timing_target TARGET_CODEBASE=build/target_codebase + +TIMING_TARGET_EXECS ?= $(basename $(notdir $(wildcard $(TARGET_CODEBASE)/config_src/drivers/timing_tests/*.F90) ) ) + +.PHONY: build.timing_target +build.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/build/timing/$(f)) +.PHONY: run.timing_target +run.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/work/timing/$(f).out) +.PHONY: compare.timing +compare.timing: $(foreach f, $(filter $(TIMING_EXECS),$(TIMING_TARGET_EXECS)), work/timing/$(f).compare) +$(WORKSPACE)/work/timing/%.compare: $(TARGET_CODEBASE) + ./tools/disp_timing.py -r $(TARGET_CODEBASE)/.testing/$(@:.compare=.out) $(@:.compare=.out) +$(TARGET_CODEBASE)/.testing/%: | $(TARGET_CODEBASE) + cd $(TARGET_CODEBASE)/.testing && make $* + # General rule to run a unit test executable # Pattern is to run build/unit/executable and direct output to executable.out $(WORKSPACE)/work/unit/%.out: build/unit/% From 34b880faa5e4528208b3becfaacbed9e1d4a5841 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Nov 2023 08:00:03 -0500 Subject: [PATCH 485/629] Add units to comments in MOM_neutral_diffusion Added or corrected the units in comments describing about 200 real variables in MOM_hor_bnd_diffusion and MOM_neutral_diffusion, and corrected spelling errors or other issues in about another 20 comments. Only comments are changed and all answers are bitwise identical. --- src/tracer/MOM_hor_bnd_diffusion.F90 | 94 ++++--- src/tracer/MOM_neutral_diffusion.F90 | 392 +++++++++++++++++---------- 2 files changed, 302 insertions(+), 184 deletions(-) diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 4f6f198ff8..163d8a480f 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -32,7 +32,7 @@ module MOM_hor_bnd_diffusion public boundary_k_range, hor_bnd_diffusion_end ! Private parameters to avoid doing string comparisons for bottom or top boundary layer -integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface bopundary +integer, public, parameter :: SURFACE = -1 !< Set a value that corresponds to the surface boundary integer, public, parameter :: BOTTOM = 1 !< Set a value that corresponds to the bottom boundary #include @@ -53,7 +53,7 @@ module MOM_hor_bnd_diffusion !! 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. ! HBD dynamic grids - real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjecent to + real, allocatable, dimension(:,:,:) :: hbd_grd_u !< HBD thicknesses at t-points adjacent to !! u-points [H ~> m or kg m-2] real, allocatable, dimension(:,:,:) :: hbd_grd_v !< HBD thicknesses at t-points adjacent to !! v-points (left and right) [H ~> m or kg m-2] @@ -182,11 +182,19 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) !! [conc H L2 ~> conc m3 or conc kg] real, dimension(SZI_(G),SZJB_(G)) :: vwork_2d !< Layer summed v-flux transport !! [conc H L2 ~> conc m3 or conc kg] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostic [conc T-1 ~> conc s-1] - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagn - type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency !< tendency array for diagnostics at first in + !! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1], + !! then converted to [conc T-1 ~> conc s-1]. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] and + ! then [C T-1 ~> degC s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d !< depth integrated content tendency for diagnostics in + !! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1]. + !! For temperature these units are + !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + type(tracer_type), pointer :: tracer => NULL() !< Pointer to the current tracer [conc] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tracer_old !< local copy of the initial tracer concentration, - !! only used to compute tendencies. + !! only used to compute tendencies [conc]. real :: tracer_int_prev !< Globally integrated tracer before HBD is applied, in mks units [conc kg] real :: tracer_int_end !< Integrated tracer after HBD is applied, in mks units [conc kg] real :: Idt !< inverse of the time step [T-1 ~> s-1] @@ -323,7 +331,7 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) end subroutine hor_bnd_diffusion -!> Build the HBD grid where tracers will be rammaped to. +!> Build the HBD grid where tracers will be remapped to. subroutine hbd_grid(boundary, G, GV, hbl, h, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] type(ocean_grid_type), intent(inout) :: G !< Grid type @@ -393,8 +401,8 @@ end subroutine hbd_grid !> Calculate the harmonic mean of two quantities !! See \ref section_harmonic_mean. real function harmonic_mean(h1,h2) - real :: h1 !< Scalar quantity - real :: h2 !< Scalar quantity + real :: h1 !< Scalar quantity [arbitrary] + real :: h2 !< Scalar quantity [arbitrary] if (h1 + h2 == 0.) then harmonic_mean = 0. else @@ -407,10 +415,10 @@ end function harmonic_mean integer function find_minimum(x, s, e) integer, intent(in) :: s !< start index integer, intent(in) :: e !< end index - real, dimension(e), intent(in) :: x !< 1D array to be checked + real, dimension(e), intent(in) :: x !< 1D array to be checked [arbitrary] ! local variables - real :: minimum + real :: minimum ! Minimum value in the same units as x [arbitrary] integer :: location integer :: i @@ -427,11 +435,11 @@ end function find_minimum !> Swaps the values of its two formal arguments. subroutine swap(a, b) - real, intent(inout) :: a !< First value to be swaped - real, intent(inout) :: b !< Second value to be swaped + real, intent(inout) :: a !< First value to be swapped [arbitrary] + real, intent(inout) :: b !< Second value to be swapped [arbitrary] ! local variables - real :: tmp + real :: tmp ! A temporary copy of a [arbitrary] tmp = a a = b @@ -440,8 +448,8 @@ end subroutine swap !> Receives a 1D array x and sorts it into ascending order. subroutine sort(x, n) - integer, intent(in ) :: n !< # of pts in the array - real, dimension(n), intent(inout) :: x !< 1D array to be sorted + integer, intent(in ) :: n !< Number of points in the array + real, dimension(n), intent(inout) :: x !< 1D array to be sorted [arbitrary] ! local variables integer :: i, location @@ -454,15 +462,15 @@ end subroutine sort !> Returns the unique values in a 1D array. subroutine unique(val, n, val_unique, val_max) - integer, intent(in ) :: n !< # of pts in the array. - real, dimension(n), intent(in ) :: val !< 1D array to be checked. - real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values. + integer, intent(in ) :: n !< Number of points in the array. + real, dimension(n), intent(in ) :: val !< 1D array to be checked [arbitrary] + real, dimension(:), allocatable, intent(inout) :: val_unique !< Returned 1D array with unique values [arbitrary] real, optional, intent(in ) :: val_max !< sets the maximum value in val_unique to - !! this value. + !! this value [arbitrary] ! local variables - real, dimension(n) :: tmp + real, dimension(n) :: tmp ! The list of unique values [arbitrary] integer :: i, j, ii - real :: min_val, max_val + real :: min_val, max_val ! The minimum and maximum values in the list [arbitrary] logical :: limit limit = .false. @@ -510,12 +518,14 @@ subroutine merge_interfaces(nk, h_L, h_R, hbl_L, hbl_R, H_subroundoff, h) ! Local variables integer :: n !< Number of layers in eta_all - real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right coloumns - real, dimension(:), allocatable :: eta_all !< Combined interfaces in the left/right columns + hbl_L and hbl_R - real, dimension(:), allocatable :: eta_unique !< Combined interfaces (eta_L, eta_R), possibly hbl_L and hbl_R - real :: min_depth !< Minimum depth - real :: max_depth !< Maximum depth - real :: max_bld !< Deepest BLD + real, dimension(nk+1) :: eta_L, eta_R!< Interfaces in the left and right columns [H ~> m or kg m-2] + real, dimension(:), allocatable :: eta_all !< Combined list of interfaces in the left and right columns + !! plus hbl_L and hbl_R [H ~> m or kg m-2] + real, dimension(:), allocatable :: eta_unique !< Combined list of unique interfaces (eta_L, eta_R), possibly + !! hbl_L and hbl_R [H ~> m or kg m-2] + real :: min_depth !< Minimum depth [H ~> m or kg m-2] + real :: max_depth !< Maximum depth [H ~> m or kg m-2] + real :: max_bld !< Deepest BLD [H ~> m or kg m-2] integer :: k, kk, nk1 !< loop indices (k and kk) and array size (nk1) n = (2*nk)+3 @@ -564,7 +574,7 @@ subroutine flux_limiter(F_layer, area_L, area_R, phi_L, phi_R, h_L, h_R) real, intent(in) :: phi_R !< Tracer concentration in the right cell [conc] ! local variables - real :: F_max !< maximum flux allowed + real :: F_max !< maximum flux allowed [conc H L2 ~> conc m3 or conc kg] ! limit the flux to 0.2 of the tracer *gradient* ! Why 0.2? ! t=0 t=inf @@ -723,7 +733,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ ! thicknesses at velocity points & khtr_u at layer centers do k = 1,ke h_vel(k) = harmonic_mean(h_L(k), h_R(k)) - ! GMM, writting 0.5 * (A(k) + A(k+1)) as A(k) + 0.5 * (A(k+1) - A(k)) to recover + ! GMM, writing 0.5 * (A(k) + A(k+1)) as A(k) + 0.5 * (A(k+1) - A(k)) to recover ! answers with depth-independent khtr khtr_ul(k) = khtr_u(k) + 0.5 * (khtr_u(k+1) - khtr_u(k)) enddo @@ -741,7 +751,7 @@ subroutine fluxes_layer_method(boundary, ke, hbl_L, hbl_R, h_L, h_R, phi_L, phi_ k_bot_max = MAX(k_bot_L, k_bot_R) k_bot_diff = (k_bot_max - k_bot_min) - ! tracer flux where the minimum BLD intersets layer + ! tracer flux where the minimum BLD intersects layer if ((CS%linear) .and. (k_bot_diff > 1)) then ! apply linear decay at the base of hbl do k = k_bot_min,1,-1 @@ -815,7 +825,7 @@ logical function near_boundary_unit_tests( verbose ) ! Local variables integer, parameter :: nk = 2 ! Number of layers real, dimension(nk+1) :: eta1 ! Updated interfaces with one extra value [m] - real, dimension(:), allocatable :: h1 ! Upates layer thicknesses [m] + real, dimension(:), allocatable :: h1 ! Updated list of layer thicknesses or other field [m] or [arbitrary] real, dimension(nk) :: phi_L, phi_R ! Tracer values (left and right column) [conc] real, dimension(nk) :: h_L, h_R ! Layer thickness (left and right) [m] real, dimension(nk+1) :: khtr_u ! Horizontal diffusivities at U-point and interfaces[m2 s-1] @@ -823,9 +833,9 @@ logical function near_boundary_unit_tests( verbose ) real, dimension(nk) :: F_layer ! Diffusive flux within each layer at U-point [conc m3 s-1] character(len=120) :: test_name ! Title of the unit test integer :: k_top ! Index of cell containing top of boundary - real :: zeta_top ! Nondimension position [nondim] + real :: zeta_top ! Fractional position in the cell of the top [nondim] integer :: k_bot ! Index of cell containing bottom of boundary - real :: zeta_bot ! Nondimension position [nondim] + real :: zeta_bot ! Fractional position in the cell of the bottom [nondim] type(hbd_CS), pointer :: CS allocate(CS) @@ -1058,8 +1068,8 @@ logical function test_layer_fluxes(verbose, nk, test_name, F_calc, F_ans) logical, intent(in) :: verbose !< If true, write results to stdout character(len=80), intent(in) :: test_name !< Brief description of the unit test integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: F_calc !< Fluxes of the unitless tracer from the algorithm [s^-1] - real, dimension(nk), intent(in) :: F_ans !< Fluxes of the unitless tracer calculated by hand [s^-1] + real, dimension(nk), intent(in) :: F_calc !< Fluxes or other quantity from the algorithm [arbitrary] + real, dimension(nk), intent(in) :: F_ans !< Expected value calculated by hand [arbitrary] ! Local variables integer :: k @@ -1081,13 +1091,13 @@ end function test_layer_fluxes logical function test_boundary_k_range(k_top, zeta_top, k_bot, zeta_bot, k_top_ans, zeta_top_ans,& k_bot_ans, zeta_bot_ans, test_name, verbose) integer :: k_top !< Index of cell containing top of boundary - real :: zeta_top !< Nondimension position + real :: zeta_top !< Fractional position in the cell of the top boundary [nondim] integer :: k_bot !< Index of cell containing bottom of boundary - real :: zeta_bot !< Nondimension position - integer :: k_top_ans !< Index of cell containing top of boundary - real :: zeta_top_ans !< Nondimension position - integer :: k_bot_ans !< Index of cell containing bottom of boundary - real :: zeta_bot_ans !< Nondimension position + real :: zeta_bot !< Fractional position in the cell of the bottom boundary [nondim] + integer :: k_top_ans !< Expected index of cell containing top of boundary + real :: zeta_top_ans !< Expected fractional position of the top boundary [nondim] + integer :: k_bot_ans !< Expected index of cell containing bottom of boundary + real :: zeta_bot_ans !< Expected fractional position of the bottom boundary [nondim] character(len=80) :: test_name !< Name of the unit test logical :: verbose !< If true always print output diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index fa45f9ed79..87a8881b10 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -63,9 +63,9 @@ module MOM_neutral_diffusion real, allocatable, dimension(:,:) :: hbl !< Boundary layer depth [H ~> m or kg m-2] ! Coefficients used to apply tapering from neutral to horizontal direction real, allocatable, dimension(:) :: coeff_l !< Non-dimensional coefficient in the left column, - !! at cell interfaces + !! at cell interfaces [nondim] real, allocatable, dimension(:) :: coeff_r !< Non-dimensional coefficient in the right column, - !! at cell interfaces + !! at cell interfaces [nondim] ! Array used when KhTh_use_ebt_struct is true real, allocatable, dimension(:,:,:) :: Coef_h !< Coef_x and Coef_y averaged at t-points [L2 ~> m2] ! Positions of neutral surfaces in both the u, v directions @@ -84,8 +84,10 @@ module MOM_neutral_diffusion !! at a v-point real, allocatable, dimension(:,:,:) :: vHeff !< Effective thickness at v-point [H ~> m or kg m-2] ! Coefficients of polynomial reconstructions for temperature and salinity - real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients for temperature - real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients for salinity + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_T !< Polynomial coefficients of the + !! sub-gridscale temperatures [C ~> degC] + real, allocatable, dimension(:,:,:,:) :: ppoly_coeffs_S !< Polynomial coefficients of the + !! sub-gridscale salinity [S ~> ppt] ! Variables needed for continuous reconstructions real, allocatable, dimension(:,:,:) :: dRdT !< dRho/dT [R C-1 ~> kg m-3 degC-1] at interfaces real, allocatable, dimension(:,:,:) :: dRdS !< dRho/dS [R S-1 ~> kg m-3 ppt-1] at interfaces @@ -335,7 +337,8 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state integer :: i, j, k ! Variables used for reconstructions - real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes + real, dimension(SZK_(GV),2) :: ppoly_r_S ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. real, dimension(SZI_(G), SZJ_(G)) :: hEff_sum ! Summed effective face thicknesses [H ~> m or kg m-2] integer :: iMethod real, dimension(SZI_(G)) :: ref_pres ! Reference pressure used to calculate alpha/beta [R L2 T-2 ~> Pa] @@ -589,24 +592,38 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(in) :: Coef_x !< dt * Kh * dy / dx at u-points [L2 ~> m2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(in) :: Coef_y !< dt * Kh * dx / dy at v-points [L2 ~> m2] real, intent(in) :: dt !< Tracer time step * I_numitts [T ~> s] - !! (I_numitts in tracer_hordiff) + !! (I_numitts is in tracer_hordiff) type(tracer_registry_type), pointer :: Reg !< Tracer registry type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables - real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer [H conc ~> m conc or conc kg m-2] - real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer - ! [H conc ~> m conc or conc kg m-2] + real, dimension(SZIB_(G),SZJ_(G),CS%nsurf-1) :: uFlx ! Zonal flux of tracer in units that vary between a + ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a + ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), + ! depending on the setting of CS%KhTh_use_ebt_struct. + real, dimension(SZI_(G),SZJB_(G),CS%nsurf-1) :: vFlx ! Meridional flux of tracer in units that vary between a + ! thickness times a concentration ([C H ~> degC m or degC kg m-2] for temperature) or a + ! volume or mass times a concentration ([C H L2 ~> degC m3 or degC kg] for temperature), + ! depending on the setting of CS%KhTh_use_ebt_struct. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tendency ! tendency array for diagnostics ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1] - real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! depth integrated content tendency for diagn - ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1] - real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! depth integrated diffusive tracer x-transport diagn - real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport diagn - real, dimension(SZK_(GV)) :: dTracer ! change in tracer concentration due to ndiffusion - ! [H L2 conc ~> m3 conc or kg conc] - real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZI_(G),SZJ_(G)) :: tendency_2d ! Depth integrated content tendency for diagnostics + ! [H conc T-1 ~> m conc s-1 or kg m-2 conc s-1]. + ! For temperature these units are + ! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1]. + real, dimension(SZIB_(G),SZJ_(G)) :: trans_x_2d ! Depth integrated diffusive tracer x-transport + ! diagnostic. For temperature this has units of + ! [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZI_(G),SZJB_(G)) :: trans_y_2d ! depth integrated diffusive tracer y-transport + ! diagnostic. For temperature this has units of + ! [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZK_(GV)) :: dTracer ! Change in tracer concentration due to neutral diffusion + ! [H L2 conc ~> m3 conc or kg conc]. For temperature + ! these units are [C H L2 ~> degC m3 or degC kg]. + real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points [nondim]. type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer @@ -950,12 +967,12 @@ subroutine compute_tapering_coeffs(ne, bld_l, bld_r, coeff_l, coeff_r, h_l, h_r) ! Local variables real :: min_bld, max_bld ! Min/Max boundary layer depth in two adjacent columns integer :: dummy1 ! dummy integer - real :: dummy2 ! dummy real + real :: dummy2 ! dummy real [nondim] integer :: k_min_l, k_min_r, k_max_l, k_max_r ! Min/max vertical indices in two adjacent columns - real :: zeta_l, zeta_r ! dummy variables + real :: zeta_l, zeta_r ! dummy variables [nondim] integer :: k ! vertical index - ! initialize coeffs + ! Initialize coefficients coeff_l(:) = 1.0 coeff_r(:) = 1.0 @@ -996,15 +1013,19 @@ end subroutine compute_tapering_coeffs subroutine interface_scalar(nk, h, S, Si, i_method, h_neglect) integer, intent(in) :: nk !< Number of levels real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(nk), intent(in) :: S !< Layer scalar (conc, e.g. ppt) - real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (conc, e.g. ppt) + real, dimension(nk), intent(in) :: S !< Layer scalar (or concentrations) in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk+1), intent(inout) :: Si !< Interface scalar (or concentrations) in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) integer, intent(in) :: i_method !< =1 use average of PLM edges !! =2 use continuous PPM edge interpolation real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] ! Local variables integer :: k, km2, kp1 - real, dimension(nk) :: diff - real :: Sb, Sa + real, dimension(nk) :: diff ! Difference in scalar concentrations between layer centers in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real :: Sb, Sa ! Values of scalar concentrations at the upper and lower edges of a layer in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) call PLM_diff(nk, h, S, 2, 1, diff) Si(1) = S(1) - 0.5 * diff(1) @@ -1032,18 +1053,24 @@ end subroutine interface_scalar !> Returns the PPM quasi-fourth order edge value at k+1/2 following !! equation 1.6 in Colella & Woodward, 1984: JCP 54, 174-201. real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) - real, intent(in) :: hkm1 !< Width of cell k-1 - real, intent(in) :: hk !< Width of cell k - real, intent(in) :: hkp1 !< Width of cell k+1 - real, intent(in) :: hkp2 !< Width of cell k+2 - real, intent(in) :: Ak !< Average scalar value of cell k - real, intent(in) :: Akp1 !< Average scalar value of cell k+1 - real, intent(in) :: Pk !< PLM slope for cell k - real, intent(in) :: Pkp1 !< PLM slope for cell k+1 + real, intent(in) :: hkm1 !< Width of cell k-1 in [H ~> m or kg m-2] or other units + real, intent(in) :: hk !< Width of cell k in [H ~> m or kg m-2] or other units + real, intent(in) :: hkp1 !< Width of cell k+1 in [H ~> m or kg m-2] or other units + real, intent(in) :: hkp2 !< Width of cell k+2 in [H ~> m or kg m-2] or other units + real, intent(in) :: Ak !< Average scalar value of cell k in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Akp1 !< Average scalar value of cell k+1 in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Pk !< PLM slope for cell k in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Pkp1 !< PLM slope for cell k+1 in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) real, intent(in) :: h_neglect !< A negligibly small thickness [H ~> m or kg m-2] ! Local variables - real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1, f1, f2, f3, f4 + real :: R_hk_hkp1, R_2hk_hkp1, R_hk_2hkp1 ! Reciprocals of combinations of thicknesses [H-1 ~> m-1 or m2 kg-1] + real :: f1 ! A work variable with units of an inverse cell width [H-1 ~> m-1 or m2 kg-1] + real :: f2, f3, f4 ! Work variables with units of the cell width [H ~> m or kg m-2] R_hk_hkp1 = hk + hkp1 if (R_hk_hkp1 <= 0.) then @@ -1069,17 +1096,23 @@ real function ppm_edge(hkm1, hk, hkp1, hkp2, Ak, Akp1, Pk, Pkp1, h_neglect) end function ppm_edge -!> Returns the average of a PPM reconstruction between two -!! fractional positions. +!> Returns the average of a PPM reconstruction between two fractional positions in the same +!! arbitrary concentration units as aMean (e.g. usually [C ~> degC] for temperature) real function ppm_ave(xL, xR, aL, aR, aMean) - real, intent(in) :: xL !< Fraction position of left bound (0,1) - real, intent(in) :: xR !< Fraction position of right bound (0,1) - real, intent(in) :: aL !< Left edge scalar value, at x=0 - real, intent(in) :: aR !< Right edge scalar value, at x=1 - real, intent(in) :: aMean !< Average scalar value of cell + real, intent(in) :: xL !< Fraction position of left bound (0,1) [nondim] + real, intent(in) :: xR !< Fraction position of right bound (0,1) [nondim] + real, intent(in) :: aL !< Left edge scalar value, at x=0, in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + real, intent(in) :: aR !< Right edge scalar value, at x=1 in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) + real, intent(in) :: aMean !< Average scalar value of cell in arbitrary concentration + !! units (e.g. usually [C ~> degC] for temperature) ! Local variables - real :: dx, xave, a6, a6o3 + real :: dx ! Distance between the bounds [nondim] + real :: xave ! Average fractional position [nondim] + real :: a6, a6o3 ! Terms proportional to the normalized scalar curvature in the same arbitrary + ! concentration units as aMean (e.g. usually [C ~> degC] for temperature) dx = xR - xL xave = 0.5 * ( xR + xL ) @@ -1098,9 +1131,10 @@ real function ppm_ave(xL, xR, aL, aR, aMean) end function ppm_ave !> A true signum function that returns either -abs(a), when x<0; or abs(a) when x>0; or 0 when x=0. +!! The returned units are the same as those of a [arbitrary]. real function signum(a,x) - real, intent(in) :: a !< The magnitude argument - real, intent(in) :: x !< The sign (or zero) argument + real, intent(in) :: a !< The magnitude argument in arbitrary units [arbitrary] + real, intent(in) :: x !< The sign (or zero) argument [arbitrary] signum = sign(a,x) if (x==0.) signum = 0. @@ -1111,11 +1145,13 @@ end function signum !! The limiting follows equation 1.8 in Colella & Woodward, 1984: JCP 54, 174-201. subroutine PLM_diff(nk, h, S, c_method, b_method, diff) integer, intent(in) :: nk !< Number of levels - real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] - real, dimension(nk), intent(in) :: S !< Layer salinity (conc, e.g. ppt) + real, dimension(nk), intent(in) :: h !< Layer thickness [H ~> m or kg m-2] or other units + real, dimension(nk), intent(in) :: S !< Layer salinity (conc, e.g. ppt) or other tracer + !! concentration in arbitrary units [A ~> a] integer, intent(in) :: c_method !< Method to use for the centered difference integer, intent(in) :: b_method !< =1, use PCM in first/last cell, =2 uses linear extrapolation real, dimension(nk), intent(inout) :: diff !< Scalar difference across layer (conc, e.g. ppt) + !! in the same arbitrary units as S [A ~> a], !! determined by the following values for c_method: !! 1. Second order finite difference (not recommended) !! 2. Second order finite volume (used in original PPM) @@ -1125,7 +1161,9 @@ subroutine PLM_diff(nk, h, S, c_method, b_method, diff) ! Local variables integer :: k - real :: hkm1, hk, hkp1, Skm1, Sk, Skp1, diff_l, diff_r, diff_c + real :: hkm1, hk, hkp1 ! Successive layer thicknesses [H ~> m or kg m-2] or other units + real :: Skm1, Sk, Skp1 ! Successive layer tracer concentrations in the same arbitrary units as S [A ~> a] + real :: diff_l, diff_r, diff_c ! Differences in tracer concentrations in arbitrary units [A ~> a] do k = 2, nk-1 hkm1 = h(k-1) @@ -1144,7 +1182,7 @@ subroutine PLM_diff(nk, h, S, c_method, b_method, diff) diff_c = 0. endif elseif (c_method==2) then - ! Second order accurate centered FV slope (from Colella and Woodward, JCP 1984) + ! Second order accurate centered finite-volume slope (from Colella and Woodward, JCP 1984) diff_c = fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) elseif (c_method==3) then ! Second order accurate finite-volume least squares slope @@ -1177,15 +1215,19 @@ end subroutine PLM_diff !! as a difference across the central cell (i.e. units of scalar S). !! Discretization follows equation 1.7 in Colella & Woodward, 1984: JCP 54, 174-201. real function fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value + real, intent(in) :: hkm1 !< Left cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hk !< Center cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hkp1 !< Right cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: Skm1 !< Left cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Sk !< Center cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Skp1 !< Right cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) ! Local variables - real :: h_sum, hp, hm + real :: h_sum, hp, hm ! At first sums of thicknesses [H ~> m or kg m-2], then changed into + ! their reciprocals [H-1 ~> m-1 or m2 kg-1] h_sum = ( hkm1 + hkp1 ) + hk if (h_sum /= 0.) h_sum = 1./ h_sum @@ -1200,19 +1242,30 @@ end function fv_diff !> Returns the cell-centered second-order weighted least squares slope -!! using three consecutive cell widths and average values. Slope is returned -!! as a gradient (i.e. units of scalar S over width units). +!! using three consecutive cell widths and average values. Slope is returned +!! as a gradient (i.e. units of scalar S over width units). For example, for temperature +!! fvlsq_slope would usually be returned in units of [C H-1 ~> degC m-1 or degC m2 kg-1]. real function fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value + real, intent(in) :: hkm1 !< Left cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hk !< Center cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: hkp1 !< Right cell width [H ~> m or kg m-2] or other arbitrary units + real, intent(in) :: Skm1 !< Left cell average value in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Sk !< Center cell average value often in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, intent(in) :: Skp1 !< Right cell average value often in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) ! Local variables - real :: xkm1, xkp1 - real :: h_sum, hx_sum, hxsq_sum, hxy_sum, hy_sum, det + real :: xkm1, xkp1 ! Distances between layer centers [H ~> m or kg m-2] or other arbitrary units + real :: h_sum ! Sum of the successive cell widths [H ~> m or kg m-2] or other arbitrary units + real :: hx_sum ! Thicknesses times distances [H2 ~> m2 or kg2 m-4] + real :: hxsq_sum ! Thicknesses times squared distances [H3 ~> m3 or kg3 m-6] + real :: det ! The denominator in the weighted slope calculation [H4 ~> m4 or kg4 m-8] + real :: hxy_sum ! Sum of layer concentrations times thicknesses and distances in units that + ! depend on those of Sk (e.g. [C H2 ~> degC m2 or degC kg2 m-4] for temperature) + real :: hy_sum ! Sum of layer concentrations times thicknesses in units that depend on + ! those of Sk (e.g. [C H ~> degC m or degC kg m-2] for temperature) xkm1 = -0.5 * ( hk + hkm1 ) xkp1 = 0.5 * ( hk + hkp1 ) @@ -1255,8 +1308,8 @@ subroutine find_neutral_surface_positions_continuous(nk, Pl, Tl, Sl, dRdTl, dRdS !! [R L2 T-2 ~> Pa] or other units following Pl and Pr. integer, optional, intent(in) :: bl_kl !< Layer index of the boundary layer (left) integer, optional, intent(in) :: bl_kr !< Layer index of the boundary layer (right) - real, optional, intent(in) :: bl_zl !< Nondimensional position of the boundary layer (left) - real, optional, intent(in) :: bl_zr !< Nondimensional position of the boundary layer (right) + real, optional, intent(in) :: bl_zl !< Fractional position of the boundary layer (left) [nondim] + real, optional, intent(in) :: bl_zr !< Fractional position of the boundary layer (right) [nondim] ! Local variables integer :: ns ! Number of neutral surfaces @@ -2161,7 +2214,7 @@ function absolute_positions(n,ns,Pint,Karr,NParr) integer, intent(in) :: ns !< Number of neutral surfaces real, intent(in) :: Pint(n+1) !< Position of interface [R L2 T-2 ~> Pa] or other units integer, intent(in) :: Karr(ns) !< Indexes of interfaces about positions - real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) + real, intent(in) :: NParr(ns) !< Non-dimensional positions within layers Karr(:) [nondim] real, dimension(ns) :: absolute_positions !< Absolute positions [R L2 T-2 ~> Pa] !! or other units following Pint @@ -2184,47 +2237,83 @@ subroutine neutral_surface_flux(nk, nsurf, deg, hl, hr, Tl, Tr, PiL, PiR, KoL, K integer, intent(in) :: deg !< Degree of polynomial reconstructions real, dimension(nk), intent(in) :: hl !< Left-column layer thickness [H ~> m or kg m-2] real, dimension(nk), intent(in) :: hr !< Right-column layer thickness [H ~> m or kg m-2] - real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer (conc, e.g. degC) - real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer (conc, e.g. degC) + real, dimension(nk), intent(in) :: Tl !< Left-column layer tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk), intent(in) :: Tr !< Right-column layer tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) real, dimension(nsurf), intent(in) :: PiL !< Fractional position of neutral surface - !! within layer KoL of left column + !! within layer KoL of left column [nondim] real, dimension(nsurf), intent(in) :: PiR !< Fractional position of neutral surface - !! within layer KoR of right column + !! within layer KoR of right column [nondim] integer, dimension(nsurf), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(nsurf), intent(in) :: KoR !< Index of first right interface above neutral surface real, dimension(nsurf-1), intent(in) :: hEff !< Effective thickness between two neutral !! surfaces [H ~> m or kg m-2] real, dimension(nsurf-1), intent(inout) :: Flx !< Flux of tracer between pairs of neutral layers - !! (conc H or conc H L2) + !! in units (conc H or conc H L2) that depend on + !! the presence and units of coeff_l and coeff_r. + !! If the tracer is temperature, this could have + !! units of [C H ~> degC m or degC kg m-2] or + !! [C H L2 ~> degC m3 or degC kg] if coeff_l has + !! units of [L2 ~> m2] logical, intent(in) :: continuous !< True if using continuous reconstruction - real, intent(in) :: h_neglect !< A negligibly small width for the - !! purpose of cell reconstructions [H ~> m or kg m-2] + real, intent(in) :: h_neglect !< A negligibly small width for the purpose + !! of cell reconstructions [H ~> m or kg m-2] type(remapping_CS), optional, intent(in) :: remap_CS !< Remapping control structure used - !! to create sublayers - real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for - !! edge value calculations if continuous is false [H ~> m or kg m-2] - real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 ~> m2 or nondim] - real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 ~> m2 or nondim] + !! to create sublayers + real, optional, intent(in) :: h_neglect_edge !< A negligibly small width used for edge value + !! calculations if continuous is false [H ~> m or kg m-2] + real, dimension(nk+1), optional, intent(in) :: coeff_l !< Left-column diffusivity [L2 ~> m2] or [nondim] + real, dimension(nk+1), optional, intent(in) :: coeff_r !< Right-column diffusivity [L2 ~> m2] or [nondim] ! Local variables integer :: k_sublayer, klb, klt, krb, krt - real :: T_right_top, T_right_bottom, T_right_layer, T_right_sub, T_right_top_int, T_right_bot_int - real :: T_left_top, T_left_bottom, T_left_layer, T_left_sub, T_left_top_int, T_left_bot_int - real :: dT_top, dT_bottom, dT_layer, dT_ave, dT_sublayer, dT_top_int, dT_bot_int, khtr_ave - real, dimension(nk+1) :: Til !< Left-column interface tracer (conc, e.g. degC) - real, dimension(nk+1) :: Tir !< Right-column interface tracer (conc, e.g. degC) - real, dimension(nk) :: aL_l !< Left-column left edge value of tracer (conc, e.g. degC) - real, dimension(nk) :: aR_l !< Left-column right edge value of tracer (conc, e.g. degC) - real, dimension(nk) :: aL_r !< Right-column left edge value of tracer (conc, e.g. degC) - real, dimension(nk) :: aR_r !< Right-column right edge value of tracer (conc, e.g. degC) + real :: T_right_sub, T_left_sub ! Tracer concentrations averaged over sub-intervals in the right and left + ! columns in arbitrary concentration units (e.g. [C ~> degC] for temperature). + real :: T_right_layer, T_left_layer ! Tracer concentrations averaged over layers in the right and left + ! columns in arbitrary concentration units (e.g. [C ~> degC] for temperature). + real :: T_right_top, T_right_bottom, T_right_top_int, T_right_bot_int ! Tracer concentrations + ! at various positions in the right column in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: T_left_top, T_left_bottom, T_left_top_int, T_left_bot_int ! Tracer concentrations + ! at various positions in the left column in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: dT_layer, dT_ave, dT_sublayer ! Differences in vertically averaged tracer concentrations + ! over various portions of the right and left columns in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: dT_top, dT_bottom, dT_top_int, dT_bot_int ! Differences in tracer concentrations + ! at various positions between the right and left columns in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature). + real :: khtr_ave ! An averaged diffusivity in normalized units [nondim] if coeff_l and coeff_r are + ! absent or in units copied from coeff_l and coeff_r [L2 ~> m2] or [nondim] + real, dimension(nk+1) :: Til !< Left-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk+1) :: Tir !< Right-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aL_l !< Left-column left edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aR_l !< Left-column right edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aL_r !< Right-column left edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk) :: aR_r !< Right-column right edge value of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) ! Discontinuous reconstruction integer :: iMethod - real, dimension(nk,2) :: Tid_l !< Left-column interface tracer (conc, e.g. degC) - real, dimension(nk,2) :: Tid_r !< Right-column interface tracer (conc, e.g. degC) - real, dimension(nk,deg+1) :: ppoly_r_coeffs_l - real, dimension(nk,deg+1) :: ppoly_r_coeffs_r - real, dimension(nk,deg+1) :: ppoly_r_S_l - real, dimension(nk,deg+1) :: ppoly_r_S_r + real, dimension(nk,2) :: Tid_l !< Left-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,2) :: Tid_r !< Right-column interface tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_coeffs_l ! Coefficients of the polynomial descriptions of + ! sub-gridscale tracer concentrations in the left column, in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_coeffs_r ! Coefficients of the polynomial descriptions of + ! sub-gridscale tracer concentrations in the right column, in arbitrary + ! concentration units (e.g. [C ~> degC] for temperature) + real, dimension(nk,deg+1) :: ppoly_r_S_l ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. + real, dimension(nk,deg+1) :: ppoly_r_S_r ! Reconstruction slopes that are unused here, in units of a vertical + ! gradient, which for temperature would be [C H-1 ~> degC m-1 or degC m2 kg-1]. logical :: down_flux, tapering tapering = .false. @@ -2327,18 +2416,28 @@ subroutine neutral_surface_T_eval(nk, ns, k_sub, Ks, Ps, T_mean, T_int, deg, iMe integer, intent(in ) :: ns !< Number of neutral surfaces integer, intent(in ) :: k_sub !< Index of current neutral layer integer, dimension(ns), intent(in ) :: Ks !< List of the layers associated with each neutral surface - real, dimension(ns), intent(in ) :: Ps !< List of the positions within a layer of each surface - real, dimension(nk), intent(in ) :: T_mean !< Cell average of tracer - real, dimension(nk,2), intent(in ) :: T_int !< Cell interface values of tracer from reconstruction + real, dimension(ns), intent(in ) :: Ps !< List of the positions within a layer of each surface [nondim] + real, dimension(nk), intent(in ) :: T_mean !< Layer average of tracer in arbitrary concentration + !! units (e.g. [C ~> degC] for temperature) + real, dimension(nk,2), intent(in ) :: T_int !< Layer interface values of tracer from reconstruction + !! in concentration units (e.g. [C ~> degC] for temperature) integer, intent(in ) :: deg !< Degree of reconstruction polynomial (e.g. 1 is linear) integer, intent(in ) :: iMethod !< Method of integration to use - real, dimension(nk,deg+1), intent(in ) :: T_poly !< Coefficients of polynomial reconstructions - real, intent( out) :: T_top !< Tracer value at top (across discontinuity if necessary) + real, dimension(nk,deg+1), intent(in ) :: T_poly !< Coefficients of polynomial reconstructions in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_top !< Tracer value at top (across discontinuity if necessary) in + !! concentration units (e.g. [C ~> degC] for temperature) real, intent( out) :: T_bot !< Tracer value at bottom (across discontinuity if necessary) - real, intent( out) :: T_sub !< Average of the tracer value over the sublayer - real, intent( out) :: T_top_int !< Tracer value at top interface of neutral layer - real, intent( out) :: T_bot_int !< Tracer value at bottom interface of neutral layer - real, intent( out) :: T_layer !< Cell-average that the reconstruction belongs to + !! in concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_sub !< Average of the tracer value over the sublayer in arbitrary + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_top_int !< Tracer value at the top interface of a neutral layer in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_bot_int !< Tracer value at the bottom interface of a neutral layer in + !! concentration units (e.g. [C ~> degC] for temperature) + real, intent( out) :: T_layer !< Cell-average tracer concentration in a layer that + !! the reconstruction belongs to in concentration + !! units (e.g. [C ~> degC] for temperature) integer :: kl, ks_top, ks_bot @@ -2376,10 +2475,12 @@ end subroutine neutral_surface_T_eval !> Discontinuous PPM reconstructions of the left/right edge values within a cell subroutine ppm_left_right_edge_values(nk, Tl, Ti, aL, aR) integer, intent(in) :: nk !< Number of levels - real, dimension(nk), intent(in) :: Tl !< Layer tracer (conc, e.g. degC) - real, dimension(nk+1), intent(in) :: Ti !< Interface tracer (conc, e.g. degC) + real, dimension(nk), intent(in) :: Tl !< Layer tracer (conc, e.g. degC) in arbitrary units [A ~> a] + real, dimension(nk+1), intent(in) :: Ti !< Interface tracer (conc, e.g. degC) in arbitrary units [A ~> a] real, dimension(nk), intent(inout) :: aL !< Left edge value of tracer (conc, e.g. degC) + !! in the same arbitrary units as Tl and Ti [A ~> a] real, dimension(nk), intent(inout) :: aR !< Right edge value of tracer (conc, e.g. degC) + !! in the same arbitrary units as Tl and Ti [A ~> a] integer :: k ! Setup reconstruction edge values @@ -2411,13 +2512,13 @@ logical function ndiff_unit_tests_continuous(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: nk = 4 - real, dimension(nk+1) :: Tio ! Test interface temperatures - real, dimension(2*nk+2) :: PiLRo, PiRLo ! Test positions + real, dimension(nk+1) :: Tio ! Test interface temperatures [degC] + real, dimension(2*nk+2) :: PiLRo, PiRLo ! Fractional test positions [nondim] integer, dimension(2*nk+2) :: KoL, KoR ! Test indexes - real, dimension(2*nk+1) :: hEff ! Test positions - real, dimension(2*nk+1) :: Flx ! Test flux + real, dimension(2*nk+1) :: hEff ! Test positions in arbitrary units [arbitrary] + real, dimension(2*nk+1) :: Flx ! Test flux in the arbitrary units of hEff times [degC] logical :: v - real :: h_neglect + real :: h_neglect ! A negligible thickness in arbitrary units [arbitrary] h_neglect = 1.0e-30 @@ -2674,12 +2775,16 @@ logical function ndiff_unit_tests_discontinuous(verbose) integer, parameter :: nk = 3 integer, parameter :: ns = nk*4 real, dimension(nk) :: Sl, Sr ! Salinities [ppt] and temperatures [degC] - real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] + real, dimension(nk) :: hl, hr ! Thicknesses in pressure units [R L2 T-2 ~> Pa] or other + ! arbitrary units [arbitrary] real, dimension(nk,2) :: TiL, SiL, TiR, SiR ! Cell edge salinities [ppt] and temperatures [degC] real, dimension(nk,2) :: Pres_l, Pres_r ! Interface pressures [R L2 T-2 ~> Pa] - integer, dimension(ns) :: KoL, KoR - real, dimension(ns) :: PoL, PoR - real, dimension(ns-1) :: hEff + integer, dimension(ns) :: KoL, KoR ! Index of the layer where the interface is found in the + ! left and right columns + real, dimension(ns) :: PoL, PoR ! Fractional position of neutral surface within layer KoL + ! of the left column or KoR of the right column [nondim] + real, dimension(ns-1) :: hEff ! Effective thickness between two neutral surfaces + ! in the same units as hl and hr [arbitrary] type(neutral_diffusion_CS) :: CS !< Neutral diffusion control structure real, dimension(nk,2) :: ppoly_T_l, ppoly_T_r ! Linear reconstruction for T [degC] real, dimension(nk,2) :: ppoly_S_l, ppoly_S_r ! Linear reconstruction for S [ppt] @@ -2921,15 +3026,15 @@ logical function test_fv_diff(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, ti real, intent(in) :: hkm1 !< Left cell width [nondim] real, intent(in) :: hk !< Center cell width [nondim] real, intent(in) :: hkp1 !< Right cell width [nondim] - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer [nondim] + real, intent(in) :: Skm1 !< Left cell average value in arbitrary units [arbitrary] + real, intent(in) :: Sk !< Center cell average value in arbitrary units [arbitrary] + real, intent(in) :: Skp1 !< Right cell average value in arbitrary units [arbitrary] + real, intent(in) :: Ptrue !< True answer in arbitrary units [arbitrary] character(len=*), intent(in) :: title !< Title for messages ! Local variables integer :: stdunit - real :: Pret + real :: Pret ! Returned normalized gradient in arbitrary units [arbitrary] Pret = fv_diff(hkm1, hk, hkp1, Skm1, Sk, Skp1) test_fv_diff = (Pret /= Ptrue) @@ -2950,18 +3055,18 @@ end function test_fv_diff !> Returns true if a test of fvlsq_slope() fails, and conditionally writes results to stream logical function test_fvlsq_slope(verbose, hkm1, hk, hkp1, Skm1, Sk, Skp1, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: hkm1 !< Left cell width - real, intent(in) :: hk !< Center cell width - real, intent(in) :: hkp1 !< Right cell width - real, intent(in) :: Skm1 !< Left cell average value - real, intent(in) :: Sk !< Center cell average value - real, intent(in) :: Skp1 !< Right cell average value - real, intent(in) :: Ptrue !< True answer + real, intent(in) :: hkm1 !< Left cell width in arbitrary units [B ~> b] + real, intent(in) :: hk !< Center cell width in arbitrary units [B ~> b] + real, intent(in) :: hkp1 !< Right cell width in arbitrary units [B ~> b] + real, intent(in) :: Skm1 !< Left cell average value in arbitrary units [A ~> a] + real, intent(in) :: Sk !< Center cell average value in arbitrary units [A ~> a] + real, intent(in) :: Skp1 !< Right cell average value in arbitrary units [A ~> a] + real, intent(in) :: Ptrue !< True answer in arbitrary units [A B-1 ~> a b-1] character(len=*), intent(in) :: title !< Title for messages ! Local variables integer :: stdunit - real :: Pret + real :: Pret ! Returned slope value [A B-1 ~> a b-1] Pret = fvlsq_slope(hkm1, hk, hkp1, Skm1, Sk, Skp1) test_fvlsq_slope = (Pret /= Ptrue) @@ -2991,7 +3096,7 @@ logical function test_ifndp(verbose, rhoNeg, Pneg, rhoPos, Ppos, Ptrue, title) ! Local variables integer :: stdunit - real :: Pret + real :: Pret ! Interpolated fractional position [nondim] Pret = interpolate_for_nondim_position(rhoNeg, Pneg, rhoPos, Ppos) test_ifndp = (Pret /= Ptrue) @@ -3015,8 +3120,8 @@ end function test_ifndp logical function test_data1d(verbose, nk, Po, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: nk !< Number of layers - real, dimension(nk), intent(in) :: Po !< Calculated answer - real, dimension(nk), intent(in) :: Ptrue !< True answer + real, dimension(nk), intent(in) :: Po !< Calculated answer [arbitrary] + real, dimension(nk), intent(in) :: Ptrue !< True answer [arbitrary] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -3050,8 +3155,8 @@ end function test_data1d logical function test_data1di(verbose, nk, Po, Ptrue, title) logical, intent(in) :: verbose !< If true, write results to stdout integer, intent(in) :: nk !< Number of layers - integer, dimension(nk), intent(in) :: Po !< Calculated answer - integer, dimension(nk), intent(in) :: Ptrue !< True answer + integer, dimension(nk), intent(in) :: Po !< Calculated answer [arbitrary] + integer, dimension(nk), intent(in) :: Ptrue !< True answer [arbitrary] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -3086,14 +3191,16 @@ logical function test_nsp(verbose, ns, KoL, KoR, pL, pR, hEff, KoL0, KoR0, pL0, integer, intent(in) :: ns !< Number of surfaces integer, dimension(ns), intent(in) :: KoL !< Index of first left interface above neutral surface integer, dimension(ns), intent(in) :: KoR !< Index of first right interface above neutral surface - real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column - real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column + real, dimension(ns), intent(in) :: pL !< Fractional position of neutral surface within layer + !! KoL of left column [nondim] + real, dimension(ns), intent(in) :: pR !< Fractional position of neutral surface within layer + !! KoR of right column [nondim] real, dimension(ns-1), intent(in) :: hEff !< Effective thickness between two neutral surfaces [R L2 T-2 ~> Pa] integer, dimension(ns), intent(in) :: KoL0 !< Correct value for KoL integer, dimension(ns), intent(in) :: KoR0 !< Correct value for KoR - real, dimension(ns), intent(in) :: pL0 !< Correct value for pL - real, dimension(ns), intent(in) :: pR0 !< Correct value for pR - real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff + real, dimension(ns), intent(in) :: pL0 !< Correct value for pL [nondim] + real, dimension(ns), intent(in) :: pR0 !< Correct value for pR [nondim] + real, dimension(ns-1), intent(in) :: hEff0 !< Correct value for hEff [R L2 T-2 ~> Pa] character(len=*), intent(in) :: title !< Title for messages ! Local variables @@ -3138,12 +3245,12 @@ end function test_nsp logical function compare_nsp_row(KoL, KoR, pL, pR, KoL0, KoR0, pL0, pR0) integer, intent(in) :: KoL !< Index of first left interface above neutral surface integer, intent(in) :: KoR !< Index of first right interface above neutral surface - real, intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column - real, intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column + real, intent(in) :: pL !< Fractional position of neutral surface within layer KoL of left column [nondim] + real, intent(in) :: pR !< Fractional position of neutral surface within layer KoR of right column [nondim] integer, intent(in) :: KoL0 !< Correct value for KoL integer, intent(in) :: KoR0 !< Correct value for KoR - real, intent(in) :: pL0 !< Correct value for pL - real, intent(in) :: pR0 !< Correct value for pR + real, intent(in) :: pL0 !< Correct value for pL [nondim] + real, intent(in) :: pR0 !< Correct value for pR [nondim] compare_nsp_row = .false. if (KoL /= KoL0) compare_nsp_row = .true. @@ -3154,8 +3261,8 @@ end function compare_nsp_row !> Compares output position from refine_nondim_position with an expected value logical function test_rnp(expected_pos, test_pos, title) - real, intent(in) :: expected_pos !< The expected position - real, intent(in) :: test_pos !< The position returned by the code + real, intent(in) :: expected_pos !< The expected position [arbitrary] + real, intent(in) :: test_pos !< The position returned by the code [arbitrary] character(len=*), intent(in) :: title !< A label for this test ! Local variables integer :: stdunit @@ -3168,6 +3275,7 @@ logical function test_rnp(expected_pos, test_pos, title) write(stdunit,'(A, f20.16, " == ", f20.16)') title, expected_pos, test_pos endif end function test_rnp + !> Deallocates neutral_diffusion control structure subroutine neutral_diffusion_end(CS) type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure From 11759d6a219bcf77313849aba7796c8f0c852c0d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 19 Nov 2023 07:49:21 -0500 Subject: [PATCH 486/629] Fix unpaired parentheses in a formatting string Fix unpaired parentheses in the format statement used in an error message about OBC segment data not being on the supergrid. All answers are bitwise identical, but there is one less compile-time warning. --- src/core/MOM_open_boundary.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7bfb6479b2..b54c93cefa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -854,7 +854,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) ! if (siz(4) == 1) segment%values_needed = .false. if (segment%on_pe) then if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then - write(mesg,'("Brushcutter mode sizes ", I6, I6))') siz(1), siz(2) + write(mesg,'("Brushcutter mode sizes ", I6, I6)') siz(1), siz(2) call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) call MOM_error(FATAL,'segment data are not on the supergrid') endif From 40134ed86a10b0616134bdaef653d37f2616e873 Mon Sep 17 00:00:00 2001 From: Raphael Dussin Date: Mon, 4 Dec 2023 13:41:27 -0500 Subject: [PATCH 487/629] change target to pointer and check for association --- src/parameterizations/vertical/MOM_set_diffusivity.F90 | 4 ++-- src/parameterizations/vertical/MOM_tidal_mixing.F90 | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index c404e94459..3de5ad1162 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -2052,7 +2052,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ type(diag_ctrl), target, intent(inout) :: diag !< A structure used to regulate diagnostic output. type(set_diffusivity_CS), pointer :: CS !< pointer set to point to the module control !! structure. - type(int_tide_CS), intent(in), target :: int_tide_CSp !< Internal tide control structure + type(int_tide_CS), pointer :: int_tide_CSp !< Internal tide control structure integer, intent(out) :: halo_TS !< The halo size of tracer points that must be !! valid for the calculations in set_diffusivity. logical, intent(out) :: double_diffuse !< This indicates whether some version @@ -2097,7 +2097,7 @@ subroutine set_diffusivity_init(Time, G, GV, US, param_file, diag, CS, int_tide_ isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed CS%diag => diag - CS%int_tide_CSp => int_tide_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp ! These default values always need to be set. CS%BBL_mixing_as_max = .true. diff --git a/src/parameterizations/vertical/MOM_tidal_mixing.F90 b/src/parameterizations/vertical/MOM_tidal_mixing.F90 index 6e53679549..31f90cdcb1 100644 --- a/src/parameterizations/vertical/MOM_tidal_mixing.F90 +++ b/src/parameterizations/vertical/MOM_tidal_mixing.F90 @@ -221,7 +221,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< Run-time parameter file handle - type(int_tide_CS),target, intent(in) :: int_tide_CSp !< A pointer to the internal tides control structure + type(int_tide_CS), pointer :: int_tide_CSp !< A pointer to the internal tides control structure type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. type(tidal_mixing_cs), intent(inout) :: CS !< This module's control structure. @@ -276,7 +276,7 @@ logical function tidal_mixing_init(Time, G, GV, US, param_file, int_tide_CSp, di CS%debug = CS%debug.and.is_root_pe() CS%diag => diag - CS%int_tide_CSp => int_tide_CSp + if (associated(int_tide_CSp)) CS%int_tide_CSp => int_tide_CSp CS%use_CVmix_tidal = use_CVmix_tidal CS%int_tide_dissipation = int_tide_dissipation From b898297e0ad5284f07c22f213120157787fc4a0a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 7 Nov 2023 08:48:04 -0500 Subject: [PATCH 488/629] +(*)Add continuity_fluxes & continuity_adjust_vel Added the new public interfaces continuity_fluxes and continuity_adjust_vel to make use of the continuity code without actually updating the layer thicknesses, and made the existing routines zonal_mass_flux and meridional_mass_flux in the continuity_PPM module public. Continuity_fluxes is overloaded to provide either the layer thickness fluxes or the vertically summed barotropic fluxes. As a part of this change, the LB arguments to meridional_mass_flux and zonal_mass_flux were made optional and moved toward the end of the list of arguments. The intent of the ocean_grid_type argument to 11 routines in the continuity_PPM module was changed from inout to in. Missing factors of por_face_area[UV] were also added to merid_face_thickness and zonal_face_thickness when the visc_rem arguments are not present or where OBCs are in use. This could change answers, but it seems very unlikely that any impacted cases are in use yet. Answers are bitwise identical all known cases, but there are 4 new public interfaces, and some bugs were fixed in cases that are not likely in use yet. --- src/core/MOM_continuity.F90 | 192 ++++++++++++++++++++++++++++++-- src/core/MOM_continuity_PPM.F90 | 89 +++++++++------ 2 files changed, 239 insertions(+), 42 deletions(-) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 76e1bbc623..7a833ccb5c 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -3,8 +3,8 @@ module MOM_continuity ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_continuity_PPM, only : continuity_PPM, continuity_PPM_init -use MOM_continuity_PPM, only : continuity_PPM_stencil +use MOM_continuity_PPM, only : continuity_PPM, zonal_mass_flux, meridional_mass_flux +use MOM_continuity_PPM, only : continuity_PPM_stencil, continuity_PPM_init use MOM_continuity_PPM, only : continuity_PPM_CS use MOM_diag_mediator, only : time_type, diag_ctrl use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe @@ -20,7 +20,7 @@ module MOM_continuity #include -public continuity, continuity_init, continuity_stencil +public continuity, continuity_fluxes, continuity_adjust_vel, continuity_init, continuity_stencil !> Control structure for mom_continuity type, public :: continuity_CS ; private @@ -35,10 +35,16 @@ module MOM_continuity integer, parameter :: PPM_SCHEME = 1 !< Enumerated constant to select PPM character(len=20), parameter :: PPM_STRING = "PPM" !< String to select PPM +!> Finds the thickness fluxes from the continuity solver or their vertical sum without +!! actually updating the layer thicknesses. +interface continuity_fluxes + module procedure continuity_3d_fluxes, continuity_2d_fluxes +end interface continuity_fluxes + contains -!> Time steps the layer thicknesses, using a monotonically limited, directionally split PPM scheme, -!! based on Lin (1994). +!> Time steps the layer thicknesses, using a monotonically or positive-definite limited, directionally +!! split PPM scheme, based on Lin (1994). subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. @@ -63,21 +69,23 @@ subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, v type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(in) :: uhbt !< The vertically summed volume - !! flux through zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + optional, intent(in) :: uhbt !< The vertically summed volume flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(in) :: vhbt !< The vertically summed volume - !! flux through meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + optional, intent(in) :: vhbt !< The vertically summed volume flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: visc_rem_u !< Both the fraction of !! zonal momentum that remains after a time-step of viscosity, and the fraction of a time-step's !! worth of a barotropic acceleration that a layer experiences after viscosity is applied [nondim]. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). When this column is + !! under an ice shelf, this can also go to 0 at the top due to the no-slip boundary condition there. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & optional, intent(in) :: visc_rem_v !< Both the fraction of !! meridional momentum that remains after a time-step of viscosity, and the fraction of a time-step's !! worth of a barotropic acceleration that a layer experiences after viscosity is applied [nondim]. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). + !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). When this column is + !! under an ice shelf, this can also go to 0 at the top due to the no-slip boundary condition there. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(out) :: u_cor !< The zonal velocities that !! give uhbt as the depth-integrated transport [L T-1 ~> m s-1]. @@ -104,6 +112,168 @@ subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, v end subroutine continuity +!> Finds the thickness fluxes from the continuity solver without actually updating the +!! layer thicknesses. Because the fluxes in the two directions are calculated based on the +!! input thicknesses, which are not updated between the direcitons, the fluxes returned here +!! are not the same as those that would be returned by a call to continuity. +subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: uh !< Thickness fluxes through zonal faces, + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: vh !< Thickness fluxes through meridional faces, + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + if (CS%continuity_scheme == PPM_SCHEME) then + call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaU) + + call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaV) + else + call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") + endif + +end subroutine continuity_3d_fluxes + +!> Find the vertical sum of the thickness fluxes from the continuity solver without actually +!! updating the layer thicknesses. Because the fluxes in the two directions are calculated +!! based on the input thicknesses, which are not updated between the directions, the fluxes +!! returned here are not the same as those that would be returned by a call to continuity. +subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), & + intent(out) :: uhbt !< Vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(out) :: vhbt !< Vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh ! Thickness fluxes through zonal faces, + ! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh ! Thickness fluxes through meridional faces, + ! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + integer :: i, j, k + + uh(:,:,:) = 0.0 + vh(:,:,:) = 0.0 + + if (CS%continuity_scheme == PPM_SCHEME) then + call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaU) + + call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaV) + else + call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") + endif + + uhbt(:,:) = 0.0 + vhbt(:,:) = 0.0 + + do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec + uhbt(I,j) = uhbt(I,j) + uh(I,j,k) + enddo ; enddo ; enddo + + do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec + vhbt(I,j) = vhbt(I,j) + vh(I,j,k) + enddo ; enddo ; enddo + +end subroutine continuity_2d_fluxes + + +!> Correct the velocities to give the specified depth-integrated transports by applying a +!! barotropic acceleration (subject to viscous drag) to the velocities. +subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, visc_rem_u, visc_rem_v) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity, which will be adjusted to + !! give uhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity, which will be adjusted + !! to give vhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + real, dimension(SZIB_(G),SZJ_(G)), & + intent(in) :: uhbt !< The vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(in) :: vhbt !< The vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of the zonal momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of the meridional momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_in !< Input zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_in !< Input meridional velocity [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh !< Volume flux through zonal faces = + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh !< Volume flux through meridional faces = + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + + ! It might not be necessary to separate the input velocity array from the adjusted velocities, + ! but it seems safer to do so, even if it might be less efficient. + u_in(:,:,:) = u(:,:,:) + v_in(:,:,:) = v(:,:,:) + + if (CS%continuity_scheme == PPM_SCHEME) then + call zonal_mass_flux(u_in, h, uh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaU, & + uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) + + call meridional_mass_flux(v_in, h, vh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaV, & + vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) + else + call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") + endif + +end subroutine continuity_adjust_vel + !> Initializes continuity_cs subroutine continuity_init(Time, G, GV, US, param_file, diag, CS) type(time_type), target, intent(in) :: Time !< Current model time. diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 73c6503242..7f96e675cd 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -19,6 +19,7 @@ module MOM_continuity_PPM #include public continuity_PPM, continuity_PPM_init, continuity_PPM_stencil +public zonal_mass_flux, meridional_mass_flux !>@{ CPU time clock IDs integer :: id_clock_update, id_clock_correct @@ -72,7 +73,7 @@ module MOM_continuity_PPM !! based on Lin (1994). subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -147,8 +148,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb ! First, advect zonally. LB%ish = G%isc ; LB%ieh = G%iec LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil - call zonal_mass_flux(u, hin, uh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaU, uhbt, visc_rem_u, u_cor, BT_cont) + call zonal_mass_flux(u, hin, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB, uhbt, visc_rem_u, u_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) @@ -163,8 +164,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb ! Now advect meridionally, using the updated thicknesses to determine ! the fluxes. - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaV, vhbt, visc_rem_v, v_cor, BT_cont) + call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + LB, vhbt, visc_rem_v, v_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) @@ -180,8 +181,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil LB%jsh = G%jsc ; LB%jeh = G%jec - call meridional_mass_flux(v, hin, vh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaV, vhbt, visc_rem_v, v_cor, BT_cont) + call meridional_mass_flux(v, hin, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + LB, vhbt, visc_rem_v, v_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) @@ -193,8 +194,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb ! Now advect zonally, using the updated thicknesses to determine ! the fluxes. LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, LB, OBC, & - pbv%por_face_areaU, uhbt, visc_rem_u, u_cor, BT_cont) + call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB, uhbt, visc_rem_u, u_cor, BT_cont) call cpu_clock_begin(id_clock_update) !$OMP parallel do default(shared) @@ -210,9 +211,9 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb end subroutine continuity_PPM !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. -subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_areaU, uhbt, & - visc_rem_u, u_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. +subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & + LB_in, uhbt, visc_rem_u, u_cor, BT_cont) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -224,10 +225,11 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: uhbt !< The summed volume flux through zonal faces !! [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -265,6 +267,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. + type(loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC @@ -279,6 +282,12 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, LB, OBC, por_face_are local_Flather_OBC = OBC%Flather_u_BCs_exist_globally local_open_BC = OBC%open_u_BCs_exist_globally endif ; endif + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke CFL_dt = CS%CFL_limit_adjust / dt @@ -523,7 +532,7 @@ end subroutine zonal_mass_flux !> Evaluates the zonal mass or volume fluxes in a layer. subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & ish, ieh, do_I, vol_CFL, por_face_areaU, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZIB_(G)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step @@ -606,7 +615,7 @@ end subroutine zonal_flux_layer !! back these thicknesses to account for viscosity and fractional open areas. subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, & marginal, OBC, por_face_areaU, visc_rem_u) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to @@ -617,7 +626,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, !! reconstruction [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_u !< Effective thickness at zonal faces, !! scaled down to account for the effects of - !! viscoity and the fractional open area + !! viscosity and the fractional open area !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -680,6 +689,11 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh h_u(I,j,k) = h_u(I,j,k) * (visc_rem_u(I,j,k) * por_face_areaU(I,j,k)) enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh,jeh ; do I=ish-1,ieh + h_u(I,j,k) = h_u(I,j,k) * por_face_areaU(I,j,k) + enddo ; enddo ; enddo endif local_open_BC = .false. @@ -695,7 +709,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, enddo enddo ; else ; do k=1,nz do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h_u(I,j,k) = h(i,j,k) + h_u(I,j,k) = h(i,j,k) * por_face_areaU(I,j,k) enddo enddo ; endif else @@ -705,7 +719,7 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, enddo enddo ; else ; do k=1,nz do j = OBC%segment(n)%HI%jsd, OBC%segment(n)%HI%jed - h_u(I,j,k) = h(i+1,j,k) + h_u(I,j,k) = h(i+1,j,k) * por_face_areaU(I,j,k) enddo enddo ; endif endif @@ -721,7 +735,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, por_face_areaU, uh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to @@ -873,7 +887,7 @@ end subroutine zonal_flux_adjust subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaU) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to @@ -1036,9 +1050,9 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, end subroutine set_zonal_BT_cont !> Calculates the mass or volume fluxes through the meridional faces, and other related quantities. -subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_face_areaV, vhbt, & - visc_rem_v, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. +subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_areaV, & + LB_in, vhbt, visc_rem_v, v_cor, BT_cont) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to @@ -1048,11 +1062,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type !! specifies whether, where, and what open boundary conditions are used. real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through !< meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1090,6 +1105,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. + type(loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC @@ -1104,6 +1120,12 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, LB, OBC, por_fac local_Flather_OBC = OBC%Flather_v_BCs_exist_globally local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke CFL_dt = CS%CFL_limit_adjust / dt @@ -1343,7 +1365,7 @@ end subroutine meridional_mass_flux !> Evaluates the meridional mass or volume fluxes in a layer. subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & ish, ieh, do_I, vol_CFL, por_face_areaV, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step @@ -1432,7 +1454,7 @@ end subroutine merid_flux_layer !! back these thicknesses to account for viscosity and fractional open areas. subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, & marginal, OBC, por_face_areaV, visc_rem_v) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to calculate fluxes, @@ -1443,7 +1465,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: h_v !< Effective thickness at meridional faces, !! scaled down to account for the effects of - !! viscoity and the fractional open area + !! viscosity and the fractional open area !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. @@ -1508,6 +1530,11 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh h_v(i,J,k) = h_v(i,J,k) * (visc_rem_v(i,J,k) * por_face_areaV(i,J,k)) enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz ; do J=jsh-1,jeh ; do i=ish,ieh + h_v(i,J,k) = h_v(i,J,k) * por_face_areaV(i,J,k) + enddo ; enddo ; enddo endif local_open_BC = .false. @@ -1523,7 +1550,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, enddo enddo ; else ; do k=1,nz do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h_v(i,J,k) = h(i,j,k) + h_v(i,J,k) = h(i,j,k) * por_face_areaV(i,J,k) enddo enddo ; endif else @@ -1533,7 +1560,7 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, enddo enddo ; else ; do k=1,nz do i = OBC%segment(n)%HI%isd, OBC%segment(n)%HI%ied - h_v(i,J,k) = h(i,j+1,k) + h_v(i,J,k) = h(i,j+1,k) * por_face_areaV(i,J,k) enddo enddo ; endif endif @@ -1547,7 +1574,7 @@ end subroutine merid_face_thickness subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, por_face_areaV, vh_3d, OBC) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. @@ -1699,7 +1726,7 @@ end subroutine meridional_flux_adjust subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaV) - type(ocean_grid_type), intent(inout) :: G !< Ocean's grid structure. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, From fc0bef1c23efe5236fc46d6fa7b6b5ea6e156648 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 14 Nov 2023 14:28:03 -0500 Subject: [PATCH 489/629] +Pass-through from continuity_PPM via continuity In recognition of the fact that there is only a single continuity scheme that is accessed via the MOM_continuity module, this commit refactors MOM_continuity to use 3 simple pass-through interfaces (continuity, continuity_init and continuity_stencil) to the corresponding routines from MOM_continuity_PPM, while the MOM_continuity control structure is now alias for continuity_PPM_CS and is opaque in the MOM_continuity module. As a part of these changes, the runtime parameter CONTINUITY_SCHEME was obsoleted with a warning value of "PPM". All answers are bitwise identical, and all public interfaces look the same from the outside, but there is one fewer entry in the MOM_parameter_doc.all files. --- src/core/MOM_continuity.F90 | 181 +++--------------------- src/diagnostics/MOM_obsolete_params.F90 | 3 +- 2 files changed, 19 insertions(+), 165 deletions(-) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 7a833ccb5c..44422d5e47 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -3,13 +3,12 @@ module MOM_continuity ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_continuity_PPM, only : continuity_PPM, zonal_mass_flux, meridional_mass_flux -use MOM_continuity_PPM, only : continuity_PPM_stencil, continuity_PPM_init -use MOM_continuity_PPM, only : continuity_PPM_CS -use MOM_diag_mediator, only : time_type, diag_ctrl -use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type -use MOM_string_functions, only : uppercase +use MOM_continuity_PPM, only : continuity=>continuity_PPM +use MOM_continuity_PPM, only : continuity_stencil=>continuity_PPM_stencil +use MOM_continuity_PPM, only : continuity_init=>continuity_PPM_init +use MOM_continuity_PPM, only : continuity_CS=>continuity_PPM_CS +use MOM_continuity_PPM, only : zonal_mass_flux, meridional_mass_flux +use MOM_diag_mediator, only : time_type use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type use MOM_unit_scaling, only : unit_scale_type @@ -20,20 +19,9 @@ module MOM_continuity #include -public continuity, continuity_fluxes, continuity_adjust_vel, continuity_init, continuity_stencil - -!> Control structure for mom_continuity -type, public :: continuity_CS ; private - integer :: continuity_scheme !< Selects the discretization for the continuity solver. - !! Valid values are: - !! - PPM - A directionally split piecewise parabolic reconstruction solver. - !! The default, PPM, seems most appropriate for use with our current - !! time-splitting strategies. - type(continuity_PPM_CS) :: PPM !< Control structure for mom_continuity_ppm -end type continuity_CS - -integer, parameter :: PPM_SCHEME = 1 !< Enumerated constant to select PPM -character(len=20), parameter :: PPM_STRING = "PPM" !< String to select PPM +! These are direct pass-throughs of routines in continuity_PPM +public continuity, continuity_init, continuity_stencil, continuity_CS +public continuity_fluxes, continuity_adjust_vel !> Finds the thickness fluxes from the continuity solver or their vertical sum without !! actually updating the layer thicknesses. @@ -43,75 +31,6 @@ module MOM_continuity contains -!> Time steps the layer thicknesses, using a monotonically or positive-definite limited, directionally -!! split PPM scheme, based on Lin (1994). -subroutine continuity(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & - visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: uh !< Volume flux through zonal faces = - !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(out) :: vh !< Volume flux through meridional faces = - !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics - real, dimension(SZIB_(G),SZJ_(G)), & - optional, intent(in) :: uhbt !< The vertically summed volume flux through - !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G)), & - optional, intent(in) :: vhbt !< The vertically summed volume flux through - !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_u !< Both the fraction of - !! zonal momentum that remains after a time-step of viscosity, and the fraction of a time-step's - !! worth of a barotropic acceleration that a layer experiences after viscosity is applied [nondim]. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). When this column is - !! under an ice shelf, this can also go to 0 at the top due to the no-slip boundary condition there. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_v !< Both the fraction of - !! meridional momentum that remains after a time-step of viscosity, and the fraction of a time-step's - !! worth of a barotropic acceleration that a layer experiences after viscosity is applied [nondim]. - !! Non-dimensional between 0 (at the bottom) and 1 (far above the bottom). When this column is - !! under an ice shelf, this can also go to 0 at the top due to the no-slip boundary condition there. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(out) :: u_cor !< The zonal velocities that - !! give uhbt as the depth-integrated transport [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(out) :: v_cor !< The meridional velocities that - !! give vhbt as the depth-integrated transport [L T-1 ~> m s-1]. - type(BT_cont_type), & - optional, pointer :: BT_cont !< A structure with elements - !! that describe the effective open face areas as a function of barotropic flow. - - if (present(visc_rem_u) .neqv. present(visc_rem_v)) call MOM_error(FATAL, & - "MOM_continuity: Either both visc_rem_u and visc_rem_v or neither"// & - " one must be present in call to continuity.") - if (present(u_cor) .neqv. present(v_cor)) call MOM_error(FATAL, & - "MOM_continuity: Either both u_cor and v_cor or neither"// & - " one must be present in call to continuity.") - - if (CS%continuity_scheme == PPM_SCHEME) then - call continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS%PPM, OBC, pbv, uhbt, vhbt, & - visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont=BT_cont) - else - call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") - endif - -end subroutine continuity - !> Finds the thickness fluxes from the continuity solver without actually updating the !! layer thicknesses. Because the fluxes in the two directions are calculated based on the !! input thicknesses, which are not updated between the direcitons, the fluxes returned here @@ -137,13 +56,9 @@ subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics - if (CS%continuity_scheme == PPM_SCHEME) then - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaU) + call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaV) - else - call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") - endif + call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) end subroutine continuity_3d_fluxes @@ -182,13 +97,9 @@ subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv uh(:,:,:) = 0.0 vh(:,:,:) = 0.0 - if (CS%continuity_scheme == PPM_SCHEME) then - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaU) + call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaV) - else - call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") - endif + call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) uhbt(:,:) = 0.0 vhbt(:,:) = 0.0 @@ -262,70 +173,12 @@ subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhb u_in(:,:,:) = u(:,:,:) v_in(:,:,:) = v(:,:,:) - if (CS%continuity_scheme == PPM_SCHEME) then - call zonal_mass_flux(u_in, h, uh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaU, & - uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) + call zonal_mass_flux(u_in, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) - call meridional_mass_flux(v_in, h, vh, dt, G, GV, US, CS%PPM, OBC, pbv%por_face_areaV, & - vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) - else - call MOM_error(FATAL, "continuity: Unrecognized value of continuity_scheme") - endif + call meridional_mass_flux(v_in, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) end subroutine continuity_adjust_vel -!> Initializes continuity_cs -subroutine continuity_init(Time, G, GV, US, param_file, diag, CS) - type(time_type), target, intent(in) :: Time !< Current model time. - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< 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 handles. - type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure. - type(continuity_CS), intent(inout) :: CS !< Control structure for mom_continuity. - - ! This include declares and sets the variable "version". -# include "version_variable.h" - character(len=40) :: mdl = "MOM_continuity" ! This module's name. - character(len=20) :: tmpstr - - ! Read all relevant parameters and write them to the model log. - call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "CONTINUITY_SCHEME", tmpstr, & - "CONTINUITY_SCHEME selects the discretization for the "//& - "continuity solver. The only valid value currently is: \n"//& - "\t PPM - use a positive-definite (or monotonic) \n"//& - "\t piecewise parabolic reconstruction solver.", & - default=PPM_STRING) - - tmpstr = uppercase(tmpstr) ; CS%continuity_scheme = 0 - select case (trim(tmpstr)) - case (PPM_STRING) ; CS%continuity_scheme = PPM_SCHEME - case default - call MOM_mesg('continuity_init: CONTINUITY_SCHEME ="'//trim(tmpstr)//'"', 0) - call MOM_mesg("continuity_init: The only valid value is currently "// & - trim(PPM_STRING), 0) - call MOM_error(FATAL, "continuity_init: Unrecognized setting "// & - "#define CONTINUITY_SCHEME "//trim(tmpstr)//" found in input file.") - end select - - if (CS%continuity_scheme == PPM_SCHEME) then - call continuity_PPM_init(Time, G, GV, US, param_file, diag, CS%PPM) - endif - -end subroutine continuity_init - - -!> continuity_stencil returns the continuity solver stencil size -function continuity_stencil(CS) result(stencil) - type(continuity_CS), intent(in) :: CS !< Module's control structure. - integer :: stencil !< The continuity solver stencil size with the current settings. - - stencil = 1 - - if (CS%continuity_scheme == PPM_SCHEME) then - stencil = continuity_PPM_stencil(CS%PPM) - endif -end function continuity_stencil - end module MOM_continuity diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 4a50abbb14..2567e7591b 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -89,7 +89,8 @@ subroutine find_obsolete_params(param_file) if (test_logic .and. .not.split) call MOM_ERROR(FATAL, & "find_obsolete_params: #define DYNAMIC_SURFACE_PRESSURE is not yet "//& "implemented without #define SPLIT.") - + call obsolete_char(param_file, "CONTINUITY_SCHEME", warning_val="PPM", & + hint="Only one continuity scheme is available so this need not be specified.") call obsolete_real(param_file, "ETA_TOLERANCE_AUX", only_warn=.true.) call obsolete_real(param_file, "BT_MASS_SOURCE_LIMIT", 0.0) call obsolete_real(param_file, "FIRST_GUESS_SURFACE_LAYER_DEPTH") From 6b86ab84dcf622abe9b8b69d35f317315e5d52b8 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 15 Nov 2023 06:11:49 -0500 Subject: [PATCH 490/629] +Create zonal_edge_thickness in MOM_continuity_PPM Refactored MOM_continuity_PPM to create the separate publicly visible routines zonal_edge_thickness and meridional_edge_thickness, and also renamed the internal routines zonal_face_thickness and merid_face_thickness to zonal_flux_thickness, meridional_flux_thickness and made them publicly visible as well. This commit also renames a number of internal edge thickness variables from h_L and h_R to h_S and h_N or h_W and h_E for greater clarity, since left and right are not so well defined on the grid as north, south, east and west. All answers are bitwise identical, but there are 4 new publicly visible interfaces. --- src/core/MOM_continuity_PPM.F90 | 431 ++++++++++++++++++-------------- 1 file changed, 250 insertions(+), 181 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 7f96e675cd..415d04dd36 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -20,6 +20,8 @@ module MOM_continuity_PPM public continuity_PPM, continuity_PPM_init, continuity_PPM_stencil public zonal_mass_flux, meridional_mass_flux +public zonal_flux_thickness, meridional_flux_thickness +public zonal_edge_thickness, meridional_edge_thickness !>@{ CPU time clock IDs integer :: id_clock_update, id_clock_correct @@ -142,7 +144,7 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither"// & " one must be present in call to continuity_PPM.") - stencil = 3 ; if (CS%simple_2nd) stencil = 2 ; if (CS%upwind_1st) stencil = 1 + stencil = continuity_PPM_stencil(CS) if (x_first) then ! First, advect zonally. @@ -210,6 +212,92 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb end subroutine continuity_PPM +!> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. +subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Tracer cell layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_W !< Western edge layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_E !< Eastern edge layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + type(loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + if (CS%upwind_1st) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh,jeh ; do i=ish-1,ieh+1 + h_W(i,j,k) = h_in(i,j,k) ; h_E(i,j,k) = h_in(i,j,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz + call PPM_reconstruction_x(h_in(:,:,k), h_W(:,:,k), h_E(:,:,k), G, LB, & + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) + enddo + endif + +end subroutine zonal_edge_thickness + + +!> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. +subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_in !< Tracer cell layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_S !< Southern edge layer thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: h_N !< Northern edge layer thickness [H ~> m or kg m-2]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(loop_bounds_type), & + optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + type(loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + if (CS%upwind_1st) then + !$OMP parallel do default(shared) + do k=1,nz ; do j=jsh-1,jeh+1 ; do i=ish,ieh + h_S(i,j,k) = h_in(i,j,k) ; h_N(i,j,k) = h_in(i,j,k) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,nz + call PPM_reconstruction_y(h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), G, LB, & + 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) + enddo + endif + +end subroutine meridional_edge_thickness + + !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & LB_in, uhbt, visc_rem_u, u_cor, BT_cont) @@ -248,7 +336,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, ! Local variables real, dimension(SZIB_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_W, h_E ! Left and right face thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G)) :: & du, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. du_min_CFL, & ! Lower limit on du correction to avoid CFL violations [L T-1 ~> m s-1] @@ -295,23 +383,13 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, if (CS%aggress_adjust) CFL_dt = I_dt call cpu_clock_begin(id_clock_update) -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,CS,h_L,h_in,h_R,G,GV,LB,visc_rem,OBC) - do k=1,nz - ! This sets h_L and h_R. - if (CS%upwind_1st) then - do j=jsh,jeh ; do i=ish-1,ieh+1 - h_L(i,j,k) = h_in(i,j,k) ; h_R(i,j,k) = h_in(i,j,k) - enddo ; enddo - else - call PPM_reconstruction_x(h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), G, LB, & - 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) - endif - do I=ish-1,ieh ; visc_rem(I,k) = 1.0 ; enddo - enddo + ! This sets h_W and h_E. + call zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB) call cpu_clock_end(id_clock_update) call cpu_clock_begin(id_clock_correct) -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_L,h_R,use_visc_rem,visc_rem_u, & + if (.not.use_visc_rem) visc_rem(:,:) = 1.0 +!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_W,h_E,use_visc_rem,visc_rem_u, & !$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & !$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC, & !$OMP por_face_areaU) & @@ -320,33 +398,33 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, !$OMP any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do j=jsh,jeh - do I=ish-1,ieh ; do_I(I) = .true. ; visc_rem_max(I) = 0.0 ; enddo + do I=ish-1,ieh ; do_I(I) = .true. ; enddo ! Set uh and duhdu. do k=1,nz if (use_visc_rem) then ; do I=ish-1,ieh visc_rem(I,k) = visc_rem_u(I,j,k) - visc_rem_max(I) = max(visc_rem_max(I), visc_rem(I,k)) enddo ; endif - call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), & + call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), & uh(:,j,k), duhdu(:,k), visc_rem(:,k), & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) if (local_specified_BC) then - do I=ish-1,ieh + do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%specified) & - uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) - endif - enddo + if (OBC%segment(l_seg)%specified) & + uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + endif ; enddo endif enddo - if ((.not.use_visc_rem).or.(.not.CS%use_visc_rem_max)) then ; do I=ish-1,ieh - visc_rem_max(I) = 1.0 - enddo ; endif - if (present(uhbt) .or. set_BT_cont) then + if (use_visc_rem .and. CS%use_visc_rem_max) then + visc_rem_max(:) = 0.0 + do k=1,nz ; do I=ish-1,ieh + visc_rem_max(I) = max(visc_rem_max(I), visc_rem(I,k)) + enddo ; enddo + else + visc_rem_max(:) = 1.0 + endif ! Set limits on du that will keep the CFL number between -1 and 1. ! This should be adequate to keep the root bracketed in all cases. do I=ish-1,ieh @@ -440,7 +518,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, endif if (present(uhbt)) then - call zonal_flux_adjust(u, h_in, h_L, h_R, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & + call zonal_flux_adjust(u, h_in, h_W, h_E, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaU, uh, OBC=OBC) @@ -459,7 +537,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, endif if (set_BT_cont) then - call set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0,& + call set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0,& du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaU) if (any_simple_OBC) then @@ -519,10 +597,10 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then if (present(u_cor)) then - call zonal_face_thickness(u_cor, h_in, h_L, h_R, BT_cont%h_u, dt, G, GV, US, LB, & + call zonal_flux_thickness(u_cor, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) else - call zonal_face_thickness(u, h_in, h_L, h_R, BT_cont%h_u, dt, G, GV, US, LB, & + call zonal_flux_thickness(u, h_in, h_W, h_E, BT_cont%h_u, dt, G, GV, US, LB, & CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaU, visc_rem_u) endif endif ; endif @@ -530,7 +608,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, end subroutine zonal_mass_flux !> Evaluates the zonal mass or volume fluxes in a layer. -subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & +subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & ish, ieh, do_I, vol_CFL, por_face_areaU, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZIB_(G)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. @@ -540,8 +618,8 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & !! acceleration that a layer experiences after viscosity is applied [nondim]. !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G)), intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G)), intent(in) :: h_L !< Left thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G)), intent(in) :: h_R !< Right thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_W !< West edge thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G)), intent(in) :: h_E !< East edge thickness [H ~> m or kg m-2]. real, dimension(SZIB_(G)), intent(inout) :: uh !< Zonal mass or volume !! transport [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)), intent(inout) :: duhdu !< Partial derivative of uh @@ -574,20 +652,20 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & if (u(I) > 0.0) then if (vol_CFL) then ; CFL = (u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) else ; CFL = u(I) * dt * G%IdxT(i,j) ; endif - curv_3 = h_L(i) + h_R(i) - 2.0*h(i) + curv_3 = h_W(i) + h_E(i) - 2.0*h(i) uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * & - (h_R(i) + CFL * (0.5*(h_L(i) - h_R(i)) + curv_3*(CFL - 1.5))) - h_marg = h_R(i) + CFL * ((h_L(i) - h_R(i)) + 3.0*curv_3*(CFL - 1.0)) + (h_E(i) + CFL * (0.5*(h_W(i) - h_E(i)) + curv_3*(CFL - 1.5))) + h_marg = h_E(i) + CFL * ((h_W(i) - h_E(i)) + 3.0*curv_3*(CFL - 1.0)) elseif (u(I) < 0.0) then if (vol_CFL) then ; CFL = (-u(I) * dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else ; CFL = -u(I) * dt * G%IdxT(i+1,j) ; endif - curv_3 = h_L(i+1) + h_R(i+1) - 2.0*h(i+1) + curv_3 = h_W(i+1) + h_E(i+1) - 2.0*h(i+1) uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * & - (h_L(i+1) + CFL * (0.5*(h_R(i+1)-h_L(i+1)) + curv_3*(CFL - 1.5))) - h_marg = h_L(i+1) + CFL * ((h_R(i+1)-h_L(i+1)) + 3.0*curv_3*(CFL - 1.0)) + (h_W(i+1) + CFL * (0.5*(h_E(i+1)-h_W(i+1)) + curv_3*(CFL - 1.5))) + h_marg = h_W(i+1) + CFL * ((h_E(i+1)-h_W(i+1)) + 3.0*curv_3*(CFL - 1.0)) else uh(I) = 0.0 - h_marg = 0.5 * (h_L(i+1) + h_R(i)) + h_marg = 0.5 * (h_W(i+1) + h_E(i)) endif duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h_marg * visc_rem(I) endif ; enddo @@ -611,18 +689,18 @@ subroutine zonal_flux_layer(u, h, h_L, h_R, uh, duhdu, visc_rem, dt, G, US, j, & endif end subroutine zonal_flux_layer -!> Sets the effective interface thickness at each zonal velocity point, optionally scaling -!! back these thicknesses to account for viscosity and fractional open areas. -subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, & +!> Sets the effective interface thickness associated with the fluxes at each zonal velocity point, +!! optionally scaling back these thicknesses to account for viscosity and fractional open areas. +subroutine zonal_flux_thickness(u, h, h_W, h_E, h_u, dt, G, GV, US, LB, vol_CFL, & marginal, OBC, por_face_areaU, visc_rem_u) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the !! reconstruction [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h_u !< Effective thickness at zonal faces, !! scaled down to account for the effects of @@ -659,23 +737,23 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, if (u(I,j,k) > 0.0) then if (vol_CFL) then ; CFL = (u(I,j,k) * dt) * (G%dy_Cu(I,j) * G%IareaT(i,j)) else ; CFL = u(I,j,k) * dt * G%IdxT(i,j) ; endif - curv_3 = h_L(i,j,k) + h_R(i,j,k) - 2.0*h(i,j,k) - h_avg = h_R(i,j,k) + CFL * (0.5*(h_L(i,j,k) - h_R(i,j,k)) + curv_3*(CFL - 1.5)) - h_marg = h_R(i,j,k) + CFL * ((h_L(i,j,k) - h_R(i,j,k)) + 3.0*curv_3*(CFL - 1.0)) + curv_3 = h_W(i,j,k) + h_E(i,j,k) - 2.0*h(i,j,k) + h_avg = h_E(i,j,k) + CFL * (0.5*(h_W(i,j,k) - h_E(i,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_E(i,j,k) + CFL * ((h_W(i,j,k) - h_E(i,j,k)) + 3.0*curv_3*(CFL - 1.0)) elseif (u(I,j,k) < 0.0) then if (vol_CFL) then ; CFL = (-u(I,j,k)*dt) * (G%dy_Cu(I,j) * G%IareaT(i+1,j)) else ; CFL = -u(I,j,k) * dt * G%IdxT(i+1,j) ; endif - curv_3 = h_L(i+1,j,k) + h_R(i+1,j,k) - 2.0*h(i+1,j,k) - h_avg = h_L(i+1,j,k) + CFL * (0.5*(h_R(i+1,j,k)-h_L(i+1,j,k)) + curv_3*(CFL - 1.5)) - h_marg = h_L(i+1,j,k) + CFL * ((h_R(i+1,j,k)-h_L(i+1,j,k)) + & + curv_3 = h_W(i+1,j,k) + h_E(i+1,j,k) - 2.0*h(i+1,j,k) + h_avg = h_W(i+1,j,k) + CFL * (0.5*(h_E(i+1,j,k)-h_W(i+1,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_W(i+1,j,k) + CFL * ((h_E(i+1,j,k)-h_W(i+1,j,k)) + & 3.0*curv_3*(CFL - 1.0)) else - h_avg = 0.5 * (h_L(i+1,j,k) + h_R(i,j,k)) + h_avg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k)) ! The choice to use the arithmetic mean here is somewhat arbitrarily, but - ! it should be noted that h_L(i+1,j,k) and h_R(i,j,k) are usually the same. - h_marg = 0.5 * (h_L(i+1,j,k) + h_R(i,j,k)) - ! h_marg = (2.0 * h_L(i+1,j,k) * h_R(i,j,k)) / & - ! (h_L(i+1,j,k) + h_R(i,j,k) + GV%H_subroundoff) + ! it should be noted that h_W(i+1,j,k) and h_E(i,j,k) are usually the same. + h_marg = 0.5 * (h_W(i+1,j,k) + h_E(i,j,k)) + ! h_marg = (2.0 * h_W(i+1,j,k) * h_E(i,j,k)) / & + ! (h_W(i+1,j,k) + h_E(i,j,k) + GV%H_subroundoff) endif if (marginal) then ; h_u(I,j,k) = h_marg @@ -727,11 +805,11 @@ subroutine zonal_face_thickness(u, h, h_L, h_R, h_u, dt, G, GV, US, LB, vol_CFL, enddo endif -end subroutine zonal_face_thickness +end subroutine zonal_flux_thickness !> Returns the barotropic velocity adjustment that gives the !! desired barotropic (layer-summed) transport. -subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & +subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uhbt, uh_tot_0, duhdu_tot_0, & du, du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, por_face_areaU, uh_3d, OBC) @@ -740,9 +818,9 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the !! reconstruction [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the !! momentum originally in a layer that remains after a time-step of viscosity, and @@ -854,7 +932,7 @@ subroutine zonal_flux_adjust(u, h_in, h_L, h_R, uhbt, uh_tot_0, duhdu_tot_0, & if ((itt < max_itts) .or. present(uh_3d)) then ; do k=1,nz do I=ish-1,ieh ; u_new(I) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo - call zonal_flux_layer(u_new, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), & + call zonal_flux_layer(u_new, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), & uh_aux(:,k), duhdu(:,k), visc_rem(:,k), & dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) enddo ; endif @@ -884,7 +962,7 @@ end subroutine zonal_flux_adjust !> Sets a structure that describes the zonal barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. -subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, & +subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaU) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. @@ -892,9 +970,9 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to !! calculate fluxes [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< West edge thickness in the !! reconstruction [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< East edge thickness in the !! reconstruction [H ~> m or kg m-2]. type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements !! that describe the effective open face areas as a function of barotropic flow. @@ -961,7 +1039,7 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, ! Diagnose the zero-transport correction, du0. do I=ish-1,ieh ; zeros(I) = 0.0 ; enddo - call zonal_flux_adjust(u, h_in, h_L, h_R, zeros, uh_tot_0, duhdu_tot_0, du0, & + call zonal_flux_adjust(u, h_in, h_W, h_E, zeros, uh_tot_0, duhdu_tot_0, du0, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaU) @@ -1003,11 +1081,11 @@ subroutine set_zonal_BT_cont(u, h_in, h_L, h_R, BT_cont, uh_tot_0, duhdu_tot_0, u_R(I) = u(I,j,k) + duR(I) * visc_rem(I,k) u_0(I) = u(I,j,k) + du0(I) * visc_rem(I,k) endif ; enddo - call zonal_flux_layer(u_0, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_0, duhdu_0, & + call zonal_flux_layer(u_0, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_0, duhdu_0, & visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) - call zonal_flux_layer(u_L, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_L, duhdu_L, & + call zonal_flux_layer(u_L, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_L, duhdu_L, & visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) - call zonal_flux_layer(u_R, h_in(:,j,k), h_L(:,j,k), h_R(:,j,k), uh_R, duhdu_R, & + call zonal_flux_layer(u_R, h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh_R, duhdu_R, & visc_rem(:,k), dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k)) do I=ish-1,ieh ; if (do_I(I)) then FAmt_0(I) = FAmt_0(I) + duhdu_0(I) @@ -1086,7 +1164,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar real, dimension(SZI_(G),SZK_(GV)) :: & dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - h_L, h_R ! Left and right face thicknesses [H ~> m or kg m-2]. + h_S, h_N ! Southern and northern face thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & dv, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. dv_min_CFL, & ! Lower limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] @@ -1133,23 +1211,13 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar if (CS%aggress_adjust) CFL_dt = I_dt call cpu_clock_begin(id_clock_update) -!$OMP parallel do default(none) shared(nz,ish,ieh,jsh,jeh,h_in,h_L,h_R,G,GV,LB,CS,visc_rem,OBC) - do k=1,nz - ! This sets h_L and h_R. - if (CS%upwind_1st) then - do j=jsh-1,jeh+1 ; do i=ish,ieh - h_L(i,j,k) = h_in(i,j,k) ; h_R(i,j,k) = h_in(i,j,k) - enddo ; enddo - else - call PPM_reconstruction_y(h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), G, LB, & - 2.0*GV%Angstrom_H, CS%monotonic, CS%simple_2nd, OBC) - endif - do i=ish,ieh ; visc_rem(i,k) = 1.0 ; enddo - enddo + ! This sets h_S and h_N. + call meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB) call cpu_clock_end(id_clock_update) call cpu_clock_begin(id_clock_correct) -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_L,h_R,vh,use_visc_rem, & + if (.not.use_visc_rem) visc_rem(:,:) = 1.0 +!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_S,h_N,vh,use_visc_rem, & !$OMP visc_rem_v,dt,US,G,GV,CS,local_specified_BC,OBC,vhbt, & !$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC, & !$OMP por_face_areaV) & @@ -1158,32 +1226,33 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar !$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & !$OMP firstprivate(visc_rem) do J=jsh-1,jeh - do i=ish,ieh ; do_I(i) = .true. ; visc_rem_max(I) = 0.0 ; enddo + do i=ish,ieh ; do_I(i) = .true. ; enddo ! This sets vh and dvhdv. do k=1,nz if (use_visc_rem) then ; do i=ish,ieh visc_rem(i,k) = visc_rem_v(i,J,k) - visc_rem_max(i) = max(visc_rem_max(i), visc_rem(i,k)) enddo ; endif - call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), & + call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), & vh(:,J,k), dvhdv(:,k), visc_rem(:,k), & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) if (local_specified_BC) then - do i=ish,ieh + do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%specified) & - vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) - endif - enddo + if (OBC%segment(l_seg)%specified) & + vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + endif ; enddo endif enddo ! k-loop - if ((.not.use_visc_rem) .or. (.not.CS%use_visc_rem_max)) then ; do i=ish,ieh - visc_rem_max(i) = 1.0 - enddo ; endif if (present(vhbt) .or. set_BT_cont) then + if (use_visc_rem .and. CS%use_visc_rem_max) then + visc_rem_max(:) = 0.0 + do k=1,nz ; do i=ish,ieh + visc_rem_max(i) = max(visc_rem_max(i), visc_rem(i,k)) + enddo ; enddo + else + visc_rem_max(:) = 1.0 + endif ! Set limits on dv that will keep the CFL number between -1 and 1. ! This should be adequate to keep the root bracketed in all cases. do i=ish,ieh @@ -1274,7 +1343,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar endif if (present(vhbt)) then - call meridional_flux_adjust(v, h_in, h_L, h_R, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & + call meridional_flux_adjust(v, h_in, h_S, h_N, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaV, vh, OBC=OBC) @@ -1292,7 +1361,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar endif if (set_BT_cont) then - call set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0,& + call set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0,& dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, J, ish, ieh, do_I, por_face_areaV) if (any_simple_OBC) then @@ -1352,18 +1421,18 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then if (present(v_cor)) then - call merid_face_thickness(v_cor, h_in, h_L, h_R, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + call meridional_flux_thickness(v_cor, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) else - call merid_face_thickness(v, h_in, h_L, h_R, BT_cont%h_v, dt, G, GV, US, LB, & - CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) + call meridional_flux_thickness(v, h_in, h_S, h_N, BT_cont%h_v, dt, G, GV, US, LB, & + CS%vol_CFL, CS%marginal_faces, OBC, por_face_areaV, visc_rem_v) endif endif ; endif end subroutine meridional_mass_flux !> Evaluates the meridional mass or volume fluxes in a layer. -subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & +subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & ish, ieh, do_I, vol_CFL, por_face_areaV, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. @@ -1374,9 +1443,9 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_L !< Left thickness in the reconstruction + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_S !< South edge thickness in the reconstruction !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_R !< Right thickness in the reconstruction + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_N !< North edge thickness in the reconstruction !! [H ~> m or kg m-2]. real, dimension(SZI_(G)), intent(inout) :: vh !< Meridional mass or volume transport !! [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -1411,22 +1480,22 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & if (v(i) > 0.0) then if (vol_CFL) then ; CFL = (v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i) * dt * G%IdyT(i,j) ; endif - curv_3 = h_L(i,j) + h_R(i,j) - 2.0*h(i,j) - vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_R(i,j) + CFL * & - (0.5*(h_L(i,j) - h_R(i,j)) + curv_3*(CFL - 1.5)) ) - h_marg = h_R(i,j) + CFL * ((h_L(i,j) - h_R(i,j)) + & + curv_3 = h_S(i,j) + h_N(i,j) - 2.0*h(i,j) + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_N(i,j) + CFL * & + (0.5*(h_S(i,j) - h_N(i,j)) + curv_3*(CFL - 1.5)) ) + h_marg = h_N(i,j) + CFL * ((h_S(i,j) - h_N(i,j)) + & 3.0*curv_3*(CFL - 1.0)) elseif (v(i) < 0.0) then if (vol_CFL) then ; CFL = (-v(i) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i) * dt * G%IdyT(i,j+1) ; endif - curv_3 = h_L(i,j+1) + h_R(i,j+1) - 2.0*h(i,j+1) - vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_L(i,j+1) + CFL * & - (0.5*(h_R(i,j+1)-h_L(i,j+1)) + curv_3*(CFL - 1.5)) ) - h_marg = h_L(i,j+1) + CFL * ((h_R(i,j+1)-h_L(i,j+1)) + & + curv_3 = h_S(i,j+1) + h_N(i,j+1) - 2.0*h(i,j+1) + vh(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * v(i) * ( h_S(i,j+1) + CFL * & + (0.5*(h_N(i,j+1)-h_S(i,j+1)) + curv_3*(CFL - 1.5)) ) + h_marg = h_S(i,j+1) + CFL * ((h_N(i,j+1)-h_S(i,j+1)) + & 3.0*curv_3*(CFL - 1.0)) else vh(i) = 0.0 - h_marg = 0.5 * (h_L(i,j+1) + h_R(i,j)) + h_marg = 0.5 * (h_S(i,j+1) + h_N(i,j)) endif dvhdv(i) = (G%dx_Cv(i,J)*por_face_areaV(i,J)) * h_marg * visc_rem(i) endif ; enddo @@ -1450,18 +1519,18 @@ subroutine merid_flux_layer(v, h, h_L, h_R, vh, dvhdv, visc_rem, dt, G, US, J, & endif end subroutine merid_flux_layer -!> Sets the effective interface thickness at each meridional velocity point, optionally scaling -!! back these thicknesses to account for viscosity and fractional open areas. -subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, & - marginal, OBC, por_face_areaV, visc_rem_v) +!> Sets the effective interface thickness associated with the fluxes at each meridional velocity point, +!! optionally scaling back these thicknesses to account for viscosity and fractional open areas. +subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol_CFL, & + marginal, OBC, por_face_areaV, visc_rem_v) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: h_v !< Effective thickness at meridional faces, !! scaled down to account for the effects of @@ -1498,24 +1567,24 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, if (v(i,J,k) > 0.0) then if (vol_CFL) then ; CFL = (v(i,J,k) * dt) * (G%dx_Cv(i,J) * G%IareaT(i,j)) else ; CFL = v(i,J,k) * dt * G%IdyT(i,j) ; endif - curv_3 = h_L(i,j,k) + h_R(i,j,k) - 2.0*h(i,j,k) - h_avg = h_R(i,j,k) + CFL * (0.5*(h_L(i,j,k) - h_R(i,j,k)) + curv_3*(CFL - 1.5)) - h_marg = h_R(i,j,k) + CFL * ((h_L(i,j,k) - h_R(i,j,k)) + & + curv_3 = h_S(i,j,k) + h_N(i,j,k) - 2.0*h(i,j,k) + h_avg = h_N(i,j,k) + CFL * (0.5*(h_S(i,j,k) - h_N(i,j,k)) + curv_3*(CFL - 1.5)) + h_marg = h_N(i,j,k) + CFL * ((h_S(i,j,k) - h_N(i,j,k)) + & 3.0*curv_3*(CFL - 1.0)) elseif (v(i,J,k) < 0.0) then if (vol_CFL) then ; CFL = (-v(i,J,k)*dt) * (G%dx_Cv(i,J) * G%IareaT(i,j+1)) else ; CFL = -v(i,J,k) * dt * G%IdyT(i,j+1) ; endif - curv_3 = h_L(i,j+1,k) + h_R(i,j+1,k) - 2.0*h(i,j+1,k) - h_avg = h_L(i,j+1,k) + CFL * (0.5*(h_R(i,j+1,k)-h_L(i,j+1,k)) + curv_3*(CFL - 1.5)) - h_marg = h_L(i,j+1,k) + CFL * ((h_R(i,j+1,k)-h_L(i,j+1,k)) + & + curv_3 = h_S(i,j+1,k) + h_N(i,j+1,k) - 2.0*h(i,j+1,k) + h_avg = h_S(i,j+1,k) + CFL * (0.5*(h_N(i,j+1,k)-h_S(i,j+1,k)) + curv_3*(CFL - 1.5)) + h_marg = h_S(i,j+1,k) + CFL * ((h_N(i,j+1,k)-h_S(i,j+1,k)) + & 3.0*curv_3*(CFL - 1.0)) else - h_avg = 0.5 * (h_L(i,j+1,k) + h_R(i,j,k)) + h_avg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k)) ! The choice to use the arithmetic mean here is somewhat arbitrarily, but - ! it should be noted that h_L(i+1,j,k) and h_R(i,j,k) are usually the same. - h_marg = 0.5 * (h_L(i,j+1,k) + h_R(i,j,k)) - ! h_marg = (2.0 * h_L(i,j+1,k) * h_R(i,j,k)) / & - ! (h_L(i,j+1,k) + h_R(i,j,k) + GV%H_subroundoff) + ! it should be noted that h_S(i+1,j,k) and h_N(i,j,k) are usually the same. + h_marg = 0.5 * (h_S(i,j+1,k) + h_N(i,j,k)) + ! h_marg = (2.0 * h_S(i,j+1,k) * h_N(i,j,k)) / & + ! (h_S(i,j+1,k) + h_N(i,j,k) + GV%H_subroundoff) endif if (marginal) then ; h_v(i,J,k) = h_marg @@ -1568,10 +1637,10 @@ subroutine merid_face_thickness(v, h, h_L, h_R, h_v, dt, G, GV, US, LB, vol_CFL, enddo endif -end subroutine merid_face_thickness +end subroutine meridional_flux_thickness !> Returns the barotropic velocity adjustment that gives the desired barotropic (layer-summed) transport. -subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0, & +subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0, & dv, dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I_in, por_face_areaV, vh_3d, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. @@ -1581,9 +1650,9 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),& - intent(in) :: h_L !< Left thickness in the reconstruction [H ~> m or kg m-2]. + intent(in) :: h_S !< South edge thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h_R !< Right thickness in the reconstruction [H ~> m or kg m-2]. + intent(in) :: h_N !< North edge thickness in the reconstruction [H ~> m or kg m-2]. real, dimension(SZI_(G),SZK_(GV)), intent(in) :: visc_rem !< Both the fraction of the momentum originally !! in a layer that remains after a time-step of viscosity, and the @@ -1693,7 +1762,7 @@ subroutine meridional_flux_adjust(v, h_in, h_L, h_R, vhbt, vh_tot_0, dvhdv_tot_0 if ((itt < max_itts) .or. present(vh_3d)) then ; do k=1,nz do i=ish,ieh ; v_new(i) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo - call merid_flux_layer(v_new, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), & + call merid_flux_layer(v_new, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), & vh_aux(:,k), dvhdv(:,k), visc_rem(:,k), & dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) enddo ; endif @@ -1723,7 +1792,7 @@ end subroutine meridional_flux_adjust !> Sets of a structure that describes the meridional barotropic volume or mass fluxes as a !! function of barotropic flow to agree closely with the sum of the layer's transports. -subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, & +subroutine set_merid_BT_cont(v, h_in, h_S, h_N, BT_cont, vh_tot_0, dvhdv_tot_0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & visc_rem_max, j, ish, ieh, do_I, por_face_areaV) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. @@ -1731,9 +1800,9 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to calculate fluxes, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. type(BT_cont_type), intent(inout) :: BT_cont !< A structure with elements !! that describe the effective open face areas as a function of barotropic flow. @@ -1800,7 +1869,7 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, ! Diagnose the zero-transport correction, dv0. do i=ish,ieh ; zeros(i) = 0.0 ; enddo - call meridional_flux_adjust(v, h_in, h_L, h_R, zeros, vh_tot_0, dvhdv_tot_0, dv0, & + call meridional_flux_adjust(v, h_in, h_S, h_N, zeros, vh_tot_0, dvhdv_tot_0, dv0, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaV) @@ -1842,11 +1911,11 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, v_R(i) = v(I,j,k) + dvR(i) * visc_rem(i,k) v_0(i) = v(I,j,k) + dv0(i) * visc_rem(i,k) endif ; enddo - call merid_flux_layer(v_0, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_0, dvhdv_0, & + call merid_flux_layer(v_0, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_0, dvhdv_0, & visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) - call merid_flux_layer(v_L, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_L, dvhdv_L, & + call merid_flux_layer(v_L, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_L, dvhdv_L, & visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) - call merid_flux_layer(v_R, h_in(:,:,k), h_L(:,:,k), h_R(:,:,k), vh_R, dvhdv_R, & + call merid_flux_layer(v_R, h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh_R, dvhdv_R, & visc_rem(:,k), dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k)) do i=ish,ieh ; if (do_I(i)) then FAmt_0(i) = FAmt_0(i) + dvhdv_0(i) @@ -1887,12 +1956,12 @@ subroutine set_merid_BT_cont(v, h_in, h_L, h_R, BT_cont, vh_tot_0, dvhdv_tot_0, end subroutine set_merid_BT_cont !> Calculates left/right edge values for PPM reconstruction. -subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_2nd, OBC) +subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_2nd, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_W !< West edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_E !< East edge thickness in the reconstruction, !! [H ~> m or kg m-2]. type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness @@ -1943,8 +2012,8 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ do j=jsl,jel ; do i=isl,iel h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) - h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) - h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) enddo ; enddo else do j=jsl,jel ; do i=isl-1,iel+1 @@ -1984,8 +2053,8 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ h_im1 = G%mask2dT(i-1,j) * h_in(i-1,j) + (1.0-G%mask2dT(i-1,j)) * h_in(i,j) h_ip1 = G%mask2dT(i+1,j) * h_in(i+1,j) + (1.0-G%mask2dT(i+1,j)) * h_in(i,j) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) - h_L(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) - h_R(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) + h_W(i,j) = 0.5*( h_im1 + h_in(i,j) ) + oneSixth*( slp(i-1,j) - slp(i,j) ) + h_E(i,j) = 0.5*( h_ip1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i+1,j) ) enddo ; enddo endif @@ -1996,39 +2065,39 @@ subroutine PPM_reconstruction_x(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if (segment%direction == OBC_DIRECTION_E) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - h_L(i+1,j) = h_in(i,j) - h_R(i+1,j) = h_in(i,j) - h_L(i,j) = h_in(i,j) - h_R(i,j) = h_in(i,j) + h_W(i+1,j) = h_in(i,j) + h_E(i+1,j) = h_in(i,j) + h_W(i,j) = h_in(i,j) + h_E(i,j) = h_in(i,j) enddo elseif (segment%direction == OBC_DIRECTION_W) then I=segment%HI%IsdB do j=segment%HI%jsd,segment%HI%jed - h_L(i,j) = h_in(i+1,j) - h_R(i,j) = h_in(i+1,j) - h_L(i+1,j) = h_in(i+1,j) - h_R(i+1,j) = h_in(i+1,j) + h_W(i,j) = h_in(i+1,j) + h_E(i,j) = h_in(i+1,j) + h_W(i+1,j) = h_in(i+1,j) + h_E(i+1,j) = h_in(i+1,j) enddo endif enddo endif if (monotonic) then - call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) + call PPM_limit_CW84(h_in, h_W, h_E, G, isl, iel, jsl, jel) else - call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) + call PPM_limit_pos(h_in, h_W, h_E, h_min, G, isl, iel, jsl, jel) endif return end subroutine PPM_reconstruction_x !> Calculates left/right edge values for PPM reconstruction. -subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_2nd, OBC) +subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_2nd, OBC) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. real, dimension(SZI_(G),SZJ_(G)), intent(in) :: h_in !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_L !< Left thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_S !< South edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_R !< Right thickness in the reconstruction, + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness @@ -2079,8 +2148,8 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ do j=jsl,jel ; do i=isl,iel h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) - h_L(i,j) = 0.5*( h_jm1 + h_in(i,j) ) - h_R(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) enddo ; enddo else do j=jsl-1,jel+1 ; do i=isl,iel @@ -2118,8 +2187,8 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ h_jm1 = G%mask2dT(i,j-1) * h_in(i,j-1) + (1.0-G%mask2dT(i,j-1)) * h_in(i,j) h_jp1 = G%mask2dT(i,j+1) * h_in(i,j+1) + (1.0-G%mask2dT(i,j+1)) * h_in(i,j) ! Left/right values following Eq. B2 in Lin 1994, MWR (132) - h_L(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) ) - h_R(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) ) + h_S(i,j) = 0.5*( h_jm1 + h_in(i,j) ) + oneSixth*( slp(i,j-1) - slp(i,j) ) + h_N(i,j) = 0.5*( h_jp1 + h_in(i,j) ) + oneSixth*( slp(i,j) - slp(i,j+1) ) enddo ; enddo endif @@ -2130,27 +2199,27 @@ subroutine PPM_reconstruction_y(h_in, h_L, h_R, G, LB, h_min, monotonic, simple_ if (segment%direction == OBC_DIRECTION_N) then J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - h_L(i,j+1) = h_in(i,j) - h_R(i,j+1) = h_in(i,j) - h_L(i,j) = h_in(i,j) - h_R(i,j) = h_in(i,j) + h_S(i,j+1) = h_in(i,j) + h_N(i,j+1) = h_in(i,j) + h_S(i,j) = h_in(i,j) + h_N(i,j) = h_in(i,j) enddo elseif (segment%direction == OBC_DIRECTION_S) then J=segment%HI%JsdB do i=segment%HI%isd,segment%HI%ied - h_L(i,j) = h_in(i,j+1) - h_R(i,j) = h_in(i,j+1) - h_L(i,j+1) = h_in(i,j+1) - h_R(i,j+1) = h_in(i,j+1) + h_S(i,j) = h_in(i,j+1) + h_N(i,j) = h_in(i,j+1) + h_S(i,j+1) = h_in(i,j+1) + h_N(i,j+1) = h_in(i,j+1) enddo endif enddo endif if (monotonic) then - call PPM_limit_CW84(h_in, h_L, h_R, G, isl, iel, jsl, jel) + call PPM_limit_CW84(h_in, h_S, h_N, G, isl, iel, jsl, jel) else - call PPM_limit_pos(h_in, h_L, h_R, h_min, G, isl, iel, jsl, jel) + call PPM_limit_pos(h_in, h_S, h_N, h_min, G, isl, iel, jsl, jel) endif return From d3496fee35eeb5b16cbe0e02afe6940a6ad94da0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Nov 2023 11:41:27 -0500 Subject: [PATCH 491/629] +Call zonal_edge_thickness outside of zonal_mass_flux Moved the calls to zonal_edge_thickness and meridional_edge_thickness out of zonal_mass_flux and meridional_mass_flux to facilitate the reuse at some later date of the PPM thickness reconstructions. As a part of this, there are new edge thickness arguments to zonal_mass_flux and meridional_mass_flux. The interfaces to zonal_edge_thickness and meridional_edge_thickness are new publicly visible and are used in MOM_continuity. This commits also changes the name of the loop_bounds_type to cont_loop_bounds_type and makes it public but opaque adds the publicly visible function set_continuity_loop_bounds to enable the continuity loop bounds to be set from outside of the continuity_PPM module. Reflecting these changes there are new calls to zonal_edge_thickness and meridional_edge_thickness in the 3 routines in MOM_continuity and in continuity_PPM, and new arrays for holding the edge thicknesses in these routines. All answers are bitwise identical, but there are new publicly visible interfaces and types and changes to other publicly visible interfaces. However, no changes are required outside of MOM_continuity and MOM_continuity_PPM. --- src/core/MOM_continuity.F90 | 39 ++++-- src/core/MOM_continuity_PPM.F90 | 231 ++++++++++++++++++-------------- 2 files changed, 156 insertions(+), 114 deletions(-) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 44422d5e47..116bf8f195 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -7,6 +7,7 @@ module MOM_continuity use MOM_continuity_PPM, only : continuity_stencil=>continuity_PPM_stencil use MOM_continuity_PPM, only : continuity_init=>continuity_PPM_init use MOM_continuity_PPM, only : continuity_CS=>continuity_PPM_CS +use MOM_continuity_PPM, only : zonal_edge_thickness, meridional_edge_thickness use MOM_continuity_PPM, only : zonal_mass_flux, meridional_mass_flux use MOM_diag_mediator, only : time_type use MOM_grid, only : ocean_grid_type @@ -56,9 +57,17 @@ subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) end subroutine continuity_3d_fluxes @@ -88,18 +97,22 @@ subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics ! Local variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh ! Thickness fluxes through zonal faces, - ! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh ! Thickness fluxes through meridional faces, - ! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: uh(SZIB_(G),SZJ_(G),SZK_(GV)) ! Thickness fluxes through zonal faces, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: vh(SZI_(G),SZJB_(G),SZK_(GV)) ! Thickness fluxes through v-point faces, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] integer :: i, j, k uh(:,:,:) = 0.0 vh(:,:,:) = 0.0 - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) uhbt(:,:) = 0.0 vhbt(:,:) = 0.0 @@ -167,16 +180,22 @@ subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhb !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh !< Volume flux through meridional faces = !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] ! It might not be necessary to separate the input velocity array from the adjusted velocities, ! but it seems safer to do so, even if it might be less efficient. u_in(:,:,:) = u(:,:,:) v_in(:,:,:) = v(:,:,:) - call zonal_mass_flux(u_in, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u_in, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) - call meridional_mass_flux(v_in, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v_in, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) end subroutine continuity_adjust_vel diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 415d04dd36..0abc0c5568 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -22,6 +22,7 @@ module MOM_continuity_PPM public zonal_mass_flux, meridional_mass_flux public zonal_flux_thickness, meridional_flux_thickness public zonal_edge_thickness, meridional_edge_thickness +public set_continuity_loop_bounds !>@{ CPU time clock IDs integer :: id_clock_update, id_clock_correct @@ -63,11 +64,11 @@ module MOM_continuity_PPM end type continuity_PPM_CS !> A container for loop bounds -type :: loop_bounds_type ; private +type, public :: cont_loop_bounds_type ; private !>@{ Loop bounds integer :: ish, ieh, jsh, jeh !>@} -end type loop_bounds_type +end type cont_loop_bounds_type contains @@ -125,8 +126,12 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb !! the effective open face areas as a function of barotropic flow. ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. - type(loop_bounds_type) :: LB + type(cont_loop_bounds_type) :: LB integer :: is, ie, js, je, nz, stencil integer :: i, j, k @@ -147,10 +152,13 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb stencil = continuity_PPM_stencil(CS) if (x_first) then - ! First, advect zonally. - LB%ish = G%isc ; LB%ieh = G%iec - LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil - call zonal_mass_flux(u, hin, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + ! First advect zonally, with loop bounds that accomodate the subsequent meridional advection. + LB = set_continuity_loop_bounds(G, CS, .false., .true.) + + call cpu_clock_begin(id_clock_update) + call zonal_edge_thickness(hin, h_W, h_E, G, GV, US, CS, OBC, LB) + call cpu_clock_end(id_clock_update) + call zonal_mass_flux(u, hin, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & LB, uhbt, visc_rem_u, u_cor, BT_cont) call cpu_clock_begin(id_clock_update) @@ -160,13 +168,14 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb ! Uncomment this line to prevent underflow. ! if (h(i,j,k) < h_min) h(i,j,k) = h_min enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + LB = set_continuity_loop_bounds(G, CS, .false., .false.) - ! Now advect meridionally, using the updated thicknesses to determine - ! the fluxes. - call meridional_mass_flux(v, h, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + ! Now advect meridionally, using the updated thicknesses to determine the fluxes. + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC, LB) + call cpu_clock_end(id_clock_update) + + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & LB, vhbt, visc_rem_v, v_cor, BT_cont) call cpu_clock_begin(id_clock_update) @@ -179,11 +188,13 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb call cpu_clock_end(id_clock_update) else ! .not. x_first - ! First, advect meridionally, so set the loop bounds accordingly. - LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil - LB%jsh = G%jsc ; LB%jeh = G%jec + ! First advect meridionally, with loop bounds that accomodate the subsequent zonal advection. + LB = set_continuity_loop_bounds(G, CS, .true., .false.) - call meridional_mass_flux(v, hin, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + call cpu_clock_begin(id_clock_update) + call meridional_edge_thickness(hin, h_S, h_N, G, GV, US, CS, OBC, LB) + call cpu_clock_end(id_clock_update) + call meridional_mass_flux(v, hin, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & LB, vhbt, visc_rem_v, v_cor, BT_cont) call cpu_clock_begin(id_clock_update) @@ -191,12 +202,13 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) - ! Now advect zonally, using the updated thicknesses to determine - ! the fluxes. - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec - call zonal_mass_flux(u, h, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + LB = set_continuity_loop_bounds(G, CS, .false., .false.) + + ! Now advect zonally, using the updated thicknesses to determine the fluxes. + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC, LB) + call cpu_clock_end(id_clock_update) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & LB, uhbt, visc_rem_u, u_cor, BT_cont) call cpu_clock_begin(id_clock_update) @@ -225,11 +237,11 @@ subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(loop_bounds_type), & + type(cont_loop_bounds_type), & optional, intent(in) :: LB_in !< Loop bounds structure. ! Local variables - type(loop_bounds_type) :: LB + type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, nz if (present(LB_in)) then @@ -268,11 +280,11 @@ subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure. type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(loop_bounds_type), & + type(cont_loop_bounds_type), & optional, intent(in) :: LB_in !< Loop bounds structure. ! Local variables - type(loop_bounds_type) :: LB + type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, nz if (present(LB_in)) then @@ -299,7 +311,7 @@ end subroutine meridional_edge_thickness !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. -subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & +subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & LB_in, uhbt, visc_rem_u, u_cor, BT_cont) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. @@ -307,6 +319,10 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(in) :: h_in !< Layer thickness used to calculate fluxes [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_W !< Western edge thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_E !< Eastern edge thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & intent(out) :: uh !< Volume flux through zonal faces = u*h*dy !! [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -316,7 +332,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. real, dimension(SZIB_(G), SZJ_(G), SZK_(G)), & intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] - type(loop_bounds_type), & + type(cont_loop_bounds_type), & optional, intent(in) :: LB_in !< Loop bounds structure. real, dimension(SZIB_(G),SZJ_(G)), & optional, intent(in) :: uhbt !< The summed volume flux through zonal faces @@ -336,7 +352,6 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, ! Local variables real, dimension(SZIB_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_W, h_E ! Left and right face thicknesses [H ~> m or kg m-2]. real, dimension(SZIB_(G)) :: & du, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. du_min_CFL, & ! Lower limit on du correction to avoid CFL violations [L T-1 ~> m s-1] @@ -355,7 +370,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. real :: du_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. - type(loop_bounds_type) :: LB + type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC @@ -382,11 +397,6 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt - call cpu_clock_begin(id_clock_update) - ! This sets h_W and h_E. - call zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB) - call cpu_clock_end(id_clock_update) - call cpu_clock_begin(id_clock_correct) if (.not.use_visc_rem) visc_rem(:,:) = 1.0 !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_W,h_E,use_visc_rem,visc_rem_u, & @@ -410,8 +420,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, if (local_specified_BC) then do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then l_seg = OBC%segnum_u(I,j) - if (OBC%segment(l_seg)%specified) & - uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) + if (OBC%segment(l_seg)%specified) uh(I,j,k) = OBC%segment(l_seg)%normal_trans(I,j,k) endif ; enddo endif enddo @@ -508,8 +517,7 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, ! Avoid reconciling barotropic/baroclinic transports if transport is specified is_simple = .false. - if (l_seg /= OBC_NONE) & - is_simple = OBC%segment(l_seg)%specified + if (l_seg /= OBC_NONE) is_simple = OBC%segment(l_seg)%specified do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do I=ish-1,ieh @@ -525,11 +533,9 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo if (local_specified_BC) then ; do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%specified) & - u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) + if (OBC%segnum_u(I,j) /= OBC_NONE) then + l_seg = OBC%segnum_u(I,j) + if (OBC%segment(l_seg)%specified) u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) endif enddo ; endif enddo ; endif ! u-corrected @@ -542,11 +548,8 @@ subroutine zonal_mass_flux(u, h_in, uh, dt, G, GV, US, CS, OBC, por_face_areaU, visc_rem_max, j, ish, ieh, do_I, por_face_areaU) if (any_simple_OBC) then do I=ish-1,ieh - l_seg = OBC%segnum_u(I,j) - do_I(I) = .false. - if (l_seg /= OBC_NONE) & - do_I(I) = OBC%segment(l_seg)%specified + if (OBC%segnum_u(I,j) /= OBC_NONE) do_I(I) = OBC%segment(OBC%segnum_u(I,j))%specified if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo @@ -671,21 +674,18 @@ subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & endif ; enddo if (local_open_BC) then - do I=ish-1,ieh ; if (do_I(I)) then + do I=ish-1,ieh ; if (do_I(I)) then ; if (OBC%segnum_u(I,j) /= OBC_NONE) then l_seg = OBC%segnum_u(I,j) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(l_seg)%open) then - if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then - uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) - duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I) - else - uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) - duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I) - endif + if (OBC%segment(l_seg)%open) then + if (OBC%segment(l_seg)%direction == OBC_DIRECTION_E) then + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i) + duhdu(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * h(i) * visc_rem(I) + else + uh(I) = (G%dy_Cu(I,j) * por_face_areaU(I)) * u(I) * h(i+1) + duhdu(I) = (G%dy_Cu(I,j)* por_face_areaU(I)) * h(i+1) * visc_rem(I) endif endif - endif ; enddo + endif ; endif ; enddo endif end subroutine zonal_flux_layer @@ -708,7 +708,7 @@ subroutine zonal_flux_thickness(u, h, h_W, h_E, h_u, dt, G, GV, US, LB, vol_CFL, !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure. logical, intent(in) :: vol_CFL !< If true, rescale the ratio !! of face areas to the cell areas when estimating the CFL number. logical, intent(in) :: marginal !< If true, report the @@ -1128,43 +1128,44 @@ subroutine set_zonal_BT_cont(u, h_in, h_W, h_E, BT_cont, uh_tot_0, duhdu_tot_0, end subroutine set_zonal_BT_cont !> Calculates the mass or volume fluxes through the meridional faces, and other related quantities. -subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_areaV, & +subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, por_face_areaV, & LB_in, vhbt, visc_rem_v, v_cor, BT_cont) - type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to - !! calculate fluxes [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vh !< Volume flux through meridional - !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G - type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type - !! specifies whether, where, and what open boundary conditions are used. - real, dimension(SZI_(G),SZJB_(G),SZK_(G)), & - intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] - type(loop_bounds_type), & - optional, intent(in) :: LB_in !< Loop bounds structure. - real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through - !< meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< South edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< North edge thickness in the + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(out) :: vh !< Volume flux through meridional + !! faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: vhbt !< The summed volume flux through meridional + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_v !< Both the fraction of the momentum + optional, intent(in) :: visc_rem_v !< Both the fraction of the momentum !! originally in a layer that remains after a time-step of viscosity, !! and the fraction of a time-step's worth of a barotropic acceleration !! that a layer experiences after viscosity is applied [nondim]. !! Visc_rem_v is between 0 (at the bottom) and 1 (far above the bottom). real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(out) :: v_cor + optional, intent(out) :: v_cor !< The meridional velocities (v with a barotropic correction) !! that give vhbt as the depth-integrated transport [L T-1 ~> m s-1]. - type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe + type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic flow. ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & - h_S, h_N ! Southern and northern face thicknesses [H ~> m or kg m-2]. real, dimension(SZI_(G)) :: & dv, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. dv_min_CFL, & ! Lower limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] @@ -1183,7 +1184,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar real :: I_dt ! 1.0 / dt [T-1 ~> s-1]. real :: dv_lim ! The velocity change that give a relative CFL of 1 [L T-1 ~> m s-1]. real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. - type(loop_bounds_type) :: LB + type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz integer :: l_seg logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC @@ -1210,11 +1211,6 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt - call cpu_clock_begin(id_clock_update) - ! This sets h_S and h_N. - call meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB) - call cpu_clock_end(id_clock_update) - call cpu_clock_begin(id_clock_correct) if (.not.use_visc_rem) visc_rem(:,:) = 1.0 !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_S,h_N,vh,use_visc_rem, & @@ -1238,8 +1234,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar if (local_specified_BC) then do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then l_seg = OBC%segnum_v(i,J) - if (OBC%segment(l_seg)%specified) & - vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) + if (OBC%segment(l_seg)%specified) vh(i,J,k) = OBC%segment(l_seg)%normal_trans(i,J,k) endif ; enddo endif enddo ! k-loop @@ -1333,8 +1328,7 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar ! Avoid reconciling barotropic/baroclinic transports if transport is specified is_simple = .false. - if (l_seg /= OBC_NONE) & - is_simple = OBC%segment(l_seg)%specified + if (l_seg /= OBC_NONE) is_simple = OBC%segment(l_seg)%specified do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) any_simple_OBC = any_simple_OBC .or. is_simple enddo ; else ; do i=ish,ieh @@ -1366,11 +1360,8 @@ subroutine meridional_mass_flux(v, h_in, vh, dt, G, GV, US, CS, OBC, por_face_ar visc_rem_max, J, ish, ieh, do_I, por_face_areaV) if (any_simple_OBC) then do i=ish,ieh - l_seg = OBC%segnum_v(i,J) - do_I(I) = .false. - if (l_seg /= OBC_NONE) & - do_I(i) = (OBC%segment(l_seg)%specified) + if (OBC%segnum_v(i,J) /= OBC_NONE) do_I(i) = (OBC%segment(OBC%segnum_v(i,J))%specified) if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo @@ -1459,7 +1450,7 @@ subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & logical, dimension(SZI_(G)), intent(in) :: do_I !< Which i values to work on. logical, intent(in) :: vol_CFL !< If true, rescale the !! ratio of face areas to the cell areas when estimating the CFL number. - real, dimension(SZI_(G), SZJB_(G)), & + real, dimension(SZI_(G),SZJB_(G)), & intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] type(ocean_OBC_type), optional, pointer :: OBC !< Open boundaries control structure. ! Local variables @@ -1537,7 +1528,7 @@ subroutine meridional_flux_thickness(v, h, h_S, h_N, h_v, dt, G, GV, US, LB, vol !! viscosity and the fractional open area !! [H ~> m or kg m-2]. real, intent(in) :: dt !< Time increment [T ~> s]. - type(loop_bounds_type), intent(in) :: LB !< Loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type logical, intent(in) :: vol_CFL !< If true, rescale the ratio !! of face areas to the cell areas when estimating the CFL number. @@ -1963,7 +1954,7 @@ subroutine PPM_reconstruction_x(h_in, h_W, h_E, G, LB, h_min, monotonic, simple_ !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_E !< East edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] logical, intent(in) :: monotonic !< If true, use the @@ -2099,7 +2090,7 @@ subroutine PPM_reconstruction_y(h_in, h_S, h_N, G, LB, h_min, monotonic, simple_ !! [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJ_(G)), intent(out) :: h_N !< North edge thickness in the reconstruction, !! [H ~> m or kg m-2]. - type(loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. + type(cont_loop_bounds_type), intent(in) :: LB !< Active loop bounds structure. real, intent(in) :: h_min !< The minimum thickness !! that can be obtained by a concave parabolic fit [H ~> m or kg m-2] logical, intent(in) :: monotonic !< If true, use the @@ -2392,8 +2383,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) "If true, stop corrective iterations using a velocity "//& "based criterion and only stop if the iteration is "//& "better than all predecessors.", default=.true.) - call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", & - CS%use_visc_rem_max, & + call get_param(param_file, mdl, "CONT_PPM_USE_VISC_REM_MAX", CS%use_visc_rem_max, & "If true, use more appropriate limiting bounds for "//& "corrections in strongly viscous columns.", default=.true.) call get_param(param_file, mdl, "CONT_PPM_MARGINAL_FACE_AREAS", CS%marginal_faces, & @@ -2417,6 +2407,39 @@ function continuity_PPM_stencil(CS) result(stencil) end function continuity_PPM_stencil +!> Set up a structure that stores the sizes of the i- and j-loops to to work on in the continuity solver. +function set_continuity_loop_bounds(G, CS, i_stencil, j_stencil) result(LB) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. + type(continuity_PPM_CS), intent(in) :: CS !< Module's control structure. + logical, optional, intent(in) :: i_stencil !< If present and true, extend the i-loop bounds + !! by the stencil width of the continuity scheme. + logical, optional, intent(in) :: j_stencil !< If present and true, extend the j-loop bounds + !! by the stencil width of the continuity scheme. + type(cont_loop_bounds_type) :: LB !< A type storing the array sizes to work on in the continuity routines. + + ! Local variables + logical :: add_i_stencil, add_j_stencil ! Local variables set based on i_stencil and j_stensil + integer :: stencil ! The continuity solver stencil size with the current continuity scheme. + + add_i_stencil = .false. ; if (present(i_stencil)) add_i_stencil = i_stencil + add_j_stencil = .false. ; if (present(j_stencil)) add_j_stencil = j_stencil + + stencil = continuity_PPM_stencil(CS) + + if (add_i_stencil) then + LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil + else + LB%ish = G%isc ; LB%ieh = G%iec + endif + + if (add_j_stencil) then + LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + else + LB%jsh = G%jsc ; LB%jeh = G%jec + endif + +end function set_continuity_loop_bounds + !> \namespace mom_continuity_ppm !! !! This module contains the subroutines that advect layer From bbda30f1214adce87c367a37891602579235516a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 16 Nov 2023 17:27:36 -0500 Subject: [PATCH 492/629] +Add zonal_BT_mass_flux & meridional_BT_mass_flux Added the new publicly visible routines zonal_BT_mass_flux and meridional_BT_mass_flux to return the vertically summed transports that the continuity solver would generate. Also revised the routine continuity_2d_fluxes in MOM_continuity to make use of these new routines. Because these new routines are not yet being used, all answers are bitwise identical, but there are new public interfaces. --- src/core/MOM_continuity.F90 | 22 +---- src/core/MOM_continuity_PPM.F90 | 149 ++++++++++++++++++++++++++++++++ 2 files changed, 152 insertions(+), 19 deletions(-) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 116bf8f195..59d6a58f74 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -9,6 +9,7 @@ module MOM_continuity use MOM_continuity_PPM, only : continuity_CS=>continuity_PPM_CS use MOM_continuity_PPM, only : zonal_edge_thickness, meridional_edge_thickness use MOM_continuity_PPM, only : zonal_mass_flux, meridional_mass_flux +use MOM_continuity_PPM, only : zonal_BT_mass_flux, meridional_BT_mass_flux use MOM_diag_mediator, only : time_type use MOM_grid, only : ocean_grid_type use MOM_open_boundary, only : ocean_OBC_type @@ -101,29 +102,12 @@ subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - real :: uh(SZIB_(G),SZJ_(G),SZK_(GV)) ! Thickness fluxes through zonal faces, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] - real :: vh(SZI_(G),SZJB_(G),SZK_(GV)) ! Thickness fluxes through v-point faces, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] - integer :: i, j, k - - uh(:,:,:) = 0.0 - vh(:,:,:) = 0.0 call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) - call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + call zonal_BT_mass_flux(u, h, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) - call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) - - uhbt(:,:) = 0.0 - vhbt(:,:) = 0.0 - - do k=1,GV%ke ; do j=G%jsc,G%jec ; do I=G%isc-1,G%iec - uhbt(I,j) = uhbt(I,j) + uh(I,j,k) - enddo ; enddo ; enddo - - do k=1,GV%ke ; do J=G%jsc-1,G%jec ; do i=G%isc,G%iec - vhbt(I,j) = vhbt(I,j) + vh(I,j,k) - enddo ; enddo ; enddo + call meridional_BT_mass_flux(v, h, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) end subroutine continuity_2d_fluxes diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 0abc0c5568..57b0668ca9 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -22,6 +22,7 @@ module MOM_continuity_PPM public zonal_mass_flux, meridional_mass_flux public zonal_flux_thickness, meridional_flux_thickness public zonal_edge_thickness, meridional_edge_thickness +public zonal_BT_mass_flux, meridional_BT_mass_flux public set_continuity_loop_bounds !>@{ CPU time clock IDs @@ -610,6 +611,80 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa end subroutine zonal_mass_flux + +!> Calculates the vertically integrated mass or volume fluxes through the zonal faces. +subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, por_face_areaU, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_W !< Western edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_E !< Eastern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), intent(out) :: uhbt !< The summed volume flux through zonal + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZIB_(G),SZJ_(G),SZK_(G)), intent(in) :: por_face_areaU !< fractional open area of U-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + real :: uh(SZIB_(G)) ! Volume flux through zonal faces = u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: duhdu(SZIB_(G)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. + logical, dimension(SZIB_(G)) :: do_I + real :: ones(SZIB_(G)) ! An array of 1's [nondim] + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + logical :: local_specified_BC, OBC_in_row + + local_specified_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + endif ; endif + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + call cpu_clock_begin(id_clock_correct) + ones(:) = 1.0 ; do_I(:) = .true. + + uhbt(:,:) = 0.0 + !$OMP parallel do default(shared) private(uh,duhdu,OBC_in_row) + do j=jsh,jeh + ! Determining whether there are any OBC points outside of the k-loop should be more efficient. + OBC_in_row = .false. + if (local_specified_BC) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_u(I,j))%specified) OBC_in_row = .true. + endif ; enddo ; endif + do k=1,nz + ! This sets uh and duhdu. + call zonal_flux_layer(u(:,j,k), h_in(:,j,k), h_W(:,j,k), h_E(:,j,k), uh, duhdu, ones, & + dt, G, US, j, ish, ieh, do_I, CS%vol_CFL, por_face_areaU(:,j,k), OBC) + if (OBC_in_row) then ; do I=ish-1,ieh ; if (OBC%segnum_u(I,j) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_u(I,j))%specified) uh(I) = OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) + endif ; enddo ; endif + + ! Accumulate the barotropic transport. + do I=ish-1,ieh + uhbt(I,j) = uhbt(I,j) + uh(I) + enddo + enddo ! k-loop + enddo ! j-loop + call cpu_clock_end(id_clock_correct) + +end subroutine zonal_BT_mass_flux + + !> Evaluates the zonal mass or volume fluxes in a layer. subroutine zonal_flux_layer(u, h, h_W, h_E, uh, duhdu, visc_rem, dt, G, US, j, & ish, ieh, do_I, vol_CFL, por_face_areaU, OBC) @@ -1422,6 +1497,80 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p end subroutine meridional_mass_flux + +!> Calculates the vertically integrated mass or volume fluxes through the meridional faces. +subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, por_face_areaV, LB_in) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_in !< Layer thickness used to + !! calculate fluxes [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_S !< Southern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h_N !< Northern edge thickness in the PPM + !! reconstruction [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G)), intent(out) :: vhbt !< The summed volume flux through meridional + !! faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< This module's control structure.G + type(ocean_OBC_type), pointer :: OBC !< Open boundary condition type + !! specifies whether, where, and what + !! open boundary conditions are used. + real, dimension(SZI_(G),SZJB_(G),SZK_(G)), intent(in) :: por_face_areaV !< fractional open area of V-faces [nondim] + type(cont_loop_bounds_type), optional, intent(in) :: LB_in !< Loop bounds structure. + + ! Local variables + real :: vh(SZI_(G)) ! Volume flux through meridional faces = v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real :: dvhdv(SZI_(G)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. + logical, dimension(SZI_(G)) :: do_I + real :: ones(SZI_(G)) ! An array of 1's [nondim] + type(cont_loop_bounds_type) :: LB + integer :: i, j, k, ish, ieh, jsh, jeh, nz + logical :: local_specified_BC, OBC_in_row + + local_specified_BC = .false. + if (associated(OBC)) then ; if (OBC%OBC_pe) then + local_specified_BC = OBC%specified_v_BCs_exist_globally + endif ; endif + + if (present(LB_in)) then + LB = LB_in + else + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + endif + ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke + + call cpu_clock_begin(id_clock_correct) + ones(:) = 1.0 ; do_I(:) = .true. + + vhbt(:,:) = 0.0 + !$OMP parallel do default(shared) private(vh,dvhdv,OBC_in_row) + do J=jsh-1,jeh + ! Determining whether there are any OBC points outside of the k-loop should be more efficient. + OBC_in_row = .false. + if (local_specified_BC) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) OBC_in_row = .true. + endif ; enddo ; endif + do k=1,nz + ! This sets vh and dvhdv. + call merid_flux_layer(v(:,J,k), h_in(:,:,k), h_S(:,:,k), h_N(:,:,k), vh, dvhdv, ones, & + dt, G, US, J, ish, ieh, do_I, CS%vol_CFL, por_face_areaV(:,:,k), OBC) + if (OBC_in_row) then ; do i=ish,ieh ; if (OBC%segnum_v(i,J) /= OBC_NONE) then + if (OBC%segment(OBC%segnum_v(i,J))%specified) vh(i) = OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) + endif ; enddo ; endif + + ! Accumulate the barotropic transport. + do i=ish,ieh + vhbt(i,J) = vhbt(i,J) + vh(i) + enddo + enddo ! k-loop + enddo ! j-loop + call cpu_clock_end(id_clock_correct) + +end subroutine meridional_BT_mass_flux + + !> Evaluates the meridional mass or volume fluxes in a layer. subroutine merid_flux_layer(v, h, h_S, h_N, vh, dvhdv, visc_rem, dt, G, US, J, & ish, ieh, do_I, vol_CFL, por_face_areaV, OBC) From a70482cfc45c6bf891dfaae7613bde73d7128d19 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 18 Nov 2023 07:15:39 -0500 Subject: [PATCH 493/629] +Add continuity_zonal_convergence Added the new publicly visible routines continuity_zonal_convergence and continuity_meridional_convergence to increment layer thicknesses using the continuity loop bounds type to specify extents. Also revised continuity_PPM to use these new routines. These changes will allow for the reuse of some of the reconstructions in calls that replace calls to continuity with the unwrapped contents. All answers are bitwise identical, but there are two new public interfaces. --- src/core/MOM_continuity_PPM.F90 | 181 ++++++++++++++++++++------------ 1 file changed, 113 insertions(+), 68 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index 57b0668ca9..f34131e03e 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -20,13 +20,14 @@ module MOM_continuity_PPM public continuity_PPM, continuity_PPM_init, continuity_PPM_stencil public zonal_mass_flux, meridional_mass_flux -public zonal_flux_thickness, meridional_flux_thickness public zonal_edge_thickness, meridional_edge_thickness +public continuity_zonal_convergence, continuity_merdional_convergence +public zonal_flux_thickness, meridional_flux_thickness public zonal_BT_mass_flux, meridional_BT_mass_flux public set_continuity_loop_bounds !>@{ CPU time clock IDs -integer :: id_clock_update, id_clock_correct +integer :: id_clock_reconstruct, id_clock_update, id_clock_correct !>@} !> Control structure for mom_continuity_ppm @@ -132,12 +133,8 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. - type(cont_loop_bounds_type) :: LB - integer :: is, ie, js, je, nz, stencil - integer :: i, j, k - + type(cont_loop_bounds_type) :: LB ! A type indicating the loop range for a phase of the updates logical :: x_first - is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke h_min = GV%Angstrom_H @@ -150,80 +147,116 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb "MOM_continuity_PPM: Either both visc_rem_u and visc_rem_v or neither"// & " one must be present in call to continuity_PPM.") - stencil = continuity_PPM_stencil(CS) - if (x_first) then ! First advect zonally, with loop bounds that accomodate the subsequent meridional advection. - LB = set_continuity_loop_bounds(G, CS, .false., .true.) - - call cpu_clock_begin(id_clock_update) + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.true.) call zonal_edge_thickness(hin, h_W, h_E, G, GV, US, CS, OBC, LB) - call cpu_clock_end(id_clock_update) call zonal_mass_flux(u, hin, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & LB, uhbt, visc_rem_u, u_cor, BT_cont) - - call cpu_clock_begin(id_clock_update) - !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) - ! Uncomment this line to prevent underflow. - ! if (h(i,j,k) < h_min) h(i,j,k) = h_min - enddo ; enddo ; enddo - - LB = set_continuity_loop_bounds(G, CS, .false., .false.) + call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin) ! Now advect meridionally, using the updated thicknesses to determine the fluxes. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC, LB) - call cpu_clock_end(id_clock_update) - call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & LB, vhbt, visc_rem_v, v_cor, BT_cont) - - call cpu_clock_begin(id_clock_update) - !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) - ! This line prevents underflow. - if (h(i,j,k) < h_min) h(i,j,k) = h_min - enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) + call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hmin=h_min) else ! .not. x_first ! First advect meridionally, with loop bounds that accomodate the subsequent zonal advection. - LB = set_continuity_loop_bounds(G, CS, .true., .false.) - - call cpu_clock_begin(id_clock_update) + LB = set_continuity_loop_bounds(G, CS, i_stencil=.true., j_stencil=.false.) call meridional_edge_thickness(hin, h_S, h_N, G, GV, US, CS, OBC, LB) - call cpu_clock_end(id_clock_update) call meridional_mass_flux(v, hin, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & LB, vhbt, visc_rem_v, v_cor, BT_cont) - - call cpu_clock_begin(id_clock_update) - !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)) - enddo ; enddo ; enddo - - LB = set_continuity_loop_bounds(G, CS, .false., .false.) + call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin) ! Now advect zonally, using the updated thicknesses to determine the fluxes. + LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC, LB) - call cpu_clock_end(id_clock_update) call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & LB, uhbt, visc_rem_u, u_cor, BT_cont) + call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hmin=h_min) + endif - call cpu_clock_begin(id_clock_update) +end subroutine continuity_PPM + + +!> Updates the thicknesses due to zonal thickness fluxes. +subroutine continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin, hmin) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: uh !< Zonal thickness flux, u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + !! If hin is absent, h is also the initial thickness. + real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2] + + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + integer :: i, j, k + + call cpu_clock_begin(id_clock_update) + + h_min = 0.0 ; if (present(hmin)) h_min = hmin + + if (present(hin)) then + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min ) + enddo ; enddo ; enddo + else !$OMP parallel do default(shared) - do k=1,nz ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh - h(i,j,k) = h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)) - ! This line prevents underflow. - if (h(i,j,k) < h_min) h(i,j,k) = h_min + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (uh(I,j,k) - uh(I-1,j,k)), h_min ) enddo ; enddo ; enddo - call cpu_clock_end(id_clock_update) + endif + + call cpu_clock_end(id_clock_update) + +end subroutine continuity_zonal_convergence + +!> Updates the thicknesses due to meridional thickness fluxes. +subroutine continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin, hmin) + type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Final layer thickness [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: vh !< Meridional thickness flux, v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1] + real, intent(in) :: dt !< Time increment [T ~> s] + type(cont_loop_bounds_type), intent(in) :: LB !< Loop bounds structure + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hin !< Initial layer thickness [H ~> m or kg m-2]. + !! If hin is absent, h is also the initial thickness. + real, optional, intent(in) :: hmin !< The minimum layer thickness [H ~> m or kg m-2] + real :: h_min ! The minimum layer thickness [H ~> m or kg m-2]. h_min could be 0. + integer :: i, j, k + + call cpu_clock_begin(id_clock_update) + + h_min = 0.0 ; if (present(hmin)) h_min = hmin + + if (present(hin)) then + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( hin(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min ) + enddo ; enddo ; enddo + else + !$OMP parallel do default(shared) + do k=1,GV%ke ; do j=LB%jsh,LB%jeh ; do i=LB%ish,LB%ieh + h(i,j,k) = max( h(i,j,k) - dt * G%IareaT(i,j) * (vh(i,J,k) - vh(i,J-1,k)), h_min ) + enddo ; enddo ; enddo endif -end subroutine continuity_PPM + call cpu_clock_end(id_clock_update) + +end subroutine continuity_merdional_convergence + !> Set the reconstructed thicknesses at the eastern and western edges of tracer cells. subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) @@ -245,6 +278,8 @@ subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, nz + call cpu_clock_begin(id_clock_reconstruct) + if (present(LB_in)) then LB = LB_in else @@ -265,6 +300,8 @@ subroutine zonal_edge_thickness(h_in, h_W, h_E, G, GV, US, CS, OBC, LB_in) enddo endif + call cpu_clock_end(id_clock_reconstruct) + end subroutine zonal_edge_thickness @@ -288,6 +325,8 @@ subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, nz + call cpu_clock_begin(id_clock_reconstruct) + if (present(LB_in)) then LB = LB_in else @@ -308,6 +347,8 @@ subroutine meridional_edge_thickness(h_in, h_S, h_N, G, GV, US, CS, OBC, LB_in) enddo endif + call cpu_clock_end(id_clock_reconstruct) + end subroutine meridional_edge_thickness @@ -377,6 +418,8 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, local_open_BC, is_simple + call cpu_clock_begin(id_clock_correct) + use_visc_rem = present(visc_rem_u) local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. local_open_BC = .false. @@ -398,7 +441,6 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt - call cpu_clock_begin(id_clock_correct) if (.not.use_visc_rem) visc_rem(:,:) = 1.0 !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_W,h_E,use_visc_rem,visc_rem_u, & !$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & @@ -597,7 +639,6 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa endif enddo endif - call cpu_clock_end(id_clock_correct) if (set_BT_cont) then ; if (allocated(BT_cont%h_u)) then if (present(u_cor)) then @@ -609,6 +650,8 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa endif endif ; endif + call cpu_clock_end(id_clock_correct) + end subroutine zonal_mass_flux @@ -639,23 +682,22 @@ subroutine zonal_BT_mass_flux(u, h_in, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, p real :: duhdu(SZIB_(G)) ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. logical, dimension(SZIB_(G)) :: do_I real :: ones(SZIB_(G)) ! An array of 1's [nondim] - type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, nz logical :: local_specified_BC, OBC_in_row + call cpu_clock_begin(id_clock_correct) + local_specified_BC = .false. if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_v_BCs_exist_globally endif ; endif if (present(LB_in)) then - LB = LB_in + ish = LB_in%ish ; ieh = LB_in%ieh ; jsh = LB_in%jsh ; jeh = LB_in%jeh ; nz = GV%ke else - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke endif - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke - call cpu_clock_begin(id_clock_correct) ones(:) = 1.0 ; do_I(:) = .true. uhbt(:,:) = 0.0 @@ -1265,6 +1307,8 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC logical :: local_Flather_OBC, is_simple, local_open_BC + call cpu_clock_begin(id_clock_correct) + use_visc_rem = present(visc_rem_v) local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. local_open_BC = .false. @@ -1286,7 +1330,6 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p I_dt = 1.0 / dt if (CS%aggress_adjust) CFL_dt = I_dt - call cpu_clock_begin(id_clock_correct) if (.not.use_visc_rem) visc_rem(:,:) = 1.0 !$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_S,h_N,vh,use_visc_rem, & !$OMP visc_rem_v,dt,US,G,GV,CS,local_specified_BC,OBC,vhbt, & @@ -1483,7 +1526,6 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p endif enddo endif - call cpu_clock_end(id_clock_correct) if (set_BT_cont) then ; if (allocated(BT_cont%h_v)) then if (present(v_cor)) then @@ -1495,6 +1537,8 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p endif endif ; endif + call cpu_clock_end(id_clock_correct) + end subroutine meridional_mass_flux @@ -1525,23 +1569,22 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O real :: dvhdv(SZI_(G)) ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. logical, dimension(SZI_(G)) :: do_I real :: ones(SZI_(G)) ! An array of 1's [nondim] - type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, nz logical :: local_specified_BC, OBC_in_row + call cpu_clock_begin(id_clock_correct) + local_specified_BC = .false. if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_v_BCs_exist_globally endif ; endif if (present(LB_in)) then - LB = LB_in + ish = LB_in%ish ; ieh = LB_in%ieh ; jsh = LB_in%jsh ; jeh = LB_in%jeh ; nz = GV%ke else - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + ish = G%isc ; ieh = G%iec ; jsh = G%jsc ; jeh = G%jec ; nz = GV%ke endif - ish = LB%ish ; ieh = LB%ieh ; jsh = LB%jsh ; jeh = LB%jeh ; nz = GV%ke - call cpu_clock_begin(id_clock_correct) ones(:) = 1.0 ; do_I(:) = .true. vhbt(:,:) = 0.0 @@ -1566,6 +1609,7 @@ subroutine meridional_BT_mass_flux(v, h_in, h_S, h_N, vhbt, dt, G, GV, US, CS, O enddo enddo ! k-loop enddo ! j-loop + call cpu_clock_end(id_clock_correct) end subroutine meridional_BT_mass_flux @@ -2542,6 +2586,7 @@ subroutine continuity_PPM_init(Time, G, GV, US, param_file, diag, CS) CS%diag => diag + id_clock_reconstruct = cpu_clock_id('(Ocean continuity reconstruction)', grain=CLOCK_ROUTINE) id_clock_update = cpu_clock_id('(Ocean continuity update)', grain=CLOCK_ROUTINE) id_clock_correct = cpu_clock_id('(Ocean continuity correction)', grain=CLOCK_ROUTINE) From 6b6f8dcde50c16feebd2f895a50b32e562d2db25 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 19 Nov 2023 09:15:42 -0500 Subject: [PATCH 494/629] Move continuity_fluxes to MOM_continuity_PPM.F90 Move continuity_fluxes and continuity_adjust_vel from MOM_continuity.F90 to MOM_continuity_PPM.F90, but with these interfaces also offered via the MOM_continuity module so that no changes are required outside of these two files. In addtion, 11 of the recently added public interfaces from MOM_continuity_PPM are also made available as pass-through interfaces from MOM_continuity. All answers are bitwise identical. --- src/core/MOM_continuity.F90 | 179 ++------------------------------ src/core/MOM_continuity_PPM.F90 | 157 ++++++++++++++++++++++++++++ 2 files changed, 168 insertions(+), 168 deletions(-) diff --git a/src/core/MOM_continuity.F90 b/src/core/MOM_continuity.F90 index 59d6a58f74..14582d1eb5 100644 --- a/src/core/MOM_continuity.F90 +++ b/src/core/MOM_continuity.F90 @@ -7,181 +7,24 @@ module MOM_continuity use MOM_continuity_PPM, only : continuity_stencil=>continuity_PPM_stencil use MOM_continuity_PPM, only : continuity_init=>continuity_PPM_init use MOM_continuity_PPM, only : continuity_CS=>continuity_PPM_CS -use MOM_continuity_PPM, only : zonal_edge_thickness, meridional_edge_thickness +use MOM_continuity_PPM, only : continuity_fluxes, continuity_adjust_vel use MOM_continuity_PPM, only : zonal_mass_flux, meridional_mass_flux +use MOM_continuity_PPM, only : zonal_edge_thickness, meridional_edge_thickness +use MOM_continuity_PPM, only : continuity_zonal_convergence, continuity_merdional_convergence +use MOM_continuity_PPM, only : zonal_flux_thickness, meridional_flux_thickness use MOM_continuity_PPM, only : zonal_BT_mass_flux, meridional_BT_mass_flux -use MOM_diag_mediator, only : time_type -use MOM_grid, only : ocean_grid_type -use MOM_open_boundary, only : ocean_OBC_type -use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : BT_cont_type, porous_barrier_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_continuity_PPM, only : set_continuity_loop_bounds, cont_loop_bounds_type implicit none ; private -#include - ! These are direct pass-throughs of routines in continuity_PPM public continuity, continuity_init, continuity_stencil, continuity_CS public continuity_fluxes, continuity_adjust_vel - -!> Finds the thickness fluxes from the continuity solver or their vertical sum without -!! actually updating the layer thicknesses. -interface continuity_fluxes - module procedure continuity_3d_fluxes, continuity_2d_fluxes -end interface continuity_fluxes - -contains - -!> Finds the thickness fluxes from the continuity solver without actually updating the -!! layer thicknesses. Because the fluxes in the two directions are calculated based on the -!! input thicknesses, which are not updated between the direcitons, the fluxes returned here -!! are not the same as those that would be returned by a call to continuity. -subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(out) :: uh !< Thickness fluxes through zonal faces, - !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(out) :: vh !< Thickness fluxes through meridional faces, - !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics - - ! Local variables - real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] - real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] - real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - - call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) - call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) - - call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) - call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) - -end subroutine continuity_3d_fluxes - -!> Find the vertical sum of the thickness fluxes from the continuity solver without actually -!! updating the layer thicknesses. Because the fluxes in the two directions are calculated -!! based on the input thicknesses, which are not updated between the directions, the fluxes -!! returned here are not the same as those that would be returned by a call to continuity. -subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G)), & - intent(out) :: uhbt !< Vertically summed thickness flux through - !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G)), & - intent(out) :: vhbt !< Vertically summed thickness flux through - !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics - - ! Local variables - real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] - real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] - real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - - call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) - call zonal_BT_mass_flux(u, h, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) - - call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) - call meridional_BT_mass_flux(v, h, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) - -end subroutine continuity_2d_fluxes - - -!> Correct the velocities to give the specified depth-integrated transports by applying a -!! barotropic acceleration (subject to viscous drag) to the velocities. -subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, visc_rem_u, visc_rem_v) - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. - type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - intent(inout) :: u !< Zonal velocity, which will be adjusted to - !! give uhbt as the depth-integrated - !! transport [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - intent(inout) :: v !< Meridional velocity, which will be adjusted - !! to give vhbt as the depth-integrated - !! transport [L T-1 ~> m s-1]. - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. - real, intent(in) :: dt !< Time increment [T ~> s]. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(continuity_CS), intent(in) :: CS !< Control structure for mom_continuity. - type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. - type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics - real, dimension(SZIB_(G),SZJ_(G)), & - intent(in) :: uhbt !< The vertically summed thickness flux through - !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G)), & - intent(in) :: vhbt !< The vertically summed thickness flux through - !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_u !< Both the fraction of the zonal momentum - !! that remains after a time-step of viscosity, and - !! the fraction of a time-step's worth of a barotropic - !! acceleration that a layer experiences after viscosity - !! is applied [nondim]. This goes between 0 (at the - !! bottom) and 1 (far above the bottom). When this - !! column is under an ice shelf, this also goes to 0 - !! at the top due to the no-slip boundary condition there. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - optional, intent(in) :: visc_rem_v !< Both the fraction of the meridional momentum - !! that remains after a time-step of viscosity, and - !! the fraction of a time-step's worth of a barotropic - !! acceleration that a layer experiences after viscosity - !! is applied [nondim]. This goes between 0 (at the - !! bottom) and 1 (far above the bottom). When this - !! column is under an ice shelf, this also goes to 0 - !! at the top due to the no-slip boundary condition there. - - ! Local variables - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_in !< Input zonal velocity [L T-1 ~> m s-1] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_in !< Input meridional velocity [L T-1 ~> m s-1] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh !< Volume flux through zonal faces = - !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh !< Volume flux through meridional faces = - !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. - real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] - real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] - real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] - - ! It might not be necessary to separate the input velocity array from the adjusted velocities, - ! but it seems safer to do so, even if it might be less efficient. - u_in(:,:,:) = u(:,:,:) - v_in(:,:,:) = v(:,:,:) - - call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) - call zonal_mass_flux(u_in, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & - uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) - - call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) - call meridional_mass_flux(v_in, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & - vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) - -end subroutine continuity_adjust_vel +public zonal_mass_flux, meridional_mass_flux +public zonal_edge_thickness, meridional_edge_thickness +public continuity_zonal_convergence, continuity_merdional_convergence +public zonal_flux_thickness, meridional_flux_thickness +public zonal_BT_mass_flux, meridional_BT_mass_flux +public set_continuity_loop_bounds, cont_loop_bounds_type end module MOM_continuity diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index f34131e03e..be2dabd9e6 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -19,6 +19,7 @@ module MOM_continuity_PPM #include public continuity_PPM, continuity_PPM_init, continuity_PPM_stencil +public continuity_fluxes, continuity_adjust_vel public zonal_mass_flux, meridional_mass_flux public zonal_edge_thickness, meridional_edge_thickness public continuity_zonal_convergence, continuity_merdional_convergence @@ -72,6 +73,12 @@ module MOM_continuity_PPM !>@} end type cont_loop_bounds_type +!> Finds the thickness fluxes from the continuity solver or their vertical sum without +!! actually updating the layer thicknesses. +interface continuity_fluxes + module procedure continuity_3d_fluxes, continuity_2d_fluxes +end interface continuity_fluxes + contains !> Time steps the layer thicknesses, using a monotonically limit, directionally split PPM scheme, @@ -180,6 +187,156 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb end subroutine continuity_PPM +!> Finds the thickness fluxes from the continuity solver without actually updating the +!! layer thicknesses. Because the fluxes in the two directions are calculated based on the +!! input thicknesses, which are not updated between the direcitons, the fluxes returned here +!! are not the same as those that would be returned by a call to continuity. +subroutine continuity_3d_fluxes(u, v, h, uh, vh, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(out) :: uh !< Thickness fluxes through zonal faces, + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(out) :: vh !< Thickness fluxes through meridional faces, + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + +end subroutine continuity_3d_fluxes + +!> Find the vertical sum of the thickness fluxes from the continuity solver without actually +!! updating the layer thicknesses. Because the fluxes in the two directions are calculated +!! based on the input thicknesses, which are not updated between the directions, the fluxes +!! returned here are not the same as those that would be returned by a call to continuity. +subroutine continuity_2d_fluxes(u, v, h, uhbt, vhbt, dt, G, GV, US, CS, OBC, pbv) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: u !< Zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, dimension(SZIB_(G),SZJ_(G)), & + intent(out) :: uhbt !< Vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(out) :: vhbt !< Vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + + ! Local variables + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_BT_mass_flux(u, h, h_W, h_E, uhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaU) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_BT_mass_flux(v, h, h_S, h_N, vhbt, dt, G, GV, US, CS, OBC, pbv%por_face_areaV) + +end subroutine continuity_2d_fluxes + +!> Correct the velocities to give the specified depth-integrated transports by applying a +!! barotropic acceleration (subject to viscous drag) to the velocities. +subroutine continuity_adjust_vel(u, v, h, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, visc_rem_u, visc_rem_v) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure. + type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< Zonal velocity, which will be adjusted to + !! give uhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< Meridional velocity, which will be adjusted + !! to give vhbt as the depth-integrated + !! transport [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< Layer thickness [H ~> m or kg m-2]. + real, intent(in) :: dt !< Time increment [T ~> s]. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(continuity_PPM_CS), intent(in) :: CS !< Control structure for mom_continuity. + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure. + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + real, dimension(SZIB_(G),SZJ_(G)), & + intent(in) :: uhbt !< The vertically summed thickness flux through + !! zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + intent(in) :: vhbt !< The vertically summed thickness flux through + !! meridional faces [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_u !< Both the fraction of the zonal momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: visc_rem_v !< Both the fraction of the meridional momentum + !! that remains after a time-step of viscosity, and + !! the fraction of a time-step's worth of a barotropic + !! acceleration that a layer experiences after viscosity + !! is applied [nondim]. This goes between 0 (at the + !! bottom) and 1 (far above the bottom). When this + !! column is under an ice shelf, this also goes to 0 + !! at the top due to the no-slip boundary condition there. + + ! Local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_in !< Input zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_in !< Input meridional velocity [L T-1 ~> m s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uh !< Volume flux through zonal faces = + !! u*h*dy [H L2 T-1 ~> m3 s-1 or kg s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vh !< Volume flux through meridional faces = + !! v*h*dx [H L2 T-1 ~> m3 s-1 or kg s-1]. + real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_E(SZI_(G),SZJ_(G),SZK_(GV)) ! East edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] + real :: h_S(SZI_(G),SZJ_(G),SZK_(GV)) ! South edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + real :: h_N(SZI_(G),SZJ_(G),SZK_(GV)) ! North edge thicknesses in the meridional PPM reconstruction [H ~> m or kg m-2] + + ! It might not be necessary to separate the input velocity array from the adjusted velocities, + ! but it seems safer to do so, even if it might be less efficient. + u_in(:,:,:) = u(:,:,:) + v_in(:,:,:) = v(:,:,:) + + call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC) + call zonal_mass_flux(u_in, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & + uhbt=uhbt, visc_rem_u=visc_rem_u, u_cor=u) + + call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC) + call meridional_mass_flux(v_in, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & + vhbt=vhbt, visc_rem_v=visc_rem_v, v_cor=v) + +end subroutine continuity_adjust_vel + !> Updates the thicknesses due to zonal thickness fluxes. subroutine continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin, hmin) From 78772923df3c8014512cb143e4b3baaec4c3bfdf Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 12 Dec 2023 18:35:30 -0500 Subject: [PATCH 495/629] +Add optional argument du_cor to continuity_PPM Added the new optional arguments du_cor and dv_cor to continuity_PPM and zonal_mass_flux or meridional_mass_flux to return the barotropic velocity increments that make the summed barotropic transports match uhbt or vhbt. Also cleaned up and simplified the logic of some of the flags used to apply specified open boundary conditions, adding a new 1-d logical array thereby avoiding working unnecessarily on some loops or repeatedly checking for specified open boundary condition points. Two openMP directives were also simplified. All answers are bitwise identical, but there are new optional arguments to three publicly visible routines. --- src/core/MOM_continuity_PPM.F90 | 172 +++++++++++++++++--------------- 1 file changed, 91 insertions(+), 81 deletions(-) diff --git a/src/core/MOM_continuity_PPM.F90 b/src/core/MOM_continuity_PPM.F90 index be2dabd9e6..ba8c234bc2 100644 --- a/src/core/MOM_continuity_PPM.F90 +++ b/src/core/MOM_continuity_PPM.F90 @@ -84,7 +84,7 @@ module MOM_continuity_PPM !> Time steps the layer thicknesses, using a monotonically limit, directionally split PPM scheme, !! based on Lin (1994). subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhbt, vhbt, & - visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont) + visc_rem_u, visc_rem_v, u_cor, v_cor, BT_cont, du_cor, dv_cor) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & @@ -133,6 +133,12 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb !! transport [L T-1 ~> m s-1]. type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: dv_cor !< The meridional velocity increments from v that give vhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. ! Local variables real :: h_W(SZI_(G),SZJ_(G),SZK_(GV)) ! West edge thicknesses in the zonal PPM reconstruction [H ~> m or kg m-2] @@ -159,14 +165,14 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.true.) call zonal_edge_thickness(hin, h_W, h_E, G, GV, US, CS, OBC, LB) call zonal_mass_flux(u, hin, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & - LB, uhbt, visc_rem_u, u_cor, BT_cont) + LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hin) ! Now advect meridionally, using the updated thicknesses to determine the fluxes. LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) call meridional_edge_thickness(h, h_S, h_N, G, GV, US, CS, OBC, LB) call meridional_mass_flux(v, h, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & - LB, vhbt, visc_rem_v, v_cor, BT_cont) + LB, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hmin=h_min) else ! .not. x_first @@ -174,14 +180,14 @@ subroutine continuity_PPM(u, v, hin, h, uh, vh, dt, G, GV, US, CS, OBC, pbv, uhb LB = set_continuity_loop_bounds(G, CS, i_stencil=.true., j_stencil=.false.) call meridional_edge_thickness(hin, h_S, h_N, G, GV, US, CS, OBC, LB) call meridional_mass_flux(v, hin, h_S, h_N, vh, dt, G, GV, US, CS, OBC, pbv%por_face_areaV, & - LB, vhbt, visc_rem_v, v_cor, BT_cont) + LB, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) call continuity_merdional_convergence(h, vh, dt, G, GV, LB, hin) ! Now advect zonally, using the updated thicknesses to determine the fluxes. LB = set_continuity_loop_bounds(G, CS, i_stencil=.false., j_stencil=.false.) call zonal_edge_thickness(h, h_W, h_E, G, GV, US, CS, OBC, LB) call zonal_mass_flux(u, h, h_W, h_E, uh, dt, G, GV, US, CS, OBC, pbv%por_face_areaU, & - LB, uhbt, visc_rem_u, u_cor, BT_cont) + LB, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) call continuity_zonal_convergence(h, uh, dt, G, GV, LB, hmin=h_min) endif @@ -511,7 +517,7 @@ end subroutine meridional_edge_thickness !> Calculates the mass or volume fluxes through the zonal faces, and other related quantities. subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_face_areaU, & - LB_in, uhbt, visc_rem_u, u_cor, BT_cont) + LB_in, uhbt, visc_rem_u, u_cor, BT_cont, du_cor) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & @@ -548,15 +554,18 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa !! that give uhbt as the depth-integrated transport [L T-1 ~> m s-1] type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe the !! effective open face areas as a function of barotropic flow. + real, dimension(SZIB_(G),SZJ_(G)), & + optional, intent(out) :: du_cor !< The zonal velocity increments from u that give uhbt + !! as the depth-integrated transports [L T-1 ~> m s-1]. ! Local variables real, dimension(SZIB_(G),SZK_(GV)) :: duhdu ! Partial derivative of uh with u [H L ~> m2 or kg m-1]. real, dimension(SZIB_(G)) :: & - du, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. + du, & ! Corrective barotropic change in the velocity to give uhbt [L T-1 ~> m s-1]. du_min_CFL, & ! Lower limit on du correction to avoid CFL violations [L T-1 ~> m s-1] du_max_CFL, & ! Upper limit on du correction to avoid CFL violations [L T-1 ~> m s-1] duhdu_tot_0, & ! Summed partial derivative of uh with u [H L ~> m2 or kg m-1]. - uh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. + uh_tot_0, & ! Summed transport with no barotropic correction [H L2 T-1 ~> m3 s-1 or kg s-1]. visc_rem_max ! The column maximum of visc_rem [nondim]. logical, dimension(SZIB_(G)) :: do_I real, dimension(SZIB_(G),SZK_(GV)) :: & @@ -571,22 +580,26 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa real :: dx_E, dx_W ! Effective x-grid spacings to the east and west [L ~> m]. type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz - integer :: l_seg - logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC - logical :: local_Flather_OBC, local_open_BC, is_simple + integer :: l_seg ! The OBC segment number + logical :: use_visc_rem, set_BT_cont + logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals + logical :: simple_OBC_pt(SZIB_(G)) ! Indicates points in a row with specified transport OBCs call cpu_clock_begin(id_clock_correct) use_visc_rem = present(visc_rem_u) - local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. - local_open_BC = .false. - if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false. if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_u_BCs_exist_globally local_Flather_OBC = OBC%Flather_u_BCs_exist_globally local_open_BC = OBC%open_u_BCs_exist_globally endif ; endif + if (present(du_cor)) du_cor(:,:) = 0.0 + if (present(LB_in)) then LB = LB_in else @@ -599,14 +612,10 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa if (CS%aggress_adjust) CFL_dt = I_dt if (.not.use_visc_rem) visc_rem(:,:) = 1.0 -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,u,h_in,h_W,h_E,use_visc_rem,visc_rem_u, & -!$OMP uh,dt,US,G,GV,CS,local_specified_BC,OBC,uhbt,set_BT_cont, & -!$OMP CFL_dt,I_dt,u_cor,BT_cont, local_Flather_OBC, & -!$OMP por_face_areaU) & -!$OMP private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0,duhdu_tot_0, & -!$OMP is_simple,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & -!$OMP any_simple_OBC,l_seg) & -!$OMP firstprivate(visc_rem) + !$OMP parallel do default(shared) private(do_I,duhdu,du,du_max_CFL,du_min_CFL,uh_tot_0, & + !$OMP duhdu_tot_0,FAuI,visc_rem_max,I_vrm,du_lim,dx_E,dx_W, & + !$OMP simple_OBC_pt,any_simple_OBC,l_seg) & + !$OMP firstprivate(visc_rem) do j=jsh,jeh do I=ish-1,ieh ; do_I(I) = .true. ; enddo ! Set uh and duhdu. @@ -716,30 +725,32 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa l_seg = OBC%segnum_u(I,j) ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = .false. - if (l_seg /= OBC_NONE) is_simple = OBC%segment(l_seg)%specified - do_I(I) = .not. (l_seg /= OBC_NONE .and. is_simple) - any_simple_OBC = any_simple_OBC .or. is_simple + simple_OBC_pt(I) = .false. + if (l_seg /= OBC_NONE) simple_OBC_pt(I) = OBC%segment(l_seg)%specified + do_I(I) = .not.simple_OBC_pt(I) + any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(I) enddo ; else ; do I=ish-1,ieh do_I(I) = .true. enddo ; endif endif if (present(uhbt)) then + ! Find du and uh. call zonal_flux_adjust(u, h_in, h_W, h_E, uhbt(:,j), uh_tot_0, duhdu_tot_0, du, & du_max_CFL, du_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaU, uh, OBC=OBC) if (present(u_cor)) then ; do k=1,nz do I=ish-1,ieh ; u_cor(I,j,k) = u(I,j,k) + du(I) * visc_rem(I,k) ; enddo - if (local_specified_BC) then ; do I=ish-1,ieh - if (OBC%segnum_u(I,j) /= OBC_NONE) then - l_seg = OBC%segnum_u(I,j) - if (OBC%segment(l_seg)%specified) u_cor(I,j,k) = OBC%segment(l_seg)%normal_vel(I,j,k) - endif - enddo ; endif + if (any_simple_OBC) then ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then + u_cor(I,j,k) = OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) + endif ; enddo ; endif enddo ; endif ! u-corrected + if (present(du_cor)) then + do I=ish-1,ieh ; du_cor(I,j) = du(I) ; enddo + endif + endif if (set_BT_cont) then @@ -748,19 +759,16 @@ subroutine zonal_mass_flux(u, h_in, h_W, h_E, uh, dt, G, GV, US, CS, OBC, por_fa visc_rem_max, j, ish, ieh, do_I, por_face_areaU) if (any_simple_OBC) then do I=ish-1,ieh - do_I(I) = .false. - if (OBC%segnum_u(I,j) /= OBC_NONE) do_I(I) = OBC%segment(OBC%segnum_u(I,j))%specified - - if (do_I(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) + if (simple_OBC_pt(I)) FAuI(I) = GV%H_subroundoff*G%dy_Cu(I,j) enddo - ! NOTE: do_I(I) should prevent access to segment OBC_NONE - do k=1,nz ; do I=ish-1,ieh ; if (do_I(I)) then + ! NOTE: simple_OBC_pt(I) should prevent access to segment OBC_NONE + do k=1,nz ; do I=ish-1,ieh ; if (simple_OBC_pt(I)) then if ((abs(OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_u(I,j))%specified)) & FAuI(I) = FAuI(I) + OBC%segment(OBC%segnum_u(I,j))%normal_trans(I,j,k) / & OBC%segment(OBC%segnum_u(I,j))%normal_vel(I,j,k) endif ; enddo ; enddo - do I=ish-1,ieh ; if (do_I(I)) then + do I=ish-1,ieh ; if (simple_OBC_pt(I)) then BT_cont%FA_u_W0(I,j) = FAuI(I) ; BT_cont%FA_u_E0(I,j) = FAuI(I) BT_cont%FA_u_WW(I,j) = FAuI(I) ; BT_cont%FA_u_EE(I,j) = FAuI(I) BT_cont%uBT_WW(I,j) = 0.0 ; BT_cont%uBT_EE(I,j) = 0.0 @@ -1101,7 +1109,7 @@ subroutine zonal_flux_adjust(u, h_in, h_W, h_E, uhbt, uh_tot_0, duhdu_tot_0, & !! the fraction of a time-step's worth of a barotropic acceleration that a layer !! experiences after viscosity is applied [nondim]. !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZIB_(G)), optional, intent(in) :: uhbt !< The summed volume flux + real, dimension(SZIB_(G)), intent(in) :: uhbt !< The summed volume flux !! through zonal faces [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZIB_(G)), intent(in) :: du_max_CFL !< Maximum acceptable @@ -1403,7 +1411,7 @@ end subroutine set_zonal_BT_cont !> Calculates the mass or volume fluxes through the meridional faces, and other related quantities. subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, por_face_areaV, & - LB_in, vhbt, visc_rem_v, v_cor, BT_cont) + LB_in, vhbt, visc_rem_v, v_cor, BT_cont, dv_cor) type(ocean_grid_type), intent(in) :: G !< Ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< Ocean's vertical grid structure. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(in) :: v !< Meridional velocity [L T-1 ~> m s-1] @@ -1437,11 +1445,16 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p !! that give vhbt as the depth-integrated transport [L T-1 ~> m s-1]. type(BT_cont_type), optional, pointer :: BT_cont !< A structure with elements that describe !! the effective open face areas as a function of barotropic flow. + real, dimension(SZI_(G),SZJB_(G)), & + optional, intent(out) :: dv_cor !< The meridional velocity increments from v + !! that give vhbt as the depth-integrated + !! transports [L T-1 ~> m s-1]. + ! Local variables real, dimension(SZI_(G),SZK_(GV)) :: & - dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. + dvhdv ! Partial derivative of vh with v [H L ~> m2 or kg m-1]. real, dimension(SZI_(G)) :: & - dv, & ! Corrective barotropic change in the velocity [L T-1 ~> m s-1]. + dv, & ! Corrective barotropic change in the velocity to give vhbt [L T-1 ~> m s-1]. dv_min_CFL, & ! Lower limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] dv_max_CFL, & ! Upper limit on dv correction to avoid CFL violations [L T-1 ~> m s-1] dvhdv_tot_0, & ! Summed partial derivative of vh with v [H L ~> m2 or kg m-1]. @@ -1460,22 +1473,26 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p real :: dy_N, dy_S ! Effective y-grid spacings to the north and south [L ~> m]. type(cont_loop_bounds_type) :: LB integer :: i, j, k, ish, ieh, jsh, jeh, n, nz - integer :: l_seg - logical :: local_specified_BC, use_visc_rem, set_BT_cont, any_simple_OBC - logical :: local_Flather_OBC, is_simple, local_open_BC + integer :: l_seg ! The OBC segment number + logical :: use_visc_rem, set_BT_cont + logical :: local_specified_BC, local_Flather_OBC, local_open_BC, any_simple_OBC ! OBC-related logicals + logical :: simple_OBC_pt(SZI_(G)) ! Indicates points in a row with specified transport OBCs call cpu_clock_begin(id_clock_correct) use_visc_rem = present(visc_rem_v) - local_specified_BC = .false. ; set_BT_cont = .false. ; local_Flather_OBC = .false. - local_open_BC = .false. - if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + set_BT_cont = .false. ; if (present(BT_cont)) set_BT_cont = (associated(BT_cont)) + + local_specified_BC = .false. ; local_Flather_OBC = .false. ; local_open_BC = .false. if (associated(OBC)) then ; if (OBC%OBC_pe) then local_specified_BC = OBC%specified_v_BCs_exist_globally local_Flather_OBC = OBC%Flather_v_BCs_exist_globally local_open_BC = OBC%open_v_BCs_exist_globally endif ; endif + if (present(dv_cor)) dv_cor(:,:) = 0.0 + if (present(LB_in)) then LB = LB_in else @@ -1488,14 +1505,10 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p if (CS%aggress_adjust) CFL_dt = I_dt if (.not.use_visc_rem) visc_rem(:,:) = 1.0 -!$OMP parallel do default(none) shared(ish,ieh,jsh,jeh,nz,v,h_in,h_S,h_N,vh,use_visc_rem, & -!$OMP visc_rem_v,dt,US,G,GV,CS,local_specified_BC,OBC,vhbt, & -!$OMP set_BT_cont,CFL_dt,I_dt,v_cor,BT_cont, local_Flather_OBC, & -!$OMP por_face_areaV) & -!$OMP private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & -!$OMP dvhdv_tot_0,visc_rem_max,I_vrm,dv_lim,dy_N, & -!$OMP is_simple,FAvi,dy_S,any_simple_OBC,l_seg) & -!$OMP firstprivate(visc_rem) + !$OMP parallel do default(shared) private(do_I,dvhdv,dv,dv_max_CFL,dv_min_CFL,vh_tot_0, & + !$OMP dvhdv_tot_0,FAvi,visc_rem_max,I_vrm,dv_lim,dy_N,dy_S, & + !$OMP simple_OBC_pt,any_simple_OBC,l_seg) & + !$OMP firstprivate(visc_rem) do J=jsh-1,jeh do i=ish,ieh ; do_I(i) = .true. ; enddo ! This sets vh and dvhdv. @@ -1602,31 +1615,32 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p l_seg = OBC%segnum_v(i,J) ! Avoid reconciling barotropic/baroclinic transports if transport is specified - is_simple = .false. - if (l_seg /= OBC_NONE) is_simple = OBC%segment(l_seg)%specified - do_I(i) = .not.(l_seg /= OBC_NONE .and. is_simple) - any_simple_OBC = any_simple_OBC .or. is_simple + simple_OBC_pt(i) = .false. + if (l_seg /= OBC_NONE) simple_OBC_pt(i) = OBC%segment(l_seg)%specified + do_I(i) = .not.simple_OBC_pt(i) + any_simple_OBC = any_simple_OBC .or. simple_OBC_pt(i) enddo ; else ; do i=ish,ieh do_I(i) = .true. enddo ; endif endif if (present(vhbt)) then + ! Find dv and vh. call meridional_flux_adjust(v, h_in, h_S, h_N, vhbt(:,J), vh_tot_0, dvhdv_tot_0, dv, & dv_max_CFL, dv_min_CFL, dt, G, GV, US, CS, visc_rem, & j, ish, ieh, do_I, por_face_areaV, vh, OBC=OBC) if (present(v_cor)) then ; do k=1,nz do i=ish,ieh ; v_cor(i,J,k) = v(i,J,k) + dv(i) * visc_rem(i,k) ; enddo - if (local_specified_BC) then ; do i=ish,ieh - l_seg = OBC%segnum_v(i,J) - - if (l_seg /= OBC_NONE) then - if (OBC%segment(OBC%segnum_v(i,J))%specified) & - v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) - endif - enddo ; endif + if (any_simple_OBC) then ; do i=ish,ieh ; if (simple_OBC_pt(i)) then + v_cor(i,J,k) = OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) + endif ; enddo ; endif enddo ; endif ! v-corrected + + if (present(dv_cor)) then + do i=ish,ieh ; dv_cor(i,J) = dv(i) ; enddo + endif + endif if (set_BT_cont) then @@ -1635,19 +1649,16 @@ subroutine meridional_mass_flux(v, h_in, h_S, h_N, vh, dt, G, GV, US, CS, OBC, p visc_rem_max, J, ish, ieh, do_I, por_face_areaV) if (any_simple_OBC) then do i=ish,ieh - do_I(I) = .false. - if (OBC%segnum_v(i,J) /= OBC_NONE) do_I(i) = (OBC%segment(OBC%segnum_v(i,J))%specified) - - if (do_I(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) + if (simple_OBC_pt(i)) FAvi(i) = GV%H_subroundoff*G%dx_Cv(i,J) enddo - ! NOTE: do_I(I) should prevent access to segment OBC_NONE - do k=1,nz ; do i=ish,ieh ; if (do_I(i)) then + ! NOTE: simple_OBC_pt(i) should prevent access to segment OBC_NONE + do k=1,nz ; do i=ish,ieh ; if (simple_OBC_pt(i)) then if ((abs(OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k)) > 0.0) .and. & (OBC%segment(OBC%segnum_v(i,J))%specified)) & FAvi(i) = FAvi(i) + OBC%segment(OBC%segnum_v(i,J))%normal_trans(i,J,k) / & OBC%segment(OBC%segnum_v(i,J))%normal_vel(i,J,k) endif ; enddo ; enddo - do i=ish,ieh ; if (do_I(i)) then + do i=ish,ieh ; if (simple_OBC_pt(i)) then BT_cont%FA_v_S0(i,J) = FAvi(i) ; BT_cont%FA_v_N0(i,J) = FAvi(i) BT_cont%FA_v_SS(i,J) = FAvi(i) ; BT_cont%FA_v_NN(i,J) = FAvi(i) BT_cont%vBT_SS(i,J) = 0.0 ; BT_cont%vBT_NN(i,J) = 0.0 @@ -2000,15 +2011,14 @@ subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0 !! fraction of a time-step's worth of a barotropic acceleration that !! a layer experiences after viscosity is applied [nondim]. !! Visc_rem is between 0 (at the bottom) and 1 (far above the bottom). - real, dimension(SZI_(G)), & - optional, intent(in) :: vhbt !< The summed volume flux through meridional faces + real, dimension(SZI_(G)), intent(in) :: vhbt !< The summed volume flux through meridional faces !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G)), intent(in) :: dv_max_CFL !< Maximum acceptable value of dv [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: dv_min_CFL !< Minimum acceptable value of dv [L T-1 ~> m s-1]. real, dimension(SZI_(G)), intent(in) :: vh_tot_0 !< The summed transport with 0 adjustment - !! [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! [H L2 T-1 ~> m3 s-1 or kg s-1]. real, dimension(SZI_(G)), intent(in) :: dvhdv_tot_0 !< The partial derivative of dv_err with - !! dv at 0 adjustment [H L ~> m2 or kg m-1]. + !! dv at 0 adjustment [H L ~> m2 or kg m-1]. real, dimension(SZI_(G)), intent(out) :: dv !< The barotropic velocity adjustment [L T-1 ~> m s-1]. real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -2036,7 +2046,7 @@ subroutine meridional_flux_adjust(v, h_in, h_S, h_N, vhbt, vh_tot_0, dvhdv_tot_0 dv_min, & ! Lower limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1] dv_max ! Upper limit on dv correction based on CFL limits and previous iterations [L T-1 ~> m s-1] real :: dv_prev ! The previous value of dv [L T-1 ~> m s-1]. - real :: ddv ! The change in dv from the previous iteration [L T-1 ~> m s-1]. + real :: ddv ! The change in dv from the previous iteration [L T-1 ~> m s-1]. real :: tol_eta ! The tolerance for the current iteration [H ~> m or kg m-2]. real :: tol_vel ! The tolerance for velocity in the current iteration [L T-1 ~> m s-1]. integer :: i, k, nz, itt, max_itts = 20 From 7d334f8867675b2902716789807e46d7e7510f9c Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 13 Dec 2023 13:13:00 -0500 Subject: [PATCH 496/629] Makedep: Include support for CPP condition blocks This patch adds support to makedep for handling most #ifdef-like condition blocks. The following preprocessing commands are handled: * #define / #undef * #ifdef / #else / #endif A new flag is added to provide defined macros (-D), and is chosen to match the `cpp` flag, so that flags can be shared across programs. Macros are tracked in a new internal variable and are used for #ifdef testing. Nested condition blocks are supported by using an internal stack of the exclusion state. Certain cases are still not handled. * #if blocks containing logical expressions are not parsed. * CPP content inside of #include is ignored. No doubt many other cases are still unconsidered, such as exotic macro names. The autoconf builds use this feature by passing the generated $(DEFS) argument to makedep. This is suitable for now, but we may need to consider two cases in the future: * Macros defined in $CPPFLAGS are currently ignored, and perhaps they should be included here. The risk is that it may contain non-macro flags. * At some point, DEFS could be moved to a config.h file, and DEFS would no longer contain these macros. (Note that this is very unlikely at the moment, since this feature only works with C.) --- ac/Makefile.in | 3 +- ac/makedep | 93 +++++++++++++++++++++++++++++++++++++++++++++++--- 2 files changed, 89 insertions(+), 7 deletions(-) diff --git a/ac/Makefile.in b/ac/Makefile.in index 64a60e70d1..c4d23efdfb 100644 --- a/ac/Makefile.in +++ b/ac/Makefile.in @@ -19,7 +19,6 @@ SRC_DIRS = @SRC_DIRS@ -include Makefile.dep - # Generate Makefile from template Makefile: @srcdir@/ac/Makefile.in config.status ./config.status @@ -33,7 +32,7 @@ rwildcard=$(foreach d,$(wildcard $(1:=/*)),$(call rwildcard,$d,$2) $(filter $(su .PHONY: depend depend: Makefile.dep Makefile.dep: $(MAKEDEP) $(call rwildcard,$(SRC_DIRS),*.h *.c *.inc *.F90) - $(PYTHON) $(MAKEDEP) -o Makefile.dep -e $(SRC_DIRS) + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e $(SRC_DIRS) # Delete any files associated with configuration (including the Makefile). diff --git a/ac/makedep b/ac/makedep index 99c2ef6ce6..e37f35aca5 100755 --- a/ac/makedep +++ b/ac/makedep @@ -13,9 +13,16 @@ import sys # Pre-compile re searches re_module = re.compile(r"^ *module +([a-z_0-9]+)") re_use = re.compile(r"^ *use +([a-z_0-9]+)") +re_cpp_define = re.compile(r"^ *# *define +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_undef = re.compile(r"^ *# *undef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_ifdef = re.compile(r"^ *# *ifdef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_ifndef = re.compile(r"^ *# *ifndef +[_a-zA-Z][_a-zA-Z0-9]") +re_cpp_if = re.compile(r"^ *# *if +") +re_cpp_else = re.compile(r"^ *# *else") +re_cpp_endif = re.compile(r"^ *# *endif") re_cpp_include = re.compile(r"^ *# *include *[<\"']([a-zA-Z_0-9\.]+)[>\"']") re_f90_include = re.compile(r"^ *include +[\"']([a-zA-Z_0-9\.]+)[\"']") -re_program = re.compile(r"^ *[pP][rR][oO][gG][rR][aA][mM] +([a-zA-Z_0-9]+)") +re_program = re.compile(r"^ *program +([a-z_0-9]+)", re.IGNORECASE) re_end = re.compile(r"^ *end *(module|procedure) ", re.IGNORECASE) # NOTE: This excludes comments and tokens with substrings containing `function` # or `subroutine`, but will fail if the keywords appear in other contexts. @@ -26,7 +33,7 @@ re_procedure = re.compile( def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, - link_externals, script_path): + link_externals, defines): """Create "makefile" after scanning "src_dis".""" # Scan everything Fortran related @@ -66,7 +73,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, o2mods, o2uses, o2h, o2inc, o2prg, prg2o, mod2o = {}, {}, {}, {}, {}, {}, {} externals, all_modules = [], [] for f in F90_files: - mods, used, cpp, inc, prg, has_externals = scan_fortran_file(f) + mods, used, cpp, inc, prg, has_externals = scan_fortran_file(f, defines) # maps object file to modules produced o2mods[object_file(f)] = mods # maps module produced to object file @@ -272,10 +279,16 @@ def nested_inc(inc_files, f2F): return inc_files + sorted(set(hlst)), used_mods -def scan_fortran_file(src_file): +def scan_fortran_file(src_file, defines=None): """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 = [], [], [], [], [] + + cpp_defines = defines if defines is not None else [] + + cpp_macros = [define.split('=')[0] for define in cpp_defines] + cpp_group_stack = [] + with io.open(src_file, 'r', errors='replace') as file: lines = file.readlines() @@ -285,7 +298,72 @@ def scan_fortran_file(src_file): file_has_externals = False # True if the file contains any external objects + cpp_exclude = False + # True if the parser excludes the subsequent lines + + cpp_group_stack = [] + # Stack of condition group exclusion states + for line in lines: + # Start of #ifdef condition group + match = re_cpp_ifdef.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # If outer group is excluding or macro is missing, then exclude + macro = line.lstrip()[1:].split()[1] + cpp_exclude = cpp_exclude or macro not in cpp_macros + + # Start of #ifndef condition group + match = re_cpp_ifndef.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # If outer group is excluding or macro is present, then exclude + macro = line.lstrip()[1:].split()[1] + cpp_exclude = cpp_exclude or macro in cpp_macros + + # Start of #if condition group + match = re_cpp_if.match(line) + if match: + cpp_group_stack.append(cpp_exclude) + + # XXX: Don't attempt to parse #if statements, but store the state. + # if/endif stack. For now, assume that these always fail. + cpp_exclude = False + + # Complement #else condition group + match = re_cpp_else.match(line) + if match: + # Reverse the exclude state, if there is no outer exclude state + outer_grp_exclude = cpp_group_stack and cpp_group_stack[-1] + cpp_exclude = not cpp_exclude or outer_grp_exclude + + # Restore exclude state when exiting conditional block + match = re_cpp_endif.match(line) + if match: + cpp_exclude = cpp_group_stack.pop() + + # Skip lines inside of false condition blocks + if cpp_exclude: + continue + + # Activate a new macro (ignoring the value) + match = re_cpp_define.match(line) + if match: + new_macro = line.lstrip()[1:].split()[1] + cpp_macros.append(new_macro) + + # Deactivate a macro + match = re_cpp_undef.match(line) + if match: + new_macro = line.lstrip()[1:].split()[1] + try: + cpp_macros.remove(new_macro) + except: + # Ignore missing macros (for now?) + continue + match = re_module.match(line.lower()) if match: if match.group(1) not in 'procedure': # avoid "module procedure" statements @@ -404,8 +482,13 @@ parser.add_argument( action='append', help="Skip directory in source code search." ) +parser.add_argument( + '-D', '--define', + action='append', + help="Apply preprocessor define macros (of the form -DMACRO[=value])", +) args = parser.parse_args() # Do the thing create_deps(args.path, args.skip, args.makefile, args.debug, args.exec_target, - args.fc_rule, args.link_externals, sys.argv[0]) + args.fc_rule, args.link_externals, args.define) From 4e8fbe15039a5006adeb8025667fce4d2f6b608e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 16 Aug 2023 18:07:52 -0400 Subject: [PATCH 497/629] +Standardize input salinity units as "ppt" Standardized the syntax for the units of salinities that are read via get_param calls to be uniformly 'units="ppt"' or similar units for derivatives with salinity. The only exceptions are places where practical salinity is used specifically, which occurs for several arguments in the MOM_EOS code. All answers are bitwise identical, but there are changes to a number of MOM_parameter_doc files. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 2 +- .../solo_driver/MOM_surface_forcing.F90 | 8 ++-- src/equation_of_state/MOM_EOS.F90 | 30 ++++++------- src/equation_of_state/MOM_EOS_linear.F90 | 44 +++++++++---------- .../MOM_coord_initialization.F90 | 8 ++-- .../MOM_state_initialization.F90 | 10 ++--- .../vertical/MOM_bulk_mixed_layer.F90 | 4 +- src/tracer/MOM_tracer_Z_init.F90 | 12 ++--- src/user/DOME2d_initialization.F90 | 10 ++--- src/user/ISOMIP_initialization.F90 | 4 +- src/user/Rossby_front_2d_initialization.F90 | 14 +++--- src/user/SCM_CVMix_tests.F90 | 10 ++--- src/user/adjustment_initialization.F90 | 18 ++++---- src/user/benchmark_initialization.F90 | 2 +- src/user/dense_water_initialization.F90 | 10 ++--- src/user/dumbbell_initialization.F90 | 18 ++++---- src/user/dumbbell_surface_forcing.F90 | 4 +- src/user/seamount_initialization.F90 | 14 +++--- src/user/sloshing_initialization.F90 | 6 +-- 19 files changed, 112 insertions(+), 116 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 f9f7fe88a0..fc4d8e79f6 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -1522,7 +1522,7 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) endif call get_param(param_file, mdl, "SPEAR_DTFREEZE_DS", CS%SPEAR_dTf_dS, & "The derivative of the freezing temperature with salinity.", & - units="deg C PSU-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, & + units="degC ppt-1", default=-0.054, scale=US%degC_to_C*US%S_to_ppt, & do_not_log=.not.CS%trestore_SPEAR_ECDA) call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & "The density that is used to convert piston velocities into salt or heat "//& diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index d17db5a9a1..14f861e955 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -1907,19 +1907,19 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C call get_param(param_file, mdl, "SST_NORTH", CS%T_north, & "With buoy_config linear, the sea surface temperature "//& "at the northern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0, scale=US%degC_to_C) + "to restore.", units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SST_SOUTH", CS%T_south, & "With buoy_config linear, the sea surface temperature "//& "at the southern end of the domain toward which to "//& - "to restore.", units="deg C", default=0.0, scale=US%degC_to_C) + "to restore.", units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "SSS_NORTH", CS%S_north, & "With buoy_config linear, the sea surface salinity "//& "at the northern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0, scale=US%ppt_to_S) + "to restore.", units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "SSS_SOUTH", CS%S_south, & "With buoy_config linear, the sea surface salinity "//& "at the southern end of the domain toward which to "//& - "to restore.", units="PSU", default=35.0, scale=US%ppt_to_S) + "to restore.", units="ppt", default=35.0, scale=US%ppt_to_S) endif call get_param(param_file, mdl, "RESTORE_FLUX_RHO", CS%rho_restore, & "The density that is used to convert piston velocities into salt or heat "//& diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index a68e3b2229..d5c7abc977 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1517,8 +1517,8 @@ subroutine EOS_init(param_file, EOS, US) "temperature.", units="kg m-3 K-1", default=-0.2) call get_param(param_file, mdl, "DRHO_DS", EOS%dRho_dS, & "When EQN_OF_STATE="//trim(EOS_LINEAR_STRING)//", "//& - "this is the partial derivative of density with "//& - "salinity.", units="kg m-3 PSU-1", default=0.8) + "this is the partial derivative of density with salinity.", & + units="kg m-3 ppt-1", default=0.8) call EOS_manual_init(EOS, form_of_EOS=EOS_LINEAR, Rho_T0_S0=EOS%Rho_T0_S0, dRho_dT=EOS%dRho_dT, dRho_dS=EOS%dRho_dS) endif if (EOS%form_of_EOS == EOS_WRIGHT) then @@ -1563,17 +1563,17 @@ subroutine EOS_init(param_file, EOS, US) call get_param(param_file, mdl, "TFREEZE_S0_P0",EOS%TFr_S0_P0, & "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& "this is the freezing potential temperature at "//& - "S=0, P=0.", units="deg C", default=0.0) + "S=0, P=0.", units="degC", default=0.0) call get_param(param_file, mdl, "DTFREEZE_DS",EOS%dTFr_dS, & "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& "this is the derivative of the freezing potential "//& "temperature with salinity.", & - units="deg C PSU-1", default=-0.054) + units="degC ppt-1", default=-0.054) call get_param(param_file, mdl, "DTFREEZE_DP",EOS%dTFr_dP, & "When TFREEZE_FORM="//trim(TFREEZE_LINEAR_STRING)//", "//& "this is the derivative of the freezing potential "//& "temperature with pressure.", & - units="deg C Pa-1", default=0.0) + units="degC Pa-1", default=0.0) endif if ((EOS%form_of_EOS == EOS_TEOS10 .or. EOS%form_of_EOS == EOS_ROQUET_RHO .or. & @@ -1694,7 +1694,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) type(EOS_type), intent(in) :: EOS !< Equation of state structure real, parameter :: Sref_Sprac = (35.16504/35.0) ! The TEOS 10 conversion factor to go from - ! practical salinity to reference salinity [nondim] + ! practical salinity to reference salinity [PSU ppt-1] integer :: i, j, k if ((EOS%form_of_EOS /= EOS_TEOS10) .and. (EOS%form_of_EOS /= EOS_ROQUET_RHO) .and. & @@ -1808,20 +1808,20 @@ end subroutine pot_temp_to_cons_temp !! 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] - real, dimension(:), intent(inout) :: prSaln !< Practical salinity [S ~> ppt] + real, dimension(:), intent(inout) :: prSaln !< Practical salinity [S ~> PSU] 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 + !! practical salinities 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. ! 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 :: S_scale ! A factor to convert practical salinity from ppt to the desired units [S PSU-1 ~> 1] real, parameter :: Sprac_Sref = (35.0/35.16504) ! The TEOS 10 conversion factor to go from - ! reference salinity to practical salinity [nondim] + ! reference salinity to practical salinity [PSU ppt-1] integer :: i, is, ie if (present(dom)) then @@ -1848,21 +1848,21 @@ end subroutine abs_saln_to_prac_saln !! 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) - real, dimension(:), intent(in) :: S !< Practical salinity [S ~> ppt] + real, dimension(:), intent(in) :: S !< Practical salinity [S ~> PSU] 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], + !! absolute salnities in place of with scaling stored + !! in EOS. A value of 1.0 returns salinities in [ppt], !! while the default is equivalent to EOS%ppt_to_S. ! 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 :: S_scale ! A factor to convert absolute 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] + ! practical salinity to reference salinity [PSU ppt-1] integer :: i, is, ie if (present(dom)) then diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index e171aaa442..db67040304 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -59,7 +59,7 @@ module MOM_EOS_linear real elemental function density_elem_linear(this, T, S, pressure) class(linear_EOS), intent(in) :: this !< This EOS real, intent(in) :: T !< Potential temperature relative to the surface [degC] - real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] density_elem_linear = this%Rho_T0_S0 + this%dRho_dT*T + this%dRho_dS*S @@ -73,7 +73,7 @@ end function density_elem_linear real elemental function density_anomaly_elem_linear(this, T, S, pressure, rho_ref) class(linear_EOS), intent(in) :: this !< This EOS real, intent(in) :: T !< Potential temperature relative to the surface [degC] - real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< Pressure [Pa] real, intent(in) :: rho_ref !< A reference density [kg m-3] @@ -87,9 +87,8 @@ end function density_anomaly_elem_linear !! scalar and array inputs. real elemental function spec_vol_elem_linear(this, T, S, pressure) class(linear_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. real, intent(in) :: pressure !< Pressure [Pa]. spec_vol_elem_linear = 1.0 / ( this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S)) @@ -102,9 +101,8 @@ end function spec_vol_elem_linear !! scalar and array inputs. real elemental function spec_vol_anomaly_elem_linear(this, T, S, pressure, spv_ref) class(linear_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. real, intent(in) :: pressure !< Pressure [Pa]. real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. @@ -118,9 +116,8 @@ end function spec_vol_anomaly_elem_linear !! with potential temperature and salinity. elemental subroutine calculate_density_derivs_elem_linear(this,T, S, pressure, dRho_dT, dRho_dS) class(linear_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. real, intent(in) :: pressure !< Pressure [Pa]. real, intent(out) :: drho_dT !< The partial derivative of density with !! potential temperature [kg m-3 degC-1]. @@ -138,16 +135,16 @@ elemental subroutine calculate_density_second_derivs_elem_linear(this, T, S, pre drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) class(linear_EOS), intent(in) :: this !< This EOS real, intent(in) :: T !< Potential temperature relative to the surface [degC]. - real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: S !< Salinity [ppt]. real, intent(in) :: pressure !< pressure [Pa]. real, intent(inout) :: drho_dS_dS !< The second derivative of density with - !! salinity [kg m-3 PSU-2]. + !! salinity [kg m-3 ppt-2]. real, intent(inout) :: drho_dS_dT !< The second derivative of density with !! temperature and salinity [kg m-3 ppt-1 degC-1]. real, intent(inout) :: drho_dT_dT !< The second derivative of density with !! temperature [kg m-3 degC-2]. real, intent(inout) :: drho_dS_dP !< The second derivative of density with - !! salinity and pressure [kg m-3 PSU-1 Pa-1]. + !! salinity and pressure [kg m-3 ppt-1 Pa-1]. real, intent(inout) :: drho_dT_dP !< The second derivative of density with !! temperature and pressure [kg m-3 degC-1 Pa-1]. @@ -163,10 +160,10 @@ end subroutine calculate_density_second_derivs_elem_linear elemental subroutine calculate_specvol_derivs_elem_linear(this, T, S, pressure, dSV_dT, dSV_dS) class(linear_EOS), intent(in) :: this !< This EOS real, intent(in) :: T !< Potential temperature [degC] - real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: S !< Salinity [ppt] real, intent(in) :: pressure !< pressure [Pa] real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with - !! salinity [m3 kg-1 PSU-1] + !! salinity [m3 kg-1 ppt-1] real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with !! potential temperature [m3 kg-1 degC-1] ! Local variables @@ -184,9 +181,8 @@ end subroutine calculate_specvol_derivs_elem_linear !! salinity, potential temperature, and pressure. elemental subroutine calculate_compress_elem_linear(this, T, S, pressure, rho, drho_dp) class(linear_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< Potential temperature relative to the surface - !! [degC]. - real, intent(in) :: S !< Salinity [PSU]. + real, intent(in) :: T !< Potential temperature relative to the surface [degC]. + real, intent(in) :: S !< Salinity [ppt]. real, intent(in) :: pressure !< pressure [Pa]. real, intent(out) :: rho !< In situ density [kg m-3]. real, intent(out) :: drho_dp !< The partial derivative of density with pressure @@ -201,7 +197,7 @@ end subroutine calculate_compress_elem_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) :: S !< Salinity [ppt] 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 @@ -268,7 +264,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & 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]. + intent(in) :: S !< Salinity [S ~> ppt]. 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), & @@ -439,7 +435,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & 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]. + intent(in) :: S !< Salinity [S ~> ppt]. 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), & @@ -614,7 +610,7 @@ end subroutine int_spec_vol_dp_linear subroutine calculate_density_array_linear(this, T, S, pressure, rho, start, npts, rho_ref) class(linear_EOS), intent(in) :: this !< This EOS real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: S !< Salinity [ppt] 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 @@ -640,7 +636,7 @@ end subroutine calculate_density_array_linear subroutine calculate_spec_vol_array_linear(this, T, S, pressure, specvol, start, npts, spv_ref) class(linear_EOS), intent(in) :: this !< This EOS real, dimension(:), intent(in) :: T !< Potential temperature relative to the surface [degC] - real, dimension(:), intent(in) :: S !< Salinity [PSU] + real, dimension(:), intent(in) :: S !< Salinity [ppt] 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 diff --git a/src/initialization/MOM_coord_initialization.F90 b/src/initialization/MOM_coord_initialization.F90 index 37c719209b..bb7832525f 100644 --- a/src/initialization/MOM_coord_initialization.F90 +++ b/src/initialization/MOM_coord_initialization.F90 @@ -235,7 +235,7 @@ subroutine set_coord_from_TS_ref(Rlay, g_prime, GV, US, param_file, eqn_of_state "The initial temperature of the lightest layer.", & units="degC", scale=US%degC_to_C, fail_if_missing=.true.) call get_param(param_file, mdl, "S_REF", S_ref, & - "The initial salinities.", units="PSU", default=35.0, scale=US%ppt_to_S) + "The initial salinities.", units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "GFS", g_fs, & "The reduced gravity at the free surface.", units="m s-2", & default=GV%g_Earth*US%L_T_to_m_s**2*US%m_to_Z, scale=US%m_s_to_L_T**2*US%Z_to_m) @@ -376,13 +376,13 @@ subroutine set_coord_from_TS_range(Rlay, g_prime, GV, US, param_file, eqn_of_sta call get_param(param_file, mdl, "S_REF", S_Ref, & "The default initial salinities.", & - units="PSU", default=35.0, scale=US%ppt_to_S) + units="ppt", default=35.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_Light, & "The initial lightest salinities when COORD_CONFIG is set to ts_range.", & - units="PSU", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_Dense, & "The initial densest salinities when COORD_CONFIG is set to ts_range.", & - units="PSU", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S) call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & "The ratio of density space resolution in the densest "//& diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4bddc0965a..7dfced262b 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1745,7 +1745,7 @@ subroutine initialize_temp_salt_fit(T, S, G, GV, US, param_file, eqn_of_state, P units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_Ref, & "A reference salinity used in initialization.", & - units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "FIT_SALINITY", fit_salin, & "If true, accept the prescribed temperature and fit the "//& "salinity; otherwise take salinity and fit temperature.", & @@ -1829,10 +1829,10 @@ subroutine initialize_temp_salt_linear(T, S, G, GV, US, param_file, just_read) units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_TOP", S_top, & "Initial salinity of the top surface.", & - units="PSU", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_RANGE", S_range, & "Initial salinity difference (top-bottom).", & - units="PSU", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -2645,7 +2645,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(PF, mdl, "LAND_FILL_SALIN", salt_land_fill, & "A value to use to fill in ocean salinities on land points.", & - units="1e-3", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "HORIZ_INTERP_TOL_TEMP", tol_temp, & "The tolerance in temperature changes between iterations when interpolating "//& "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& @@ -2655,7 +2655,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just "The tolerance in salinity changes between iterations when interpolating "//& "from an input dataset using horiz_interp_and_extrap_tracer. This routine "//& "converges slowly, so an overly small tolerance can get expensive.", & - units="1e-3", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=1.0e-3, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) then if ((.not.useALEremapping) .and. adjust_temperature) & diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index c7e522eddc..f2b38c4a29 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -4026,14 +4026,14 @@ subroutine bulkmixedlayer_init(Time, G, GV, US, param_file, diag, CS) "during detrainment.", units="K", default=0.5, scale=US%degC_to_C) call get_param(param_file, mdl, "ALLOWED_DETRAIN_SALT_CHG", CS%Allowed_S_chg, & "The amount by which salinity is allowed to exceed previous values "//& - "during detrainment.", units="PSU", default=0.1, scale=US%ppt_to_S) + "during detrainment.", units="ppt", default=0.1, scale=US%ppt_to_S) call get_param(param_file, mdl, "ML_DT_DS_WEIGHT", CS%dT_dS_wt, & "When forced to extrapolate T & S to match the layer "//& "densities, this factor (in deg C / PSU) is combined "//& "with the derivatives of density with T & S to determine "//& "what direction is orthogonal to density contours. It "//& "should be a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & - units="degC PSU-1", default=6.0, scale=US%degC_to_C*US%S_to_ppt) + units="degC ppt-1", default=6.0, scale=US%degC_to_C*US%S_to_ppt) call get_param(param_file, mdl, "BUFFER_LAYER_EXTRAP_LIMIT", CS%BL_extrap_lim, & "A limit on the density range over which extrapolation "//& "can occur when detraining from the buffer layers, "//& diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index fab7da3917..c404c560f3 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -628,16 +628,16 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, units="degC", default=31.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_S_MIN", S_min, & "The minimum salinity that can be found by determine_temperature.", & - units="1e-3", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_S_MAX", S_max, & "The maximum salinity that can be found by determine_temperature.", & - units="1e-3", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=65.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_T_TOLERANCE", tol_T, & "The convergence tolerance for temperature in determine_temperature.", & units="degC", default=1.0e-4, scale=US%degC_to_C, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_S_TOLERANCE", tol_S, & "The convergence tolerance for temperature in determine_temperature.", & - units="1e-3", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=1.0e-4, scale=US%ppt_to_S, do_not_log=just_read) call get_param(PF, mdl, "DETERMINE_TEMP_RHO_TOLERANCE", tol_rho, & "The convergence tolerance for density in determine_temperature.", & units="kg m-3", default=1.0e-4, scale=US%kg_m3_to_R, do_not_log=just_read) @@ -645,10 +645,10 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, ! By default 10 degC is weighted equivalently to 1 ppt when minimizing changes. call get_param(PF, mdl, "DETERMINE_TEMP_DT_DS_WEIGHT", dT_dS_gauge, & "When extrapolating T & S to match the layer target densities, this "//& - "factor (in deg C / PSU) is combined with the derivatives of density "//& + "factor (in degC / ppt) is combined with the derivatives of density "//& "with T & S to determine what direction is orthogonal to density contours. "//& "It could be based on a typical value of (dR/dS) / (dR/dT) in oceanic profiles.", & - units="degC PSU-1", default=10.0, scale=US%degC_to_C*US%S_to_ppt) + units="degC ppt-1", default=10.0, scale=US%degC_to_C*US%S_to_ppt) else call get_param(PF, mdl, "DETERMINE_TEMP_T_ADJ_RANGE", max_t_adj, & "The maximum amount by which the initial layer temperatures can be "//& @@ -657,7 +657,7 @@ subroutine determine_temperature(temp, salt, R_tgt, EOS, p_ref, niter, k_start, call get_param(PF, mdl, "DETERMINE_TEMP_S_ADJ_RANGE", max_S_adj, & "The maximum amount by which the initial layer salinities can be "//& "modified in determine_temperature.", & - units="1e-3", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=0.5, scale=US%ppt_to_S, do_not_log=just_read) endif if (just_read) return ! All run-time parameters have been read, so return. diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index dade17a9a0..c1ec83257d 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -261,15 +261,15 @@ subroutine DOME2d_initialize_temperature_salinity ( T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "DOME2D_SHELF_DEPTH", dome2d_depth_bay, & units="nondim", default=0.2, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_RANGE", S_range,' Initial salinity range', & - units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & - units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "DOME2D_T_BAY", T_bay, & "Temperature in the inflow embayment in the DOME2d test case", & units="degC", default=1.0, scale=US%degC_to_C, do_not_log=just_read) @@ -440,10 +440,10 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A call get_param(param_file, mdl, "S_RANGE", S_range, units="ppt", default=2.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "T_RANGE", T_range, units="degC", default=0.0, scale=US%degC_to_C) call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & - units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "DOME2D_EAST_SPONGE_S_RANGE", S_range_sponge, & "Range of salinities in the eastern sponge region in the DOME2D configuration", & - units="1e-3", default=1.0, scale=US%ppt_to_S) + units="ppt", default=1.0, scale=US%ppt_to_S) ! Set the sponge damping rate as a function of position Idamp(:,:) = 0.0 diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 232ce6d4e7..3f28da4d5e 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -348,7 +348,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U default=.false., do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DS", drho_dS1, & "Partial derivative of density with salinity.", & - units="kg m-3 PSU-1", scale=US%kg_m3_to_R*US%S_to_ppt, & + units="kg m-3 ppt-1", scale=US%kg_m3_to_R*US%S_to_ppt, & fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DT", drho_dT1, & "Partial derivative of density with temperature.", & @@ -359,7 +359,7 @@ subroutine ISOMIP_initialize_temperature_salinity ( T, S, h, depth_tot, G, GV, U units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_Ref, & "A reference salinity used in initialization.", & - units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. ! write(mesg,*) 'read drho_dS, drho_dT', drho_dS1, drho_dT1 diff --git a/src/user/Rossby_front_2d_initialization.F90 b/src/user/Rossby_front_2d_initialization.F90 index b76e69bb44..33c7641a00 100644 --- a/src/user/Rossby_front_2d_initialization.F90 +++ b/src/user/Rossby_front_2d_initialization.F90 @@ -68,7 +68,7 @@ subroutine Rossby_front_initialize_thickness(h, G, GV, US, param_file, just_read call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & units="kg m-3 degC-1", default=-0.2, scale=US%kg_m3_to_R*US%C_to_degC, do_not_log=.true.) call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & @@ -155,11 +155,11 @@ subroutine Rossby_front_initialize_temperature_salinity(T, S, h, G, GV, US, & call get_param(param_file, mdl,"REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & - units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & units="m", default=-1.e9, scale=GV%m_to_H, do_not_log=.true.) @@ -231,11 +231,11 @@ subroutine Rossby_front_initialize_velocity(u, v, h, G, GV, US, param_file, just call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & default=DEFAULT_COORDINATE_MODE, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & - units='C', default=0.0, scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=.true.) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & - units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=.true.) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=.true.) call get_param(param_file, mdl, "RHO_T0_S0", Rho_T0_S0, & units="kg m-3", default=1000.0, scale=US%kg_m3_to_R, do_not_log=.true.) call get_param(param_file, mdl, "DRHO_DT", dRho_dT, & diff --git a/src/user/SCM_CVMix_tests.F90 b/src/user/SCM_CVMix_tests.F90 index 104a2b0312..be515f22ca 100644 --- a/src/user/SCM_CVMix_tests.F90 +++ b/src/user/SCM_CVMix_tests.F90 @@ -88,13 +88,13 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) 'Initial salt mixed layer depth', & units='m', default=0.0, scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L1_SALT", UpperLayerSalt, & - 'Layer 2 surface salinity', units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + 'Layer 2 surface salinity', units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L1_TEMP", UpperLayerTemp, & - 'Layer 1 surface temperature', units='C', default=20.0, scale=US%degC_to_C, do_not_log=just_read) + 'Layer 1 surface temperature', units="degC", default=20.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_SALT", LowerLayerSalt, & - 'Layer 2 surface salinity', units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + 'Layer 2 surface salinity', units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_TEMP", LowerLayerTemp, & - 'Layer 2 surface temperature', units='C', default=20.0, scale=US%degC_to_C, do_not_log=just_read) + 'Layer 2 surface temperature', units="degC", default=20.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_DTDZ", LowerLayerdTdZ, & 'Initial temperature stratification in layer 2', & units='C/m', default=0.0, scale=US%degC_to_C*US%Z_to_m, do_not_log=just_read) @@ -102,7 +102,7 @@ subroutine SCM_CVMix_tests_TS_init(T, S, h, G, GV, US, param_file, just_read) 'Initial salinity stratification in layer 2', & units='PPT/m', default=0.0, scale=US%ppt_to_S*US%Z_to_m, do_not_log=just_read) call get_param(param_file, mdl, "SCM_L2_MINTEMP",LowerLayerMinTemp, & - 'Layer 2 minimum temperature', units='C', default=4.0, scale=US%degC_to_C, do_not_log=just_read) + 'Layer 2 minimum temperature', units="degC", default=4.0, scale=US%degC_to_C, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. diff --git a/src/user/adjustment_initialization.F90 b/src/user/adjustment_initialization.F90 index 58389b7b5c..4a1d6c3d9f 100644 --- a/src/user/adjustment_initialization.F90 +++ b/src/user/adjustment_initialization.F90 @@ -76,12 +76,12 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read ! Parameters used by main model initialization if (.not.just_read) call log_version(param_file, mdl, version, "") call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + default=35.0, units='ppt', scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "MIN_THICKNESS", min_thickness, 'Minimum layer thickness', & default=1.0e-3, units='m', scale=US%m_to_Z, do_not_log=just_read) call get_param(param_file, mdl, "DRHO_DS", dRho_dS, & "The partial derivative of density with salinity with a linear equation of state.", & - units="kg m-3 PSU-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) + units="kg m-3 ppt-1", default=0.8, scale=US%kg_m3_to_R*US%S_to_ppt) ! Parameters specific to this experiment configuration call get_param(param_file, mdl, "REGRIDDING_COORDINATE_MODE", verticalCoordinate, & @@ -91,10 +91,10 @@ subroutine adjustment_initialize_thickness ( h, G, GV, US, param_file, just_read units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & "Top-to-bottom salinity difference of stratification", & - units="1e-3", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & "Salinity difference across front", & - units="1e-3", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & "Amplitude of trans-frontal wave perturbation", & units=G%x_ax_unit_short, default=0., do_not_log=just_read) @@ -239,11 +239,11 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, ! Parameters used by main model initialization call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference temperature', & - units='C', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) + units="degC", scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range', & - default=2.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + default=2.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & default=1.0, units='degC', scale=US%degC_to_C, do_not_log=just_read) ! Parameters specific to this experiment configuration BUT logged in previous s/r @@ -252,9 +252,9 @@ subroutine adjustment_initialize_temperature_salinity(T, S, h, depth_tot, G, GV, call get_param(param_file, mdl, "ADJUSTMENT_WIDTH", adjustment_width, & units=G%x_ax_unit_short, fail_if_missing=.not.just_read, do_not_log=.true.) call get_param(param_file, mdl, "ADJUSTMENT_DELTAS", adjustment_deltaS, & - units='1e-3', scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) call get_param(param_file, mdl, "DELTA_S_STRAT", delta_S_strat, & - units='1e-3', scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) + units="ppt", scale=US%ppt_to_S, fail_if_missing=.not.just_read, do_not_log=.true.) call get_param(param_file, mdl, "FRONT_WAVE_AMP", front_wave_amp, & units=G%x_ax_unit_short, default=0., do_not_log=.true.) call get_param(param_file, mdl, "FRONT_WAVE_LENGTH", front_wave_length, & diff --git a/src/user/benchmark_initialization.F90 b/src/user/benchmark_initialization.F90 index ad75d83efa..333f53895e 100644 --- a/src/user/benchmark_initialization.F90 +++ b/src/user/benchmark_initialization.F90 @@ -142,7 +142,7 @@ subroutine benchmark_initialize_thickness(h, depth_tot, G, GV, US, param_file, e units="degC", default=29.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, & "The uniform salinities used to initialize the benchmark test case.", & - units="PSU", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! This subroutine has no run-time parameters. diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 03cc983a9f..2daf03ccb1 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -122,11 +122,11 @@ subroutine dense_water_initialize_TS(G, GV, US, param_file, T, S, h, just_read) "Depth of unstratified mixed layer as a fraction of the water column.", & units="nondim", default=default_mld, do_not_log=just_read) call get_param(param_file, mdl, "S_REF", S_ref, 'Reference salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl,"T_REF", T_ref, 'Reference temperature', & units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) call get_param(param_file, mdl,"S_RANGE", S_range, 'Initial salinity range', & - units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) if (just_read) return ! All run-time parameters have been read, so return. @@ -204,7 +204,7 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, units="nondim", default=0.1) call get_param(param_file, mdl, "DENSE_WATER_EAST_SPONGE_SALT", S_dense, & "Salt anomaly of the dense water being formed in the overflow region.", & - units="1e-3", default=4.0, scale=US%ppt_to_S) + units="ppt", default=4.0, scale=US%ppt_to_S) call get_param(param_file, mdl, "DENSE_WATER_MLD", mld, & units="nondim", default=default_mld, do_not_log=.true.) @@ -212,9 +212,9 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, units="nondim", default=default_sill, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, & - units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "S_RANGE", S_range, & - units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "T_REF", T_ref, & units='degC', scale=US%degC_to_C, fail_if_missing=.true., do_not_log=.true.) diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 492cb3ebe8..3d968d85d0 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -183,15 +183,15 @@ subroutine dumbbell_initialize_thickness ( h, depth_tot, G, GV, US, param_file, case ( REGRIDDING_RHO, REGRIDDING_HYCOM1) ! Initial thicknesses for isopycnal coordinates call get_param(param_file, mdl, "INITIAL_SSS", S_surf, & - units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INITIAL_S_RANGE", S_range, & - units='1e-3', default=2., scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, & - units='1e-3', default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & - units='1e-3', default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & - units='1e-3', default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "INTERFACE_IC_QUANTA", eta_IC_quanta, & "The granularity of initial interface height values "//& "per meter, to avoid sensivity to order-of-arithmetic changes.", & @@ -291,10 +291,10 @@ subroutine dumbbell_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ units='degC', default=20., scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_SREF", S_surf, & 'DUMBBELL REFERENCE SALINITY', & - units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & 'DUMBBELL salinity range (right-left)', & - units='1e-3', default=2., scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "DUMBBELL_LEN", dblen, & 'Lateral Length scale for dumbbell ', & units=G%x_ax_unit_short, default=600., do_not_log=just_read) @@ -388,10 +388,10 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil 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.) + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "DUMBBELL_S_RANGE", S_range, & 'DUMBBELL salinity range (right-left)', & - units='1e-3', default=2., scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl,"MIN_THICKNESS", min_thickness, & 'Minimum thickness for layer', & units='m', default=1.0e-3, scale=US%m_to_Z, do_not_log=.true.) diff --git a/src/user/dumbbell_surface_forcing.F90 b/src/user/dumbbell_surface_forcing.F90 index 6f6e4da439..288ccd89fa 100644 --- a/src/user/dumbbell_surface_forcing.F90 +++ b/src/user/dumbbell_surface_forcing.F90 @@ -221,10 +221,10 @@ subroutine dumbbell_surface_forcing_init(Time, G, US, param_file, diag, CS) default=.false., do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & "Initial surface salinity", & - units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & "Initial salinity range (bottom - surface)", & - units="1e-3", default=2., scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "RESTOREBUOY", CS%restorebuoy, & "If true, the buoyancy fluxes drive the model back "//& diff --git a/src/user/seamount_initialization.F90 b/src/user/seamount_initialization.F90 index d1971f25f9..60aef08cb4 100644 --- a/src/user/seamount_initialization.F90 +++ b/src/user/seamount_initialization.F90 @@ -233,16 +233,16 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi 'and "exponential".', default='linear', do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_SSS", S_surf, & 'Initial surface salinity', & - units='1e-3', default=34., scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=34., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_SST", T_surf, & 'Initial surface temperature', & - units='C', default=0., scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=0., scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_S_RANGE", S_range, & 'Initial salinity range (bottom - surface)', & - units='1e-3', default=2., scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=2., scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl,"INITIAL_T_RANGE", T_range, & 'Initial temperature range (bottom - surface)', & - units='C', default=0., scale=US%degC_to_C, do_not_log=just_read) + units="degC", default=0., scale=US%degC_to_C, do_not_log=just_read) select case ( coordinateMode(verticalCoordinate) ) case ( REGRIDDING_LAYER ) ! Initial thicknesses for layer isopycnal coordinates @@ -254,11 +254,11 @@ subroutine seamount_initialize_temperature_salinity(T, S, h, G, GV, US, param_fi call get_param(param_file, mdl, "TS_RANGE_T_DENSE", T_dense, & units="degC", default=US%C_to_degC*T_Ref, scale=US%degC_to_C, do_not_log=.true.) call get_param(param_file, mdl, "S_REF", S_ref, & - units="1e-3", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=35.0, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_LIGHT", S_light, & - units="1e-3", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_S_DENSE", S_dense, & - units="1e-3", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) + units="ppt", default=US%S_to_ppt*S_Ref, scale=US%ppt_to_S, do_not_log=.true.) call get_param(param_file, mdl, "TS_RANGE_RESOLN_RATIO", res_rat, & units="nondim", default=1.0, do_not_log=.true.) if (just_read) return ! All run-time parameters have been read, so return. diff --git a/src/user/sloshing_initialization.F90 b/src/user/sloshing_initialization.F90 index 75e5889092..4381d42038 100644 --- a/src/user/sloshing_initialization.F90 +++ b/src/user/sloshing_initialization.F90 @@ -201,17 +201,17 @@ subroutine sloshing_initialize_temperature_salinity ( T, S, h, G, GV, US, param_ is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke call get_param(param_file, mdl, "S_REF", S_ref, 'Reference value for salinity', & - default=35.0, units='1e-3', scale=US%ppt_to_S, do_not_log=just_read) + default=35.0, units="ppt", scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_REF", T_ref, 'Reference value for temperature', & units='degC', scale=US%degC_to_C, fail_if_missing=.not.just_read, do_not_log=just_read) ! The default is to assume an increase by 2 ppt for the salinity and a uniform temperature. call get_param(param_file, mdl, "S_RANGE", S_range, 'Initial salinity range.', & - units='1e-3', default=2.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=2.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "T_RANGE", T_range, 'Initial temperature range', & units='degC', default=0.0, scale=US%degC_to_C, do_not_log=just_read) call get_param(param_file, mdl, "INITIAL_SSS", S_surf, "Initial surface salinity", & - units="1e-3", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) + units="ppt", default=34.0, scale=US%ppt_to_S, do_not_log=just_read) call get_param(param_file, mdl, "SLOSHING_T_PERT", T_pert, & 'A mid-column temperature perturbation in the sloshing test case', & units='degC', default=1.0, scale=US%degC_to_C, do_not_log=just_read) From 1a8625db94c428932be26a8913644986241ab774 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 15 Dec 2023 15:23:11 -0500 Subject: [PATCH 498/629] Disable FPEs in MacOS testing Due to poor handling of floating point in HDF5 1.14.3, it is currently not possible to use floating point exceptions (FPEs) whenever this version is present. The GitHub Actions CI nodes would randomly select either 1.14.2 or 1.14.3, and would raise an FPE error if 1.14.3 was selected. Additionally, the homebrew installation does not provide a clean method for selecting a different version of HDF5. Thus, for now we disable FPEs in the MacOS testing, and hope to catch any legitimate FP errors in the Ubuntu version. We will restore these tests as soon as this has been fixed in an easily-accessible version of HDF5. As part of this PR, I have also moved the FCFLAGS configuration to the platform specific Actions files, allowing for independent compiler configuration for each platform. --- .github/actions/macos-setup/action.yml | 15 +++++++++++++++ .github/actions/testing-setup/action.yml | 11 ----------- .github/actions/ubuntu-setup/action.yml | 12 ++++++++++++ 3 files changed, 27 insertions(+), 11 deletions(-) diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml index fecbe787b5..4c248abd11 100644 --- a/.github/actions/macos-setup/action.yml +++ b/.github/actions/macos-setup/action.yml @@ -16,3 +16,18 @@ runs: brew install netcdf-fortran brew install mpich echo "::endgroup::" + + # NOTE: Floating point exceptions are currently disabled due to an error in + # HDF5 1.4.3. They will be re-enabled when the default brew version has + # been updated to a working version. + + - name: Set compiler flags + shell: bash + run: | + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml index 6ba149d927..a15dd6d0a2 100644 --- a/.github/actions/testing-setup/action.yml +++ b/.github/actions/testing-setup/action.yml @@ -31,17 +31,6 @@ runs: REPORT_ERROR_LOGS=true make deps/lib/libFMS.a -s -j echo "::endgroup::" - - name: Store compiler flags used in Makefile - shell: bash - run: | - echo "::group::config.mk" - cd .testing - echo "FCFLAGS_DEBUG=-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk - echo "FCFLAGS_REPRO=-g -O2 -fbacktrace" >> config.mk - echo "FCFLAGS_INIT=-finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk - cat config.mk - echo "::endgroup::" - - name: Compile MOM6 in symmetric memory mode shell: bash run: | diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3f3ba5f0b6..83d6795954 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -17,3 +17,15 @@ runs: sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" + + - name: Store compiler flags used in Makefile + shell: bash + run: | + echo "::group::config.mk" + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" From a28443ba138c693fd498a2b3fd40a7b6a91ce83a Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Wed, 6 Dec 2023 13:50:09 -0900 Subject: [PATCH 499/629] Fix for an OBC issue with mask_tables - Without this, if part of your OBC is filled with land mask and if that land mask contains a masked out tile, you will generate a NaN from the phase speed calculation where h is negative in the halo neighbor of that masked tile. --- src/core/MOM_open_boundary.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index b54c93cefa..76ac477906 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -3919,7 +3919,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%Htot(I,j) = segment%Htot(I,j) + segment%h(I,j,k) segment%dZtot(I,j) = segment%dZtot(I,j) + dz(i+ishift,j,k) enddo - segment%Cg(I,j) = sqrt(GV%g_prime(1) * segment%dZtot(I,j)) + segment%Cg(I,j) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(I,j))) enddo else! (segment%direction == OBC_DIRECTION_N .or. segment%direction == OBC_DIRECTION_S) allocate(normal_trans_bt(segment%HI%isd:segment%HI%ied,segment%HI%JsdB:segment%HI%JedB), source=0.0) @@ -3933,7 +3933,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) segment%Htot(i,J) = segment%Htot(i,J) + segment%h(i,J,k) segment%dZtot(i,J) = segment%dZtot(i,J) + dz(i,j+jshift,k) enddo - segment%Cg(i,J) = sqrt(GV%g_prime(1) * segment%dZtot(i,J)) + segment%Cg(i,J) = sqrt(GV%g_prime(1) * max(0.0, segment%dZtot(i,J))) enddo endif From 5c146680ff820c86e756611ec5b6cf2e26ad4621 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Dec 2023 16:28:48 -0500 Subject: [PATCH 500/629] +FIX_USTAR_GUSTLESS_BUG is now USTAR_GUSTLESS_BUG Renamed the runtime parameter FIX_USTAR_GUSTLESS_BUG to USTAR_GUSTLESS_BUG (with a switch between the meanings of true and false for the two parameters) for consistency with the syntax of other bug-fix flags in MOM6 and to partially address dev/gfdl MOM6 issue #237. Input parameter files need not be changed right away because MOM6 will still work if FIX_USTAR_GUSTLESS_BUG is specified instead of USTAR_GUSTLESS_BUG, but USTAR_GUSTLESS_BUG will be logged, so there are changes to the MOM_parameter_doc files. By default or with existing input parameter files, all answers are bitwise identical, and there is error handling if inconsistent settings of FIX_USTAR_GUSTLESS_BUG and USTAR_GUSTLESS_BUG are both specified. --- .../FMS_cap/MOM_surface_forcing_gfdl.F90 | 34 +++++++++++++-- .../STALE_mct_cap/mom_surface_forcing_mct.F90 | 41 +++++++++++++++---- .../nuopc_cap/mom_surface_forcing_nuopc.F90 | 41 +++++++++++++++---- .../solo_driver/MOM_surface_forcing.F90 | 39 +++++++++++++++--- 4 files changed, 129 insertions(+), 26 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 fc4d8e79f6..1e56486329 100644 --- a/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 +++ b/config_src/drivers/FMS_cap/MOM_surface_forcing_gfdl.F90 @@ -137,7 +137,7 @@ module MOM_surface_forcing_gfdl !! gustiness calculations. Values below 20190101 recover the answers !! from the end of 2018, while higher values use a simpler expression !! to calculate gustiness. - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. logical :: check_no_land_fluxes !< Return warning if IOB flux over land is non-zero @@ -284,7 +284,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.not.CS%nonBous, press=.true., & - fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=CS%nonBous) + fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=CS%nonBous) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -1298,6 +1298,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) logical :: new_sim ! False if this simulation was started from a restart file ! or other equivalent files. logical :: iceberg_flux_diags ! If true, diagnostics of fluxes from icebergs are available. + logical :: fix_ustar_gustless_bug ! If false, include a bug using an older run-time parameter. + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. type(time_type) :: Time_frc type(directories) :: dirs ! A structure containing relevant directory paths and input filenames. @@ -1611,9 +1614,32 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, wind_stagger) "of 2018, while higher values use a simpler expression to calculate gustiness.", & default=default_answer_date) - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & diff --git a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 index a5c2db6974..bb57810f5b 100644 --- a/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 +++ b/config_src/drivers/STALE_mct_cap/mom_surface_forcing_mct.F90 @@ -16,7 +16,7 @@ module MOM_surface_forcing_mct use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type @@ -117,7 +117,7 @@ module MOM_surface_forcing_mct real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing character(len=200) :: inputdir !< directory where NetCDF input files are @@ -276,7 +276,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & - press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, tau_mag=.true.) + press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, tau_mag=.true.) call safe_alloc_ptr(fluxes%sw_vis_dir,isd,ied,jsd,jed) call safe_alloc_ptr(fluxes%sw_vis_dif,isd,ied,jsd,jed) @@ -1025,11 +1025,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags + logical :: new_sim, iceberg_flux_diags, fix_ustar_gustless_bug + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. type(time_type) :: Time_frc character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing_mct" ! This module's name. character(len=48) :: stagger character(len=48) :: flnam @@ -1257,9 +1259,32 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & 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 d699697140..e7d6c9abc6 100644 --- a/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 +++ b/config_src/drivers/nuopc_cap/mom_surface_forcing_nuopc.F90 @@ -17,7 +17,7 @@ module MOM_surface_forcing_nuopc use MOM_domains, only : AGRID, BGRID_NE, CGRID_NE, To_All use MOM_domains, only : To_North, To_East, Omit_Corners use MOM_error_handler, only : MOM_error, WARNING, FATAL, is_root_pe, MOM_mesg -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : forcing_diags, mech_forcing_diags, register_forcing_type_diags use MOM_forcing_type, only : allocate_forcing_type, deallocate_forcing_type @@ -124,7 +124,7 @@ module MOM_surface_forcing_nuopc real :: max_delta_srestore !< maximum delta salinity used for restoring [S ~> ppt] real :: max_delta_trestore !< maximum delta sst used for restoring [C ~> degC] real, pointer, dimension(:,:) :: basin_mask => NULL() !< mask for SSS restoring by basin - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the !! gustless wind friction velocity. type(diag_ctrl), pointer :: diag !< structure to regulate diagnostic output timing @@ -296,7 +296,7 @@ subroutine convert_IOB_to_fluxes(IOB, fluxes, index_bounds, Time, valid_time, G, ! flux type has been used. if (fluxes%dt_buoy_accum < 0) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., ustar=.true., & - press=.true., fix_accum_bug=CS%fix_ustar_gustless_bug, & + press=.true., fix_accum_bug=.not.CS%ustar_gustless_bug, & cfc=CS%use_CFC, hevap=CS%enthalpy_cpl, tau_mag=.true.) !call safe_alloc_ptr(fluxes%omega_w2x,isd,ied,jsd,jed) @@ -1103,11 +1103,13 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, ! Local variables real :: utide ! The RMS tidal velocity [Z T-1 ~> m s-1]. type(directories) :: dirs - logical :: new_sim, iceberg_flux_diags + logical :: new_sim, iceberg_flux_diags, fix_ustar_gustless_bug + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. type(time_type) :: Time_frc character(len=200) :: TideAmp_file, gust_file, salt_file, temp_file ! Input file names. -! This include declares and sets the variable "version". -#include "version_variable.h" + ! This include declares and sets the variable "version". +# include "version_variable.h" character(len=40) :: mdl = "MOM_surface_forcing_nuopc" ! This module's name. character(len=48) :: stagger character(len=48) :: flnam @@ -1342,9 +1344,32 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, restore_salt, call MOM_read_data(gust_file, 'gustiness', CS%gust, G%domain, timelevel=1, & scale=US%kg_m3_to_R*US%m_s_to_L_T**2*US%L_to_Z) ! units in file should be Pa endif - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) ! See whether sufficiently thick sea ice should be treated as rigid. call get_param(param_file, mdl, "USE_RIGID_SEA_ICE", CS%rigid_sea_ice, & diff --git a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 index 14f861e955..3de43eec85 100644 --- a/config_src/drivers/solo_driver/MOM_surface_forcing.F90 +++ b/config_src/drivers/solo_driver/MOM_surface_forcing.F90 @@ -19,7 +19,7 @@ module MOM_surface_forcing use MOM_domains, only : fill_symmetric_edges, CGRID_NE use MOM_error_handler, only : MOM_error, FATAL, WARNING, MOM_mesg, is_root_pe use MOM_error_handler, only : callTree_enter, callTree_leave -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_string_functions, only : uppercase use MOM_forcing_type, only : forcing, mech_forcing use MOM_forcing_type, only : set_net_mass_forcing, copy_common_forcing_fields @@ -116,8 +116,8 @@ module MOM_surface_forcing !! Dates before 20190101 use original answers. !! Dates after 20190101 use a form of the gyre wind stresses that are !! rotationally invariant and more likely to be the same between compilers. - logical :: fix_ustar_gustless_bug !< If true correct a bug in the time-averaging of the - !! gustless wind friction velocity. + logical :: ustar_gustless_bug !< If true, include a bug in the time-averaging of the + !! gustless wind friction velocity. ! if WIND_CONFIG=='scurves' then use the following to define a piecewise scurve profile real :: scurves_ydata(20) = 90. !< Latitudes of scurve nodes [degreesN] real :: scurves_taux(20) = 0. !< Zonal wind stress values at scurve nodes [R L Z T-2 ~> Pa] @@ -256,7 +256,7 @@ subroutine set_forcing(sfc_state, forces, fluxes, day_start, day_interval, G, US call allocate_mech_forcing(G, forces, stress=.true., ustar=.not.CS%nonBous, press=.true., tau_mag=CS%nonBous) call allocate_forcing_type(G, fluxes, ustar=.not.CS%nonBous, tau_mag=CS%nonBous, & - fix_accum_bug=CS%fix_ustar_gustless_bug) + fix_accum_bug=.not.CS%ustar_gustless_bug) if (trim(CS%buoy_config) /= "NONE") then if ( CS%use_temperature ) then call allocate_forcing_type(G, fluxes, water=.true., heat=.true., press=.true.) @@ -1582,6 +1582,9 @@ subroutine surface_forcing_init(Time, G, US, param_file, diag, CS, tracer_flow_C real :: flux_const_default ! The unscaled value of FLUXCONST [m day-1] logical :: Boussinesq ! If true, this run is fully Boussinesq logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq + logical :: fix_ustar_gustless_bug ! If false, include a bug using an older run-time parameter. + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. character(len=40) :: mdl = "MOM_surface_forcing" ! This module's name. character(len=200) :: filename, gust_file ! The name of the gustiness input file. @@ -1935,9 +1938,33 @@ 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=US%Pa_to_RLZ_T2) - call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", CS%fix_ustar_gustless_bug, & + + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false., do_not_log=.true.) + ! This is used to test whether USTAR_GUSTLESS_BUG is being actively set. + call get_param(param_file, mdl, "USTAR_GUSTLESS_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%ustar_gustless_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", fix_ustar_gustless_bug, & "If true correct a bug in the time-averaging of the gustless wind friction velocity", & - default=.true.) + default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_USTAR_GUSTLESS_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = fix_ustar_gustless_bug .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (fix_ustar_gustless_bug .eqv. CS%ustar_gustless_bug)) then + ! USTAR_GUSTLESS_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "USTAR_GUSTLESS_BUG and FIX_USTAR_GUSTLESS_BUG are both being set "//& + "with inconsistent values. FIX_USTAR_GUSTLESS_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_USTAR_GUSTLESS_BUG is an obsolete parameter. "//& + "Use USTAR_GUSTLESS_BUG instead (noting that it has the opposite sense).") + CS%ustar_gustless_bug = .not.fix_ustar_gustless_bug + endif + call log_param(param_file, mdl, "USTAR_GUSTLESS_BUG", CS%ustar_gustless_bug, & + "If true include a bug in the time-averaging of the gustless wind friction velocity", & + default=.false.) + call get_param(param_file, mdl, "READ_GUST_2D", CS%read_gust_2d, & "If true, use a 2-dimensional gustiness supplied from "//& "an input file", default=.false.) From 7ddc727a2460784ea048e511d66dfa207c0a408e Mon Sep 17 00:00:00 2001 From: alex-huth Date: Mon, 27 Nov 2023 18:15:46 -0500 Subject: [PATCH 501/629] This commit guarantees consistency of the ice sheet code under rotated/flipped input and grids, and under dimensional rescaling to the +/-140 power. Bitwise identical results were achieved under rotation/rescaling using standard 2D test cases such as MISMIP+. Major changes include the following: - Specified order of operations throughout, and modified the implementation of FEM integration, h-point-to-node operations, etc for consistency under rotation (see MOM_ice_shelf_dynamics.F90 subroutines calc_shelf_driving_stress, CG_action, CG_action_subgrid_basal, matrix_diagonal, shelf_advance_front, and interpolate_h_to_b). - Added an ice-shelf version of 'first_direction' and 'alterate_first_direction', allowing users to control the order in which the x- and y-direction ice-shelf advection calls are made. Required for consistency under rotation. - Dimensional rescaling fixes throughout MOM_ice_shelf_initialize.F90, and within MOM_ice_shelf_dynamics.F90 (see subroutines initialize_ice_shelf_dyn, ice_shelf_solve_outer, and calc_shelf_taub) - Rotation/rescaling testing revealed two additional bugs that were subsequently fixed: (1) An index error in the conjugate gradient algorithm (subroutine CG_action) (2) Discretization error for the east/north fluxes in subroutines ice_shelf_advect_thickness_x and ice_shelf_advect_thickness_y. The commit also includes several simple changes for code readability and computational efficiency: - Saved Phi, PhiC, and Phisub in the ice shelf dynamics control structure at the start of each run, rather than reallocating and recalculating these static fields each time they are used. Reshaped the Phisub array for computational efficiency over loops. - Modified the sub-cell grounding scheme so that it is only called for partially-grounded cells that contain the grounding line (i.e. where float_cond(i,j)==1). Added float_cond to the ice dynamics structure for output. - Simplified the option to calculate ice viscosity at 4 quadrature points per cell rather than at cell centers, by adding parameter NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS and reshaping CS%ice_visc accordingly. - Style changes and removal of unused code (e.g. removed subroutine apply_boundary_values and field thickness_bdry_val) --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 1180 ++++++++++---------- src/ice_shelf/MOM_ice_shelf_initialize.F90 | 58 +- 2 files changed, 620 insertions(+), 618 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 312fa43fe9..4bfcc3605c 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -84,12 +84,11 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: t_shelf => NULL() !< Vertically integrated temperature in the ice shelf/stream, !! on corner-points (B grid) [C ~> degC] real, pointer, dimension(:,:) :: tmask => NULL() !< A mask on tracer points that is 1 where there is ice. - real, pointer, dimension(:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), + real, pointer, dimension(:,:,:) :: ice_visc => NULL() !< Glen's law ice viscosity (Pa s), !! in [R L2 T-1 ~> kg m-1 s-1]. - real, pointer, dimension(:,:,:) :: Ee => NULL() !< Glen's effective strain-rate ** (1-n)/(n) + !! at either 1 (cell-centered) or 4 quadrature points per cell real, pointer, dimension(:,:) :: AGlen_visc => NULL() !< Ice-stiffness parameter in Glen's law ice viscosity, !! often in [Pa-3 s-1] if n_Glen is 3. - real, pointer, dimension(:,:) :: thickness_bdry_val => NULL() !< The ice thickness at an inflowing boundary [Z ~> m]. real, pointer, dimension(:,:) :: u_bdry_val => NULL() !< The zonal ice velocity at inflowing boundaries !! [L yr-1 ~> m yr-1] real, pointer, dimension(:,:) :: v_bdry_val => NULL() !< The meridional ice velocity at inflowing boundaries @@ -114,6 +113,14 @@ module MOM_ice_shelf_dynamics real, pointer, dimension(:,:) :: ground_frac => NULL() !< Fraction of the time a cell is "exposed", i.e. the column !! thickness is below a threshold and interacting with the rock [nondim]. When this !! is 1, the ice-shelf is grounded + real, pointer, dimension(:,:) :: float_cond => NULL() !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) + real, pointer, dimension(:,:,:,:) :: Phi => NULL() !< The gradients of bilinear basis elements at Gaussian + !! 4 quadrature points surrounding the cell vertices [L-1 ~> m-1]. + real, pointer, dimension(:,:,:) :: PhiC => NULL() !< The gradients of bilinear basis elements at 1 cell-centered + !! quadrature point per cell [L-1 ~> m-1]. + real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() !< Quadrature structure weights at subgridscale + !! locations for finite element calculations [nondim] integer :: OD_rt_counter = 0 !< A counter of the number of contributions to OD_rt. real :: velocity_update_time_step !< The time interval over which to update the ice shelf velocity @@ -128,6 +135,13 @@ module MOM_ice_shelf_dynamics real :: density_ice !< A typical density of ice [R ~> kg m-3]. logical :: advect_shelf !< If true (default), advect ice shelf and evolve thickness + logical :: alternate_first_direction_IS !< If true, alternate whether the x- or y-direction + !! updates occur first in directionally split parts of the calculation. + integer :: first_direction_IS !< An integer that indicates which direction is + !! to be updated first in directionally split + !! parts of the ice sheet calculation (e.g. advection). + real :: first_dir_restart_IS = -1.0 !< A real copy of CS%first_direction_IS for use in restart files + integer :: visc_qps !< The number of quadrature points per cell (1 or 4) on which to calculate ice viscosity. character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally !! according to Glen's flow law; is constant (for debugging purposes) !! or using observed strain rates and read from a file @@ -150,7 +164,7 @@ module MOM_ice_shelf_dynamics real :: eps_glen_min !< Min. strain rate to avoid infinite Glen's law viscosity, [T-1 ~> s-1]. real :: n_basal_fric !< Exponent in sliding law tau_b = C u^(m_slide) [nondim] logical :: CoulombFriction !< Use Coulomb friction law (Schoof 2005, Gagliardini et al 2007) - real :: CF_MinN !< Minimum Coulomb friction effective pressure [R L2 T-2 ~> Pa] + real :: CF_MinN !< Minimum Coulomb friction effective pressure [Pa] real :: CF_PostPeak !< Coulomb friction post peak exponent [nondim] real :: CF_Max !< Coulomb friction maximum coefficient [nondim] real :: density_ocean_avg !< A typical ocean density [R ~> kg m-3]. This does not affect ocean @@ -202,7 +216,7 @@ module MOM_ice_shelf_dynamics !>@{ Diagnostic handles integer :: id_u_shelf = -1, id_v_shelf = -1, id_t_shelf = -1, & id_taudx_shelf = -1, id_taudy_shelf = -1, id_bed_elev = -1, & - id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, & + id_ground_frac = -1, id_col_thick = -1, id_OD_av = -1, id_float_cond = -1, & id_u_mask = -1, id_v_mask = -1, id_ufb_mask =-1, id_vfb_mask = -1, id_t_mask = -1 !>@} ! ids for outputting intermediate thickness in advection subroutine (debugging) @@ -301,11 +315,28 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) call get_param(param_file, mdl, "MISSING_SHELF_TEMPERATURE", T_shelf_missing, & "An ice shelf temperature to use where there is no ice shelf.",& units="degC", default=-10.0, scale=US%degC_to_C, do_not_log=.true.) + + call get_param(param_file, mdl, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS", CS%visc_qps, & + "Number of ice viscosity quadrature points. Either 1 (cell-centered) for 4", & + units="none", default=1) + if (CS%visc_qps/=1 .and. CS%visc_qps/=4) call MOM_error (FATAL, & + "NUMBER OF ICE_VISCOSITY_QUADRATURE_POINTS must be 1 or 4") + + call get_param(param_file, mdl, "FIRST_DIRECTION_IS", CS%first_direction_IS, & + "An integer that indicates which direction goes first "//& + "in parts of the code that use directionally split "//& + "updates (e.g. advection), with even numbers (or 0) used for x- first "//& + "and odd numbers used for y-first.", default=0) + call get_param(param_file, mdl, "ALTERNATE_FIRST_DIRECTION_IS", CS%alternate_first_direction_IS, & + "If true, after every advection call, alternate whether the x- or y- "//& + "direction advection updates occur first. "//& + "If this is true, FIRST_DIRECTION applies at the start of a new run or if "//& + "the next first direction can not be found in the restart file.", default=.false.) + allocate(CS%u_shelf(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%v_shelf(IsdB:IedB,JsdB:JedB), source=0.0) allocate(CS%t_shelf(isd:ied,jsd:jed), source=T_shelf_missing) ! [C ~> degC] - allocate(CS%ice_visc(isd:ied,jsd:jed), source=0.0) - allocate(CS%Ee(isd:ied,jsd:jed,4), source=0.0) + allocate(CS%ice_visc(isd:ied,jsd:jed,CS%visc_qps), source=0.0) allocate(CS%AGlen_visc(isd:ied,jsd:jed), source=2.261e-25) ! [Pa-3 s-1] allocate(CS%basal_traction(isd:ied,jsd:jed), source=0.0) ! [R L3 T-1 ~> kg s-1] allocate(CS%C_basal_friction(isd:ied,jsd:jed), source=5.0e10) ! [Pa (m-1 s)^n_sliding] @@ -319,6 +350,7 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) allocate(CS%u_face_mask_bdry(IsdB:IedB,JsdB:JedB), source=-2.0) allocate(CS%v_face_mask_bdry(IsdB:iedB,JsdB:JedB), source=-2.0) allocate(CS%h_bdry_val(isd:ied,jsd:jed), source=0.0) + ! additional restarts for ice shelf state call register_restart_field(CS%u_shelf, "u_shelf", .false., restart_CS, & "ice sheet/shelf u-velocity", & @@ -349,6 +381,8 @@ subroutine register_ice_shelf_dyn_restarts(G, US, param_file, CS, restart_CS) "ice thickness at the boundary", "m", conversion=US%Z_to_m) call register_restart_field(CS%bed_elev, "bed elevation", .true., restart_CS, & "bed elevation", "m", conversion=US%Z_to_m) + call register_restart_field(CS%first_dir_restart_IS, "first_direction_IS", .false., restart_CS, & + "Indicator of the first direction in split ice shelf calculations.", "nondim") endif end subroutine register_ice_shelf_dyn_restarts @@ -466,7 +500,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ units="none", default=.false., fail_if_missing=.false.) call get_param(param_file, mdl, "CF_MinN", CS%CF_MinN, & "Minimum Coulomb friction effective pressure", & - units="Pa", default=1.0, scale=US%Pa_to_RL2_T2, fail_if_missing=.false.) + units="Pa", default=1.0, fail_if_missing=.false.) call get_param(param_file, mdl, "CF_PostPeak", CS%CF_PostPeak, & "Coulomb friction post peak exponent", & units="none", default=1.0, fail_if_missing=.false.) @@ -500,11 +534,14 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ "If true, advect ice shelf and evolve thickness", & default=.true.) call get_param(param_file, mdl, "ICE_VISCOSITY_COMPUTE", CS%ice_viscosity_compute, & - "If MODEL, compute ice viscosity internally at cell centers, if OBS read from a file,"//& - "If MODEL_QUADRATURE, compute at quadrature points (4 per element),"//& + "If MODEL, compute ice viscosity internally using 1 or 4 quadrature points,"//& + "if OBS read from a file,"//& "if CONSTANT a constant value (for debugging).", & default="MODEL") + if ((CS%visc_qps/=1) .and. (trim(CS%ice_viscosity_compute) /= "MODEL")) then + call MOM_error(FATAL, "NUMBER_OF_ICE_VISCOSITY_QUADRATURE_POINTS must be 1 unless ICE_VISCOSITY_COMPUTE==MODEL.") + endif call get_param(param_file, mdl, "INFLOW_SHELF_TEMPERATURE", T_shelf_bdry, & "A default ice shelf temperature to use for ice flowing in through "//& "open boundaries.", units="degC", default=-15.0, scale=US%degC_to_C) @@ -558,7 +595,6 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ if (active_shelf_dynamics) then allocate( CS%t_bdry_val(isd:ied,jsd:jed), source=T_shelf_bdry) ! [C ~> degC] - allocate( CS%thickness_bdry_val(isd:ied,jsd:jed), source=0.0) allocate( CS%u_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) allocate( CS%v_face_mask(Isdq:Iedq,Jsdq:Jedq), source=0.0) allocate( CS%u_flux_bdry_val(Isdq:Iedq,jsd:jed), source=0.0) @@ -566,6 +602,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ allocate( CS%umask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) allocate( CS%vmask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) allocate( CS%tmask(Isdq:Iedq,Jsdq:Jedq), source=-1.0) + allocate( CS%float_cond(isd:ied,jsd:jed)) CS%OD_rt_counter = 0 allocate( CS%OD_rt(isd:ied,jsd:jed), source=0.0) @@ -575,6 +612,24 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ allocate( CS%calve_mask(isd:ied,jsd:jed), source=0.0) endif + allocate(CS%Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) + do j=G%jsd,G%jed ; do i=G%isd,G%ied + call bilinear_shape_fn_grid(G, i, j, CS%Phi(:,:,i,j)) + enddo; enddo + + if (CS%GL_regularize) then + allocate(CS%Phisub(2,2,CS%n_sub_regularize,CS%n_sub_regularize,2,2), source=0.0) + call bilinear_shape_functions_subgrid(CS%Phisub, CS%n_sub_regularize) + endif + + if ((trim(CS%ice_viscosity_compute) == "MODEL") .and. CS%visc_qps==1) then + !for calculating viscosity and 1 cell-centered quadrature point per cell + allocate(CS%PhiC(1:8,G%isc:G%iec,G%jsc:G%jec), source=0.0) + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call bilinear_shape_fn_grid_1qp(G, i, j, CS%PhiC(:,i,j)) + enddo; enddo + endif + CS%elapsed_velocity_time = 0.0 call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) @@ -622,15 +677,13 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif call pass_var(CS%OD_av,G%domain, complete=.false.) - call pass_var(CS%ground_frac,G%domain, complete=.false.) - call pass_var(CS%ice_visc,G%domain, complete=.false.) + call pass_var(CS%ground_frac, G%domain, complete=.false.) call pass_var(CS%basal_traction, G%domain, complete=.false.) call pass_var(CS%AGlen_visc, G%domain, complete=.false.) call pass_var(CS%bed_elev, G%domain, complete=.false.) call pass_var(CS%C_basal_friction, G%domain, complete=.false.) - call pass_var(CS%h_bdry_val, G%domain, complete=.false.) - call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) + call pass_var(CS%ice_visc, G%domain) call pass_vector(CS%u_shelf, CS%v_shelf, G%domain, TO_ALL, BGRID_NE, complete=.false.) call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) @@ -639,6 +692,12 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ endif if (active_shelf_dynamics) then + if (CS%first_dir_restart_IS > -1.0) then + CS%first_direction_IS = modulo(NINT(CS%first_dir_restart_IS), 2) + else + CS%first_dir_restart_IS = real(modulo(CS%first_direction_IS, 2)) + endif + ! If we are calving to a mask, i.e. if a mask exists where a shelf cannot, read the mask from a file. if (CS%calve_to_mask) then call MOM_mesg(" MOM_ice_shelf.F90, initialize_ice_shelf: reading calving_mask") @@ -670,16 +729,15 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ call pass_var(CS%C_basal_friction, G%domain, complete=.false.) ! initialize ice-stiffness AGlen - call initialize_ice_AGlen(CS%AGlen_visc, G, US, param_file) + call initialize_ice_AGlen(CS%AGlen_visc, CS%ice_viscosity_compute, G, US, param_file) call pass_var(CS%AGlen_visc, G%domain, complete=.false.) !initialize boundary conditions call initialize_ice_shelf_boundary_from_file(CS%u_face_mask_bdry, CS%v_face_mask_bdry, & CS%u_bdry_val, CS%v_bdry_val, CS%umask, CS%vmask, CS%h_bdry_val, & - CS%thickness_bdry_val, ISS%hmask, ISS%h_shelf, G, US, param_file ) + ISS%hmask, ISS%h_shelf, G, US, param_file ) call pass_var(ISS%hmask, G%domain, complete=.false.) - call pass_var(CS%h_bdry_val, G%domain, complete=.false.) - call pass_var(CS%thickness_bdry_val, G%domain, complete=.true.) + call pass_var(CS%h_bdry_val, G%domain, complete=.true.) call pass_vector(CS%u_bdry_val, CS%v_bdry_val, G%domain, TO_ALL, BGRID_NE, complete=.false.) call pass_vector(CS%u_face_mask_bdry, CS%v_face_mask_bdry, G%domain, TO_ALL, BGRID_NE, complete=.false.) @@ -696,17 +754,18 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ 'x-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) CS%id_v_shelf = register_diag_field('ice_shelf_model','v_shelf',CS%diag%axesB1, Time, & 'y-velocity of ice', 'm yr-1', conversion=365.0*86400.0*US%L_T_to_m_s) - ! I think that the conversion factors for the next two diagnostics are wrong. - RWH CS%id_taudx_shelf = register_diag_field('ice_shelf_model','taudx_shelf',CS%diag%axesB1, Time, & - 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RL2_T2_to_Pa) + 'x-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_taudy_shelf = register_diag_field('ice_shelf_model','taudy_shelf',CS%diag%axesB1, Time, & - 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RL2_T2_to_Pa) + 'y-driving stress of ice', 'kPa', conversion=1.e-3*US%RLZ_T2_to_Pa) CS%id_u_mask = register_diag_field('ice_shelf_model','u_mask',CS%diag%axesB1, Time, & 'mask for u-nodes', 'none') CS%id_v_mask = register_diag_field('ice_shelf_model','v_mask',CS%diag%axesB1, Time, & 'mask for v-nodes', 'none') CS%id_ground_frac = register_diag_field('ice_shelf_model','ice_ground_frac',CS%diag%axesT1, Time, & 'fraction of cell that is grounded', 'none') + CS%id_float_cond = register_diag_field('ice_shelf_model','float_cond',CS%diag%axesT1, Time, & + 'sub-cell grounding cells', 'none') CS%id_col_thick = register_diag_field('ice_shelf_model','col_thick',CS%diag%axesT1, Time, & 'ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) CS%id_visc_shelf = register_diag_field('ice_shelf_model','ice_visc',CS%diag%axesT1, Time, & @@ -716,7 +775,7 @@ subroutine initialize_ice_shelf_dyn(param_file, Time, ISS, CS, G, US, diag, new_ CS%id_OD_av = register_diag_field('ice_shelf_model','OD_av',CS%diag%axesT1, Time, & 'intermediate ocean column thickness passed to ice model', 'm', conversion=US%Z_to_m) endif - call MOM_mesg("MOM_ice_shelf.F90, initialize_ice_shelf: initialize ice velocity.") + if (new_sim) then call update_OD_ffrac_uncoupled(CS, G, ISS%h_shelf(:,:)) endif @@ -821,6 +880,10 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled ! if (CS%advect_shelf) then call ice_shelf_advect(CS, ISS, G, time_step, Time) + if (CS%alternate_first_direction_IS) then + CS%first_direction_IS = modulo(CS%first_direction_IS+1,2) + CS%first_dir_restart_IS = real(CS%first_direction_IS) + endif endif CS%elapsed_velocity_time = CS%elapsed_velocity_time + time_step if (CS%elapsed_velocity_time >= CS%velocity_update_time_step) update_ice_vel = .true. @@ -832,7 +895,6 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled CS%GL_couple=.false. endif - if (update_ice_vel) then call ice_shelf_solve_outer(CS, ISS, G, US, CS%u_shelf, CS%v_shelf,CS%taudx_shelf,CS%taudy_shelf, iters, Time) endif @@ -854,12 +916,14 @@ subroutine update_ice_shelf(CS, ISS, G, US, time_step, Time, ocean_mass, coupled call post_data(CS%id_taudy_shelf, taud_y, CS%diag) endif if (CS%id_ground_frac > 0) call post_data(CS%id_ground_frac, CS%ground_frac, CS%diag) + if (CS%id_float_cond > 0) call post_data(CS%id_float_cond, CS%float_cond, CS%diag) if (CS%id_OD_av >0) call post_data(CS%id_OD_av, CS%OD_av,CS%diag) if (CS%id_visc_shelf > 0) then - ice_visc(:,:) = CS%ice_visc(:,:)*G%IareaT(:,:) - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then - ice_visc(:,:) = ice_visc(:,:) * & - 0.25 * (CS%Ee(:,:,1) + CS%Ee(:,:,2) + CS%Ee(:,:,3) + CS%Ee(:,:,4)) + if (CS%visc_qps==4) then + ice_visc(:,:) = (0.25 * G%IareaT(:,:)) * & + ((CS%ice_visc(:,:,1) + CS%ice_visc(:,:,4)) + (CS%ice_visc(:,:,2) + CS%ice_visc(:,:,3))) + else + ice_visc(:,:) = CS%ice_visc(:,:,1)*G%IareaT(:,:) endif call post_data(CS%id_visc_shelf, ice_visc, CS%diag) endif @@ -945,11 +1009,11 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) !calculate KE using cell-centered ice shelf velocity tmp1(:,:)=0.0 - KE_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 * US%L_T_to_m_s**2 + KE_scale_factor = US%L_to_m**2 * (US%RZ_to_kg_m2 * US%L_T_to_m_s**2) do j=js,je ; do i=is,ie - tmp1(i,j) = KE_scale_factor * 0.03125 * G%areaT(i,j) * mass(i,j) * & - ((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J-1)+CS%u_shelf(I,J)+CS%u_shelf(I,J-1))**2 + & - (CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J-1)+CS%v_shelf(I,J)+CS%v_shelf(I,J-1))**2) + tmp1(i,j) = (KE_scale_factor * 0.03125) * (G%areaT(i,j) * mass(i,j)) * & + (((CS%u_shelf(I-1,J-1)+CS%u_shelf(I,J))+(CS%u_shelf(I,J-1)+CS%u_shelf(I-1,J)))**2 + & + ((CS%v_shelf(I-1,J-1)+CS%v_shelf(I,J))+(CS%v_shelf(I,J-1)+CS%v_shelf(I-1,J)))**2) enddo; enddo KE_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) @@ -958,7 +1022,7 @@ subroutine write_ice_shelf_energy(CS, G, US, mass, day, time_step) tmp1(:,:)=0.0 mass_scale_factor = US%L_to_m**2 * US%RZ_to_kg_m2 do j=js,je ; do i=is,ie - tmp1(i,j) = mass_scale_factor * mass(i,j) * G%areaT(i,j) + tmp1(i,j) = mass_scale_factor * (mass(i,j) * G%areaT(i,j)) enddo; enddo mass_tot = reproducing_sum(tmp1, isr, ier, jsr, jer) @@ -1034,7 +1098,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) ! The flux overflows are included here. That is because they will be used to advect 3D scalars ! into partial cells - real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_uflux, h_after_vflux ! Ice thicknesses [Z ~> m]. + real, dimension(SZDI_(G),SZDJ_(G)) :: h_after_flux1, h_after_flux2 ! Ice thicknesses [Z ~> m]. real, dimension(SZDIB_(G),SZDJ_(G)) :: uh_ice ! The accumulated zonal ice volume flux [Z L2 ~> m3] real, dimension(SZDI_(G),SZDJB_(G)) :: vh_ice ! The accumulated meridional ice volume flux [Z L2 ~> m3] type(loop_bounds_type) :: LB @@ -1046,37 +1110,39 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) uh_ice(:,:) = 0.0 vh_ice(:,:) = 0.0 - h_after_uflux(:,:) = 0.0 - h_after_vflux(:,:) = 0.0 + h_after_flux1(:,:) = 0.0 + h_after_flux2(:,:) = 0.0 ! call MOM_mesg("MOM_ice_shelf.F90: ice_shelf_advect called") - do j=jsd,jed ; do i=isd,ied ; if (CS%thickness_bdry_val(i,j) /= 0.0) then - ISS%h_shelf(i,j) = CS%thickness_bdry_val(i,j) + do j=jsd,jed ; do i=isd,ied ; if (CS%h_bdry_val(i,j) /= 0.0) then + ISS%h_shelf(i,j) = CS%h_bdry_val(i,j) endif ; enddo ; enddo stencil = 2 - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil - if (LB%jsh < jsd) call MOM_error(FATAL, & - "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") - - call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_uflux, uh_ice) - -! call enable_averages(time_step, Time, CS%diag) - call pass_var(h_after_uflux, G%domain) -! if (CS%id_h_after_uflux > 0) call post_data(CS%id_h_after_uflux, h_after_uflux, CS%diag) -! call disable_averaging(CS%diag) - - LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec - call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_uflux, h_after_vflux, vh_ice) - -! call enable_averages(time_step, Time, CS%diag) - call pass_var(h_after_vflux, G%domain) -! if (CS%id_h_after_vflux > 0) call post_data(CS%id_h_after_vflux, h_after_vflux, CS%diag) -! call disable_averaging(CS%diag) + if (modulo(CS%first_direction_IS,2)==0) then + !x first + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc-stencil ; LB%jeh = G%jec+stencil + if (LB%jsh < jsd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_flux1, uh_ice) + call pass_var(h_after_flux1, G%domain) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, h_after_flux1, h_after_flux2, vh_ice) + else + ! y first + LB%ish = G%isc-stencil ; LB%ieh = G%iec+stencil ; LB%jsh = G%jsc ; LB%jeh = G%jec + if (LB%ish < isd) call MOM_error(FATAL, & + "ice_shelf_advect: Halo is too small for the ice thickness advection stencil.") + call ice_shelf_advect_thickness_y(CS, G, LB, time_step, ISS%hmask, ISS%h_shelf, h_after_flux1, vh_ice) + call pass_var(h_after_flux1, G%domain) + LB%ish = G%isc ; LB%ieh = G%iec ; LB%jsh = G%jsc ; LB%jeh = G%jec + call ice_shelf_advect_thickness_x(CS, G, LB, time_step, ISS%hmask, h_after_flux1, h_after_flux2, uh_ice) + endif + call pass_var(h_after_flux2, G%domain) do j=jsd,jed do i=isd,ied - if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_vflux(i,j) + if (ISS%hmask(i,j) == 1) ISS%h_shelf(i,j) = h_after_flux2(i,j) enddo enddo @@ -1092,7 +1158,7 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) endif do j=jsc,jec; do i=isc,iec - ISS%mass_shelf(i,j) = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) * G%IareaT(i,j) * CS%density_ice + ISS%mass_shelf(i,j) = (ISS%h_shelf(i,j) * CS%density_ice) * (ISS%area_shelf_h(i,j) * G%IareaT(i,j)) enddo; enddo call pass_var(ISS%mass_shelf, G%domain, complete=.false.) @@ -1100,12 +1166,6 @@ subroutine ice_shelf_advect(CS, ISS, G, time_step, Time) call pass_var(ISS%area_shelf_h, G%domain, complete=.false.) call pass_var(ISS%hmask, G%domain, complete=.true.) - !call enable_averages(time_step, Time, CS%diag) - !if (CS%id_h_after_adv > 0) call post_data(CS%id_h_after_adv, ISS%h_shelf, CS%diag) - !call disable_averaging(CS%diag) - - !call change_thickness_using_melt(ISS, G, time_step, fluxes, CS%density_ice) - call update_velocity_masks(CS, G, ISS%hmask, CS%umask, CS%vmask, CS%u_face_mask, CS%v_face_mask) end subroutine ice_shelf_advect @@ -1134,40 +1194,30 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i real, dimension(SZDIB_(G),SZDJB_(G)) :: Au, Av ! The retarding lateral stress contributions [R L3 Z T-2 ~> kg m s-2] real, dimension(SZDIB_(G),SZDJB_(G)) :: u_last, v_last ! Previous velocities [L T-1 ~> m s-1] real, dimension(SZDIB_(G),SZDJB_(G)) :: H_node ! Ice shelf thickness at corners [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, an array indicating where the ice - ! shelf is floating: 0 if floating, 1 if not + real, dimension(SZDI_(G),SZDJ_(G)) :: float_cond ! If GL_regularize=true, indicates cells containing + ! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDIB_(G),SZDJB_(G)) :: Normvec ! Used for convergence character(len=160) :: mesg ! The text of an error message integer :: conv_flag, i, j, k,l, iter - integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat, nsub + integer :: isdq, iedq, jsdq, jedq, isd, ied, jsd, jed, nodefloat real :: err_max, err_tempu, err_tempv, err_init, max_vel, tempu, tempv, Norm, PrevNorm real :: rhoi_rhow ! The density of ice divided by a typical water density [nondim] - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. - real, pointer, dimension(:,:,:,:,:,:) :: Phisub => NULL() ! Quadrature structure weights at subgridscale - ! locations for finite element calculations [nondim] integer :: Is_sum, Js_sum, Ie_sum, Je_sum ! Loop bounds for global sums or arrays starting at 1. - ! for GL interpolation - nsub = CS%n_sub_regularize - isdq = G%isdB ; iedq = G%iedB ; jsdq = G%jsdB ; jedq = G%jedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed rhoi_rhow = CS%density_ice / CS%density_ocean_avg taudx(:,:) = 0.0 ; taudy(:,:) = 0.0 - !u_bdry_cont(:,:) = 0.0 ; v_bdry_cont(:,:) = 0.0 Au(:,:) = 0.0 ; Av(:,:) = 0.0 ! need to make these conditional on GL interpolation - float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 + CS%float_cond(:,:) = 0.0 ; H_node(:,:) = 0.0 !CS%ground_frac(:,:) = 0.0 - allocate(Phisub(nsub,nsub,2,2,2,2), source=0.0) if (.not. CS%GL_couple) then do j=G%jsc,G%jec ; do i=G%isc,G%iec if (rhoi_rhow * ISS%h_shelf(i,j) - CS%bed_elev(i,j) > 0) then - if (CS%GL_regularize) float_cond(i,j) = 1.0 CS%ground_frac(i,j) = 1.0 CS%OD_av(i,j) =0.0 endif @@ -1197,34 +1247,24 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i endif enddo ; enddo if ((nodefloat > 0) .and. (nodefloat < 4)) then - float_cond(i,j) = 1.0 + CS%float_cond(i,j) = 1.0 CS%ground_frac(i,j) = 1.0 endif enddo ; enddo - call pass_var(float_cond, G%Domain, complete=.false.) - - call bilinear_shape_functions_subgrid(Phisub, nsub) + call pass_var(CS%float_cond, G%Domain, complete=.false.) endif - ! must prepare Phi - allocate(Phi(1:8,1:4,isd:ied,jsd:jed), source=0.0) - - do j=jsd,jed ; do i=isd,ied - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo ; enddo - - call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain, complete=.true.) - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%ice_visc, G%domain) ! This makes sure basal stress is only applied when it is supposed to be if (CS%GL_regularize) then do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 enddo ; enddo else do j=G%jsd,G%jed ; do i=G%isd,G%ied @@ -1233,25 +1273,21 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i endif if (CS%nonlin_solve_err_mode == 1) then - ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0.0 ; Av(:,:) = 0.0 - call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) err_init = 0 ; err_tempu = 0 ; err_tempv = 0 do J=G%IscB,G%JecB ; do I=G%IscB,G%IecB if (CS%umask(I,J) == 1) then - !err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_init) err_init = err_tempu endif if (CS%vmask(I,J) == 1) then - !err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_init) err_init = err_tempv endif @@ -1271,8 +1307,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB - if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)*u_shlf(I,J) - if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)*v_shlf(I,J) + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) enddo; enddo Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) Norm = sqrt(Norm) @@ -1284,8 +1320,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i do iter=1,50 - call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, float_cond, & - ISS%hmask, conv_flag, iters, time, Phi, Phisub) + call ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H_node, CS%float_cond, & + ISS%hmask, conv_flag, iters, time, CS%Phi, CS%Phisub) if (CS%debug) then call qchksum(u_shlf, "u shelf", G%HI, haloshift=2, scale=US%L_T_to_m_s) @@ -1295,16 +1331,15 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i write(mesg,*) "ice_shelf_solve_outer: linear solve done in ",iters," iterations" call MOM_mesg(mesg, 5) - call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) - call pass_var(CS%ice_visc, G%domain, complete=.false.) call calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) call pass_var(CS%basal_traction, G%domain, complete=.true.) - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") call pass_var(CS%Ee,G%domain) + call calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) + call pass_var(CS%ice_visc, G%domain) ! makes sure basal stress is only applied when it is supposed to be if (CS%GL_regularize) then do j=G%jsd,G%jed ; do i=G%isd,G%ied - CS%basal_traction(i,j) = CS%basal_traction(i,j) * float_cond(i,j) + if (CS%ground_frac(i,j)/=1.0) CS%basal_traction(i,j) = 0.0 enddo ; enddo else do j=G%jsd,G%jed ; do i=G%isd,G%ied @@ -1313,15 +1348,11 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i endif if (CS%nonlin_solve_err_mode == 1) then - !u_bdry_cont(:,:) = 0 ; v_bdry_cont(:,:) = 0 - - ! call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - ! CS%basal_traction, float_cond, rhoi_rhow, u_bdry_cont, v_bdry_cont) Au(:,:) = 0 ; Av(:,:) = 0 - call CG_action(CS, Au, Av, u_shlf, v_shlf, Phi, Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & - CS%ice_visc, float_cond, CS%bed_elev, CS%basal_traction, & + call CG_action(CS, Au, Av, u_shlf, v_shlf, CS%Phi, CS%Phisub, CS%umask, CS%vmask, ISS%hmask, H_node, & + CS%ice_visc, CS%float_cond, CS%bed_elev, CS%basal_traction, & G, US, G%isc-1, G%iec+1, G%jsc-1, G%jec+1, rhoi_rhow) call pass_vector(Au, Av, G%domain, TO_ALL, BGRID_NE) @@ -1330,12 +1361,10 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i do J=G%jscB,G%jecB ; do I=G%jscB,G%iecB if (CS%umask(I,J) == 1) then - !err_tempu = ABS(Au(I,J) + u_bdry_cont(I,J) - taudx(I,J)) err_tempu = ABS(Au(I,J) - taudx(I,J)) if (err_tempu >= err_max) err_max = err_tempu endif if (CS%vmask(I,J) == 1) then - !err_tempv = ABS(Av(I,J) + v_bdry_cont(I,J) - taudy(I,J)) err_tempv = ABS(Av(I,J) - taudy(I,J)) if (err_tempv >= err_max) err_max = err_tempv endif @@ -1372,8 +1401,8 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i elseif (CS%nonlin_solve_err_mode == 3) then PrevNorm=Norm; Norm=0.0; Normvec=0.0 do J=G%jscB,G%jecB ; do I=G%iscB,G%iecB - if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + u_shlf(I,J)*u_shlf(I,J) - if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + v_shlf(I,J)*v_shlf(I,J) + if (CS%umask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (u_shlf(I,J)**2 * US%L_T_to_m_s**2) + if (CS%vmask(I,J) == 1) Normvec(I,J) = Normvec(I,J) + (v_shlf(I,J)**2 * US%L_T_to_m_s**2) enddo; enddo Norm = reproducing_sum( Normvec, Is_sum, Ie_sum, Js_sum, Je_sum ) Norm = sqrt(Norm) @@ -1393,8 +1422,6 @@ subroutine ice_shelf_solve_outer(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, i call MOM_mesg(mesg) write(mesg,*) "ice_shelf_solve_outer: exiting nonlinear solve after ",iter," iterations" call MOM_mesg(mesg) - deallocate(Phi) - deallocate(Phisub) end subroutine ice_shelf_solve_outer @@ -1417,8 +1444,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H intent(in) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf @@ -1473,7 +1500,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Zu(:,:) = 0 ; Zv(:,:) = 0 ; DIAGu(:,:) = 0 ; DIAGv(:,:) = 0 Ru(:,:) = 0 ; Rv(:,:) = 0 ; Au(:,:) = 0 ; Av(:,:) = 0 ; RHSu(:,:) = 0 ; RHSv(:,:) = 0 - Du(:,:) = 0 ; Dv(:,:) = 0 !; ubd(:,:) = 0 ; vbd(:,:) = 0 + Du(:,:) = 0 ; Dv(:,:) = 0 dot_p1 = 0 ! Determine the loop limits for sums, bearing in mind that the arrays will be starting at 1. @@ -1487,16 +1514,13 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H ! Include the edge if tile is at the southern bdry; Should add a test to avoid this if reentrant. if (G%jsc+G%jdg_offset==G%jsg) Js_sum = G%JscB + (1-G%JsdB) - !call apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, CS%ice_visc, & - ! CS%basal_traction, float_cond, rhoi_rhow, ubd, vbd) - - RHSu(:,:) = taudx(:,:) !- ubd(:,:) - RHSv(:,:) = taudy(:,:) !- vbd(:,:) + RHSu(:,:) = taudx(:,:) + RHSv(:,:) = taudy(:,:) call pass_vector(RHSu, RHSv, G%domain, TO_ALL, BGRID_NE, complete=.false.) call matrix_diagonal(CS, G, US, float_cond, H_node, CS%ice_visc, CS%basal_traction, & - hmask, rhoi_rhow, Phisub, DIAGu, DIAGv) + hmask, rhoi_rhow, Phi, Phisub, DIAGu, DIAGv) call pass_vector(DIAGu, DIAGv, G%domain, TO_ALL, BGRID_NE, complete=.false.) @@ -1508,9 +1532,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H Ru(:,:) = (RHSu(:,:) - Au(:,:)) Rv(:,:) = (RHSv(:,:) - Av(:,:)) - - resid_scale = US%L_to_m**2*US%s_to_T*US%RZ_to_kg_m2*US%L_T_to_m_s**2 - resid2_scale = (US%RZ_to_kg_m2*US%L_to_m*US%L_T_to_m_s**2)**2 + resid_scale = (US%L_to_m**2*US%s_to_T)*(US%RZ_to_kg_m2*US%L_T_to_m_s**2) + resid2_scale = ((US%RZ_to_kg_m2*US%L_to_m)*US%L_T_to_m_s**2)**2 sum_vec(:,:) = 0.0 do j=jscq,jecq ; do i=iscq,iecq @@ -1518,7 +1541,7 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H if (CS%vmask(I,J) == 1) sum_vec(I,J) = sum_vec(I,J) + resid2_scale*Rv(I,J)**2 enddo ; enddo - dot_p1 = reproducing_sum( sum_vec, Js_sum, Ie_sum, Js_sum, Je_sum ) + dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) resid0 = sqrt(dot_p1) @@ -1654,7 +1677,8 @@ subroutine ice_shelf_solve_inner(CS, ISS, G, US, u_shlf, v_shlf, taudx, taudy, H dot_p1 = reproducing_sum( sum_vec, Is_sum, Ie_sum, Js_sum, Je_sum ) dot_p1 = sqrt(dot_p1) - if (dot_p1 <= CS%cg_tolerance * resid0) then + + if (dot_p1 <= (CS%cg_tolerance * resid0)) then iters = iter conv_flag = 1 exit @@ -1732,37 +1756,39 @@ subroutine ice_shelf_advect_thickness_x(CS, G, LB, time_step, hmask, h0, h_after do j=jsh,jeh ; do I=ish-1,ieh if (CS%u_face_mask(I,j) == 4.) then ! The flux itself is a specified boundary condition. - uh_ice(I,j) = time_step * G%dyCu(I,j) * CS%u_flux_bdry_val(I,j) + uh_ice(I,j) = (time_step * G%dyCu(I,j)) * CS%u_flux_bdry_val(I,j) elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then u_face = 0.5 * (CS%u_shelf(I,J-1) + CS%u_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. if (u_face > 0) then if (hmask(i,j) == 3) then ! This is a open boundary inflow from the west - h_face = CS%thickness_bdry_val(i,j) + h_face = CS%h_bdry_val(i,j) elseif (hmask(i,j) == 1) then ! There can be eastward flow through this face. - if ((hmask(i-1,j) == 1) .and. (hmask(i+1,j) == 1)) then + if ((hmask(i-1,j) == 1 .or. hmask(i-1,j) == 3) .and. & + (hmask(i+1,j) == 1 .or. hmask(i+1,j) == 3)) then slope_lim = slope_limiter(h0(i,j)-h0(i-1,j), h0(i+1,j)-h0(i,j)) ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. - h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i+1,j)) + h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i+1,j))) else h_face = h0(i,j) endif endif else if (hmask(i+1,j) == 3) then ! This is a open boundary inflow from the east - h_face = CS%thickness_bdry_val(i+1,j) + h_face = CS%h_bdry_val(i+1,j) elseif (hmask(i+1,j) == 1) then - if ((hmask(i,j) == 1) .and. (hmask(i+2,j) == 1)) then + if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. & + (hmask(i+2,j) == 1 .or. hmask(i+2,j) == 3)) then slope_lim = slope_limiter(h0(i+1,j)-h0(i,j), h0(i+2,j)-h0(i+1,j)) - h_face = h0(i+1,j) - slope_lim * 0.5 * (h0(i+1,j)-h0(i,j)) + h_face = h0(i+1,j) - slope_lim * (0.5 * (h0(i+2,j)-h0(i+1,j))) else h_face = h0(i+1,j) endif endif endif - uh_ice(I,j) = time_step * G%dyCu(I,j) * u_face * h_face + uh_ice(I,j) = (time_step * G%dyCu(I,j)) * (u_face * h_face) else uh_ice(I,j) = 0.0 endif @@ -1811,37 +1837,39 @@ subroutine ice_shelf_advect_thickness_y(CS, G, LB, time_step, hmask, h0, h_after do J=jsh-1,jeh ; do i=ish,ieh if (CS%v_face_mask(i,J) == 4.) then ! The flux itself is a specified boundary condition. - vh_ice(i,J) = time_step * G%dxCv(i,J) * CS%v_flux_bdry_val(i,J) + vh_ice(i,J) = (time_step * G%dxCv(i,J)) * CS%v_flux_bdry_val(i,J) elseif ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .or. (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then v_face = 0.5 * (CS%v_shelf(I-1,J) + CS%v_shelf(I,J)) h_face = 0.0 ! This will apply when the source cell is iceless or not fully ice covered. if (v_face > 0) then if (hmask(i,j) == 3) then ! This is a open boundary inflow from the south - h_face = CS%thickness_bdry_val(i,j) - elseif (hmask(i,j) == 1) then ! There can be northtward flow through this face. - if ((hmask(i,j-1) == 1) .and. (hmask(i,j+1) == 1)) then + h_face = CS%h_bdry_val(i,j) + elseif (hmask(i,j) == 1) then ! There can be northward flow through this face. + if ((hmask(i,j-1) == 1 .or. hmask(i,j-1) == 3) .and. & + (hmask(i,j+1) == 1 .or. hmask(i,j+1) == 3)) then slope_lim = slope_limiter(h0(i,j)-h0(i,j-1), h0(i,j+1)-h0(i,j)) ! This is a 2nd-order centered scheme with a slope limiter. We could try PPM here. - h_face = h0(i,j) - slope_lim * 0.5 * (h0(i,j)-h0(i,j+1)) + h_face = h0(i,j) - slope_lim * (0.5 * (h0(i,j)-h0(i,j+1))) else h_face = h0(i,j) endif endif else if (hmask(i,j+1) == 3) then ! This is a open boundary inflow from the north - h_face = CS%thickness_bdry_val(i,j+1) + h_face = CS%h_bdry_val(i,j+1) elseif (hmask(i,j+1) == 1) then - if ((hmask(i,j) == 1) .and. (hmask(i,j+2) == 1)) then + if ((hmask(i,j) == 1 .or. hmask(i,j) == 3) .and. & + (hmask(i,j+2) == 1 .or. hmask(i,j+2) == 3)) then slope_lim = slope_limiter(h0(i,j+1)-h0(i,j), h0(i,j+2)-h0(i,j+1)) - h_face = h0(i,j+1) - slope_lim * 0.5 * (h0(i,j+1)-h0(i,j)) + h_face = h0(i,j+1) - slope_lim * (0.5 * (h0(i,j+2)-h0(i,j+1))) else h_face = h0(i,j+1) endif endif endif - vh_ice(i,J) = time_step * G%dxCv(i,J) * v_face * h_face + vh_ice(i,J) = (time_step * G%dxCv(i,J)) * (v_face * h_face) else vh_ice(i,J) = 0.0 endif @@ -1902,7 +1930,11 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) integer :: iter_flag real :: h_reference ! A reference thicknesss based on neighboring cells [Z ~> m] + real :: h_reference_ew !contribution to reference thickness from east + west cells [Z ~> m] + real :: h_reference_ns !contribution to reference thickness from north + south cells [Z ~> m] real :: tot_flux ! The total ice mass flux [Z L2 ~> m3] + real :: tot_flux_ew ! The contribution to total ice mass flux from east + west cells [Z L2 ~> m3] + real :: tot_flux_ns ! The contribution to total ice mass flux from north + south cells [Z L2 ~> m3] real :: partial_vol ! The volume covered by ice shelf [Z L2 ~> m3] real :: dxdyh ! Cell area [L2 ~> m2] character(len=160) :: mesg ! The text of an error message @@ -1953,15 +1985,17 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ((i+i_off) >= 1)) then ! first get reference thickness by averaging over cells that are fluxing into this cell n_flux = 0 - h_reference = 0.0 - tot_flux = 0.0 + h_reference_ew = 0.0 + h_reference_ns = 0.0 + tot_flux_ew = 0.0 + tot_flux_ns = 0.0 do k=1,2 if (flux_enter(i,j,k) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) + h_reference_ew = h_reference_ew + flux_enter(i,j,k) * ISS%h_shelf(i+2*k-3,j) !h_reference = h_reference + ISS%h_shelf(i+2*k-3,j) - tot_flux = tot_flux + flux_enter(i,j,k) + tot_flux_ew = tot_flux_ew + flux_enter(i,j,k) flux_enter(i,j,k) = 0.0 endif enddo @@ -1969,13 +2003,16 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) do k=1,2 if (flux_enter(i,j,k+2) > 0) then n_flux = n_flux + 1 - h_reference = h_reference + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) + h_reference_ns = h_reference_ns + flux_enter(i,j,k+2) * ISS%h_shelf(i,j+2*k-3) !h_reference = h_reference + ISS%h_shelf(i,j+2*k-3) - tot_flux = tot_flux + flux_enter(i,j,k+2) + tot_flux_ns = tot_flux_ns + flux_enter(i,j,k+2) flux_enter(i,j,k+2) = 0.0 endif enddo + h_reference = h_reference_ew + h_reference_ns + tot_flux = tot_flux_ew + tot_flux_ns + if (n_flux > 0) then dxdyh = G%areaT(i,j) h_reference = h_reference / tot_flux @@ -1983,7 +2020,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) partial_vol = ISS%h_shelf(i,j) * ISS%area_shelf_h(i,j) + tot_flux if ((partial_vol / G%areaT(i,j)) == h_reference) then ! cell is exactly covered, no overflow - if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j)/=3) ISS%hmask(i,j) = 1 ISS%h_shelf(i,j) = h_reference ISS%area_shelf_h(i,j) = G%areaT(i,j) elseif ((partial_vol / G%areaT(i,j)) < h_reference) then @@ -1993,7 +2030,7 @@ subroutine shelf_advance_front(CS, ISS, G, hmask, uh_ice, vh_ice) ISS%h_shelf(i,j) = h_reference else - if (ISS%hmask(i,j).ne.3) ISS%hmask(i,j) = 1 + if (ISS%hmask(i,j)/=3) ISS%hmask(i,j) = 1 ISS%area_shelf_h(i,j) = G%areaT(i,j) !h_temp(i,j) = h_reference partial_vol = partial_vol - h_reference * G%areaT(i,j) @@ -2131,7 +2168,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) ! (it is assumed that base_ice = bed + OD) real, dimension(SIZE(OD,1),SIZE(OD,2)) :: S ! surface elevation [Z ~> m]. - + real, dimension(SZDI_(G),SZDJ_(G)) :: sx_e, sy_e !element contributions to driving stress real :: rho, rhow, rhoi_rhow ! Ice and ocean densities [R ~> kg m-3] real :: sx, sy ! Ice shelf top slopes [Z L-1 ~> nondim] real :: neumann_val ! [R Z L2 T-2 ~> kg s-2] @@ -2143,15 +2180,14 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) integer :: i_off, j_off isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB - isd = G%isd ; jsd = G%jsd +! iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB isd = G%isd ; jsd = G%jsd ; ied = G%ied ; jed = G%jed - iegq = G%iegB ; jegq = G%jegB +! iegq = G%iegB ; jegq = G%jegB ! gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 gisc = 1 ; gjsc = 1 ! giec = G%domain%niglobal+G%domain%nihalo ; gjec = G%domain%njglobal+G%domain%njhalo giec = G%domain%niglobal ; gjec = G%domain%njglobal - is = iscq - 1; js = jscq - 1 +! is = iscq - 1; js = jscq - 1 i_off = G%idg_offset ; j_off = G%jdg_offset @@ -2182,6 +2218,8 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) call pass_var(S, G%domain) + sx_e(:,:)=0.0; sy_e(:,:)=0.0 + do j=jsc-1,jec+1 do i=isc-1,iec+1 cnt = 0 @@ -2210,14 +2248,14 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) else ! interior if (ISS%hmask(i+1,j) == 1 .or. ISS%hmask(i+1,j) == 3) then cnt = cnt+1 - Dx =dxh+ G%dxT(i+1,j) + Dx = dxh + G%dxT(i+1,j) sx = S(i+1,j) else sx = S(i,j) endif if (ISS%hmask(i-1,j) == 1 .or. ISS%hmask(i-1,j) == 3) then cnt = cnt+1 - Dx =dxh+ G%dxT(i-1,j) + Dx = dxh + G%dxT(i-1,j) sx = sx - S(i-1,j) else sx = sx - S(i,j) @@ -2225,7 +2263,7 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) if (cnt == 0) then sx = 0 else - sx = sx / ( Dx) + sx = sx / Dx endif endif @@ -2247,54 +2285,36 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) else ! interior if (ISS%hmask(i,j+1) == 1 .or. ISS%hmask(i,j+1) == 3) then cnt = cnt+1 - Dy =dyh+ G%dyT(i,j+1) + Dy = dyh + G%dyT(i,j+1) sy = S(i,j+1) else sy = S(i,j) endif if (ISS%hmask(i,j-1) == 1 .or. ISS%hmask(i,j-1) == 3) then cnt = cnt+1 + Dy = dyh + G%dyT(i,j-1) sy = sy - S(i,j-1) - Dy =dyh+ G%dyT(i,j-1) else sy = sy - S(i,j) endif if (cnt == 0) then sy = 0 else - sy = sy / (Dy) + sy = sy / Dy endif endif - ! SW vertex - !if (ISS%hmask(I-1,J-1) == 1) then - taudx(I-1,J-1) = taudx(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I-1,J-1) = taudy(I-1,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - !endif - ! SE vertex - !if (ISS%hmask(I,J-1) == 1) then - taudx(I,J-1) = taudx(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I,J-1) = taudy(I,J-1) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - !endif - ! NW vertex - !if (ISS%hmask(I-1,J) == 1) then - taudx(I-1,J) = taudx(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I-1,J) = taudy(I-1,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - !endif - ! NE vertex - !if (ISS%hmask(I,J) == 1) then - taudx(I,J) = taudx(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sx * G%areaT(i,j) - taudy(I,J) = taudy(I,J) - .25 * rho * grav * ISS%h_shelf(i,j) * sy * G%areaT(i,j) - !endif + sx_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sx)) + sy_e(i,j) = (-.25 * G%areaT(i,j)) * ((rho * grav) * (ISS%h_shelf(i,j) * sy)) !Stress (Neumann) boundary conditions if (CS%ground_frac(i,j) == 1) then - neumann_val = (.5 * grav * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) + neumann_val = ((.5 * grav) * (rho * ISS%h_shelf(i,j)**2 - rhow * CS%bed_elev(i,j)**2)) else - neumann_val = (.5 * grav * (1-rho/rhow) * rho * ISS%h_shelf(i,j)**2) + neumann_val = (.5 * grav) * ((1-rho/rhow) * (rho * ISS%h_shelf(i,j)**2)) endif if ((CS%u_face_mask_bdry(I-1,j) == 2) .OR. & - ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off .ne. gisc))) then + ((ISS%hmask(i-1,j) == 0 .OR. ISS%hmask(i-1,j) == 2) .AND. (i+i_off /= gisc))) then ! left face of the cell is at a stress boundary ! the depth-integrated longitudinal stress is equal to the difference of depth-integrated ! pressure on either side of the face @@ -2309,30 +2329,33 @@ subroutine calc_shelf_driving_stress(CS, ISS, G, US, taudx, taudy, OD) endif if ((CS%u_face_mask_bdry(I,j) == 2) .OR. & - ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off .ne. giec))) then + ((ISS%hmask(i+1,j) == 0 .OR. ISS%hmask(i+1,j) == 2) .and. (i+i_off /= giec))) then ! east face of the cell is at a stress boundary taudx(I,J-1) = taudx(I,J-1) + .5 * dyh * neumann_val taudx(I,J) = taudx(I,J) + .5 * dyh * neumann_val endif if ((CS%v_face_mask_bdry(i,J-1) == 2) .OR. & - ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off .ne. gjsc))) then + ((ISS%hmask(i,j-1) == 0 .OR. ISS%hmask(i,j-1) == 2) .and. (j+j_off /= gjsc))) then ! south face of the cell is at a stress boundary taudy(I-1,J-1) = taudy(I-1,J-1) - .5 * dxh * neumann_val taudy(I,J-1) = taudy(I,J-1) - .5 * dxh * neumann_val endif if ((CS%v_face_mask_bdry(i,J) == 2) .OR. & - ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off .ne. gjec))) then + ((ISS%hmask(i,j+1) == 0 .OR. ISS%hmask(i,j+1) == 2) .and. (j+j_off /= gjec))) then ! north face of the cell is at a stress boundary taudy(I-1,J) = taudy(I-1,J) + .5 * dxh * neumann_val taudy(I,J) = taudy(I,J) + .5 * dxh * neumann_val endif - endif enddo enddo + do J=jsc-2,jec+1; do I=isc-2,iec+1 + taudx(I,J) = taudx(I,J) + ((sx_e(i,j)+sx_e(i+1,j+1)) + (sx_e(i+1,j)+sx_e(i,j+1))) + taudy(I,J) = taudy(I,J) + ((sy_e(i,j)+sy_e(i+1,j+1)) + (sy_e(i+1,j)+sy_e(i,j+1))) + enddo; enddo end subroutine calc_shelf_driving_stress ! Not used? Seems to be only set up to work for a specific test case with u_face_mask==3 @@ -2369,7 +2392,7 @@ subroutine init_boundary_values(CS, G, time, hmask, input_flux, input_thick, new do i=isd,ied if (hmask(i,j) == 3) then - CS%thickness_bdry_val(i,j) = input_thick + CS%h_bdry_val(i,j) = input_thick endif if ((hmask(i,j) == 0) .or. (hmask(i,j) == 1) .or. (hmask(i,j) == 2)) then @@ -2436,7 +2459,7 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, real, dimension(SZDI_(G),SZDJ_(G)), & intent(in) :: hmask !< A mask indicating which tracer points are !! partly or fully covered by an ice-shelf - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. @@ -2479,88 +2502,124 @@ subroutine CG_action(CS, uret, vret, u_shlf, v_shlf, Phi, Phisub, umask, vmask, real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt + integer :: iq, jq, iphi, jphi, i, j, ilq, jlq, Itgt, Jtgt, qp, qpv + logical :: visc_qp4 real, dimension(2) :: xquad real, dimension(2,2) :: Ucell, Vcell, Hcell, Usub, Vsub - real :: Ee + real, dimension(2,2,4) :: uret_qp, vret_qp + real, dimension(SZDIB_(G),SZDJB_(G),4) :: uret_b, vret_b xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - Ee=1.0 + if (CS%visc_qps == 4) then + visc_qp4=.true. + else + visc_qp4=.false. + qpv = 1 + endif + + uret(:,:) = 0.0; vret(:,:)=0.0 + uret_b(:,:,:)=0.0 ; vret_b(:,:,:)=0.0 do j=js,je ; do i=is,ie ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then + uret_qp(:,:,:)=0.0; vret_qp(:,:,:)=0.0 + do iq=1,2 ; do jq=1,2 - uq = u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & - u_shlf(I,J) * (xquad(iq) * xquad(jq)) - - vq = v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq)) + & - v_shlf(I,J) * (xquad(iq) * xquad(jq)) - - ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - - vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - - uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - - vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; ;Jtgt = J-2+jphi - if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + 0.25 * Ee * ice_visc(i,j) * & - ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) - if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + 0.25 * Ee * ice_visc(i,j) * & - ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq,i,j) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq,i,j)) + qp = 2*(jq-1)+iq !current quad point + + uq = (u_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + u_shlf(I,J) * (xquad(iq) * xquad(jq))) + & + (u_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + u_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + + vq = (v_shlf(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & + v_shlf(I,J) * (xquad(iq) * xquad(jq))) + & + (v_shlf(I,J-1) * (xquad(iq) * xquad(3-jq)) + & + v_shlf(I-1,J) * (xquad(3-iq) * xquad(jq))) + + ux = (u_shlf(I-1,J-1) * Phi(1,qp,i,j) + & + u_shlf(I,J) * Phi(7,qp,i,j)) + & + (u_shlf(I,J-1) * Phi(3,qp,i,j) + & + u_shlf(I-1,J) * Phi(5,qp,i,j)) + + vx = (v_shlf(I-1,J-1) * Phi(1,qp,i,j) + & + v_shlf(I,J) * Phi(7,qp,i,j)) + & + (v_shlf(I,J-1) * Phi(3,qp,i,j) + & + v_shlf(I-1,J) * Phi(5,qp,i,j)) + + uy = (u_shlf(I-1,J-1) * Phi(2,qp,i,j) + & + u_shlf(I,J) * Phi(8,qp,i,j)) + & + (u_shlf(I,J-1) * Phi(4,qp,i,j) + & + u_shlf(I-1,J) * Phi(6,qp,i,j)) + + vy = (v_shlf(I-1,J-1) * Phi(2,qp,i,j) + & + v_shlf(I,J) * Phi(8,qp,i,j)) + & + (v_shlf(I,J-1) * Phi(4,qp,i,j) + & + v_shlf(I-1,J) * Phi(6,qp,i,j)) + + if (visc_qp4) qpv = qp !current quad point for viscosity + + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & + ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = ice_visc(i,j,qpv) * & + ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) if (float_cond(i,j) == 0) then ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 - if (umask(Itgt,Jtgt) == 1) uret(Itgt,Jtgt) = uret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) - if (vmask(Itgt,Jtgt) == 1) vret(Itgt,Jtgt) = vret(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) + if (umask(Itgt,Jtgt) == 1) uret_qp(iphi,jphi,qp) = uret_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) + if (vmask(Itgt,Jtgt) == 1) vret_qp(iphi,jphi,qp) = vret_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) endif enddo ; enddo enddo ; enddo + !element contribution to SW node (node 1, which sees the current element as element 4) + uret_b(I-1,J-1,4) = 0.25*((uret_qp(1,1,1)+uret_qp(1,1,4))+(uret_qp(1,1,2)+uret_qp(1,1,3))) + vret_b(I-1,J-1,4) = 0.25*((vret_qp(1,1,1)+vret_qp(1,1,4))+(vret_qp(1,1,2)+vret_qp(1,1,3))) + + !element contribution to NW node (node 3, which sees the current element as element 2) + uret_b(I-1,J ,2) = 0.25*((uret_qp(1,2,1)+uret_qp(1,2,4))+(uret_qp(1,2,2)+uret_qp(1,2,3))) + vret_b(I-1,J ,2) = 0.25*((vret_qp(1,2,1)+vret_qp(1,2,4))+(vret_qp(1,2,2)+vret_qp(1,2,3))) + + !element contribution to SE node (node 2, which sees the current element as element 3) + uret_b(I ,J-1,3) = 0.25*((uret_qp(2,1,1)+uret_qp(2,1,4))+(uret_qp(2,1,2)+uret_qp(2,1,3))) + vret_b(I ,J-1,3) = 0.25*((vret_qp(2,1,1)+vret_qp(2,1,4))+(vret_qp(2,1,2)+vret_qp(2,1,3))) + + !element contribution to NE node (node 4, which sees the current element as element 1) + uret_b(I ,J ,1) = 0.25*((uret_qp(2,2,1)+uret_qp(2,2,4))+(uret_qp(2,2,2)+uret_qp(2,2,3))) + vret_b(I ,J ,1) = 0.25*((vret_qp(2,2,1)+vret_qp(2,2,4))+(vret_qp(2,2,2)+vret_qp(2,2,3))) + if (float_cond(i,j) == 1) then Ucell(:,:) = u_shlf(I-1:I,J-1:J) ; Vcell(:,:) = v_shlf(I-1:I,J-1:J) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, bathyT(i,j), dens_ratio, Usub, Vsub) - - if (umask(I-1,J-1) == 1) uret(I-1,J-1) = uret(I-1,J-1) + Usub(1,1) * basal_trac(i,j) - if (umask(I-1,J) == 1) uret(I-1,J) = uret(I-1,J) + Usub(1,2) * basal_trac(i,j) - if (umask(I,J-1) == 1) uret(I,J-1) = uret(I,J-1) + Usub(2,1) * basal_trac(i,j) - if (umask(I,J) == 1) uret(I,J) = uret(I,J) + Usub(2,2) * basal_trac(i,j) - - if (vmask(I-1,J-1) == 1) vret(I-1,J-1) = vret(I-1,J-1) + Vsub(1,1) * basal_trac(i,j) - if (vmask(I-1,J) == 1) vret(I-1,J) = vret(I-1,J) + Vsub(1,2) * basal_trac(i,j) - if (vmask(I,J-1) == 1) vret(I,J-1) = vret(I,J-1) + Vsub(2,1) * basal_trac(i,j) - if (vmask(I,J) == 1) vret(I,J) = vret(I,J) + Vsub(2,2) * basal_trac(i,j) - endif + Hcell(:,:) = H_node(I-1:I,J-1:J) + + call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, & + bathyT(i,j), dens_ratio, Usub, Vsub) + if (umask(I-1,J-1) == 1) uret_b(I-1,J-1,4) = uret_b(I-1,J-1,4) + (Usub(1,1) * basal_trac(i,j)) + if (umask(I-1,J ) == 1) uret_b(I-1,J ,2) = uret_b(I-1,J ,2) + (Usub(1,2) * basal_trac(i,j)) + if (umask(I ,J-1) == 1) uret_b(I ,J-1,3) = uret_b(I ,J-1,3) + (Usub(2,1) * basal_trac(i,j)) + if (umask(I ,J ) == 1) uret_b(I ,J ,1) = uret_b(I ,J ,1) + (Usub(2,2) * basal_trac(i,j)) + + if (vmask(I-1,J-1) == 1) vret_b(I-1,J-1,4) = vret_b(I-1,J-1,4) + (Vsub(1,1) * basal_trac(i,j)) + if (vmask(I-1,J ) == 1) vret_b(I-1,J ,2) = vret_b(I-1,J ,2) + (Vsub(1,2) * basal_trac(i,j)) + if (vmask(I ,J-1) == 1) vret_b(I ,J-1,3) = vret_b(I ,J-1,3) + (Vsub(2,1) * basal_trac(i,j)) + if (vmask(I ,J ) == 1) vret_b(I ,J ,1) = vret_b(I ,J ,1) + (Vsub(2,2) * basal_trac(i,j)) + endif endif ; enddo ; enddo + do J=js-1,je ; do I=is-1,ie + uret(I,J) = (uret_b(I,J,1)+uret_b(I,J,4)) + (uret_b(I,J,2)+uret_b(I,J,3)) + vret(I,J) = (vret_b(I,J,1)+vret_b(I,J,4)) + (vret_b(I,J,2)+vret_b(I,J,3)) + enddo; enddo + end subroutine CG_action subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, Vcontr) @@ -2579,45 +2638,101 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, real, dimension(2,2), intent(out) :: Vcontr !< The areal average of v-velocities where the ice shelf !! is grounded, or 0 where it is floating [L T-1 ~> m s-1]. + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr + !! at each sub-cell + real, dimension(2,2) :: Ucontr_q, Vcontr_q !Contributions to a node from each quadrature point in a sub-grid cell real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-cell ice thickness [Z ~> m] integer :: nsub, i, j, qx, qy, m, n - nsub = size(Phisub,1) + nsub = size(Phisub,3) subarea = 1.0 / (nsub**2) - do n=1,2 ; do m=1,2 - Ucontr(m,n) = 0.0 ; Vcontr(m,n) = 0.0 - do qy=1,2 ; do qx=1,2 ; do j=1,nsub ; do i=1,nsub - hloc = (Phisub(i,j,1,1,qx,qy)*H(1,1) + Phisub(i,j,2,2,qx,qy)*H(2,2)) + & - (Phisub(i,j,1,2,qx,qy)*H(1,2) + Phisub(i,j,2,1,qx,qy)*H(2,1)) + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do qy=1,2 ; do qx=1,2 + !calculate quadrature point contributions for the sub-cell, to each node + hloc = (Phisub(qx,qy,i,j,1,1)*H(1,1) + Phisub(qx,qy,i,j,2,2)*H(2,2)) + & + (Phisub(qx,qy,i,j,1,2)*H(1,2) + Phisub(qx,qy,i,j,2,1)*H(2,1)) + if (dens_ratio * hloc - bathyT > 0) then - Ucontr(m,n) = Ucontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & - ((Phisub(i,j,1,1,qx,qy) * U(1,1) + Phisub(i,j,2,2,qx,qy) * U(2,2)) + & - (Phisub(i,j,1,2,qx,qy) * U(1,2) + Phisub(i,j,2,1,qx,qy) * U(2,1))) - Vcontr(m,n) = Vcontr(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy) * & - ((Phisub(i,j,1,1,qx,qy) * V(1,1) + Phisub(i,j,2,2,qx,qy) * V(2,2)) + & - (Phisub(i,j,1,2,qx,qy) * V(1,2) + Phisub(i,j,2,1,qx,qy) * V(2,1))) + Ucontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * & + ((Phisub(qx,qy,i,j,1,1) * U(1,1) + Phisub(qx,qy,i,j,2,2) * U(2,2)) + & + (Phisub(qx,qy,i,j,1,2) * U(1,2) + Phisub(qx,qy,i,j,2,1) * U(2,1))) + Vcontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * & + ((Phisub(qx,qy,i,j,1,1) * V(1,1) + Phisub(qx,qy,i,j,2,2) * V(2,2)) + & + (Phisub(qx,qy,i,j,1,2) * V(1,2) + Phisub(qx,qy,i,j,2,1) * V(2,1))) + else + Ucontr_q(qx,qy) = 0.0; Vcontr_q(qx,qy) = 0.0 endif - enddo ; enddo ; enddo ; enddo + enddo; enddo + + !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell + Ucontr_sub(i,j,m,n) = (subarea * 0.25) * ((Ucontr_q(1,1) + Ucontr_q(2,2)) + (Ucontr_q(1,2)+Ucontr_q(2,1))) + Vcontr_sub(i,j,m,n) = (subarea * 0.25) * ((Vcontr_q(1,1) + Vcontr_q(2,2)) + (Vcontr_q(1,2)+Vcontr_q(2,1))) + enddo; enddo ; enddo ; enddo + + !sum up the sub-cell contributions to each node + do n=1,2 ; do m=1,2 + call sum_square_matrix(Ucontr(m,n),Ucontr_sub(:,:,m,n),nsub) + call sum_square_matrix(Vcontr(m,n),Vcontr_sub(:,:,m,n),nsub) enddo ; enddo end subroutine CG_action_subgrid_basal + +!! Returns the sum of the elements in a square matrix. This sum is bitwise identical even if the matrices are rotated. +subroutine sum_square_matrix(sum_out, mat_in, n) + integer, intent(in) :: n !< The length and width of each matrix in mat_in + real, dimension(n,n), intent(in) :: mat_in !< The four n x n matrices to be summed individually + real, intent(out) :: sum_out !< The sums of each of the 4 matrices given in mat_in + integer :: s0,e0,s1,e1 + + sum_out=0.0 + + s0=1; e0=n + + !start by summing elements on outer edges of matrix + do while (s0 returns the diagonal entries of the matrix for a Jacobi preconditioning subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, hmask, dens_ratio, & - Phisub, u_diagonal, v_diagonal) + Phi, Phisub, u_diagonal, v_diagonal) type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< If GL_regularize=true, an array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not + intent(in) :: float_cond !< If GL_regularize=true, indicates cells containing + !! the grounding line (float_cond=1) or not (float_cond=0) real, dimension(SZDIB_(G),SZDJB_(G)), & intent(in) :: H_node !< The ice shelf thickness at nodal !! (corner) points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & + real, dimension(SZDI_(G),SZDJ_(G),CS%visc_qps), & intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's !! flow law [R L4 Z T-1 ~> kg m2 s-1]. The exact form !! and units depend on the basal law exponent. @@ -2630,6 +2745,9 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, !! partly or fully covered by an ice-shelf real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] + real, dimension(8,4,SZDI_(G),SZDJ_(G)), & + intent(in) :: Phi !< The gradients of bilinear basis elements at Gaussian + !! quadrature points surrounding the cell vertices [L-1 ~> m-1] real, dimension(:,:,:,:,:,:), intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & @@ -2644,89 +2762,122 @@ subroutine matrix_diagonal(CS, G, US, float_cond, H_node, ice_visc, basal_trac, real :: ux, uy, vx, vy ! Interpolated weight gradients [L-1 ~> m-1] real :: uq, vq - real, dimension(8,4) :: Phi ! Weight gradients [L-1 ~> m-1] real, dimension(2) :: xquad real, dimension(2,2) :: Hcell, sub_ground - integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt - real :: Ee + real, dimension(2,2,4) :: u_diag_qp, v_diag_qp + real, dimension(SZDIB_(G),SZDJB_(G),4) :: u_diag_b, v_diag_b + logical :: visc_qp4 + integer :: i, j, isc, jsc, iec, jec, iphi, jphi, iq, jq, ilq, jlq, Itgt, Jtgt, qp, qpv isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - Ee=1.0 + if (CS%visc_qps == 4) then + visc_qp4=.true. + else + visc_qp4=.false. + qpv = 1 + endif + + u_diag_b(:,:,:)=0.0 + v_diag_b(:,:,:)=0.0 do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (hmask(i,j) == 1 .or. hmask(i,j)==3) then - call bilinear_shape_fn_grid(G, i, j, Phi) - ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j + u_diag_qp(:,:,:)=0.0; v_diag_qp(:,:,:)=0.0 + do iq=1,2 ; do jq=1,2 - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) - do iphi=1,2 ; do jphi=1,2 + qp = 2*(jq-1)+iq !current quad point + if (visc_qp4) qpv = qp !current quad point for viscosity + + do jphi=1,2 ; Jtgt = J-2+jphi ; do iphi=1,2 ; Itgt = I-2+iphi - Itgt = I-2+iphi ; Jtgt = J-2+jphi ilq = 1 ; if (iq == iphi) ilq = 2 jlq = 1 ; if (jq == jphi) jlq = 2 if (CS%umask(Itgt,Jtgt) == 1) then - ux = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - uy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + ux = Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + uy = Phi(2*(2*(jphi-1)+iphi),qp,i,j) vx = 0. vy = 0. - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * Ee * ice_visc(i,j) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + u_diag_qp(iphi,jphi,qp) = & + ice_visc(i,j,qpv) * ((4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (uy+vx) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) if (float_cond(i,j) == 0) then uq = xquad(ilq) * xquad(jlq) - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) + u_diag_qp(iphi,jphi,qp) = u_diag_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * uq) * (xquad(ilq) * xquad(jlq)) endif endif if (CS%vmask(Itgt,Jtgt) == 1) then - vx = Phi(2*(2*(jphi-1)+iphi)-1, 2*(jq-1)+iq) - vy = Phi(2*(2*(jphi-1)+iphi), 2*(jq-1)+iq) + vx = Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + vy = Phi(2*(2*(jphi-1)+iphi),qp,i,j) ux = 0. uy = 0. - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * Ee * ice_visc(i,j) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq)) + v_diag_qp(iphi,jphi,qp) = & + ice_visc(i,j,qpv) * ((uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,qp,i,j) + & + (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),qp,i,j)) if (float_cond(i,j) == 0) then vq = xquad(ilq) * xquad(jlq) - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) + v_diag_qp(iphi,jphi,qp) = v_diag_qp(iphi,jphi,qp) + & + (basal_trac(i,j) * vq) * (xquad(ilq) * xquad(jlq)) endif endif enddo ; enddo enddo ; enddo + !element contribution to SW node (node 1, which sees the current element as element 4) + u_diag_b(I-1,J-1,4) = 0.25*((u_diag_qp(1,1,1)+u_diag_qp(1,1,4))+(u_diag_qp(1,1,2)+u_diag_qp(1,1,3))) + v_diag_b(I-1,J-1,4) = 0.25*((v_diag_qp(1,1,1)+v_diag_qp(1,1,4))+(v_diag_qp(1,1,2)+v_diag_qp(1,1,3))) + + !element contribution to NW node (node 3, which sees the current element as element 2) + u_diag_b(I-1,J ,2) = 0.25*((u_diag_qp(1,2,1)+u_diag_qp(1,2,4))+(u_diag_qp(1,2,2)+u_diag_qp(1,2,3))) + v_diag_b(I-1,J ,2) = 0.25*((v_diag_qp(1,2,1)+v_diag_qp(1,2,4))+(v_diag_qp(1,2,2)+v_diag_qp(1,2,3))) + + !element contribution to SE node (node 2, which sees the current element as element 3) + u_diag_b(I ,J-1,3) = 0.25*((u_diag_qp(2,1,1)+u_diag_qp(2,1,4))+(u_diag_qp(2,1,2)+u_diag_qp(2,1,3))) + v_diag_b(I ,J-1,3) = 0.25*((v_diag_qp(2,1,1)+v_diag_qp(2,1,4))+(v_diag_qp(2,1,2)+v_diag_qp(2,1,3))) + + !element contribution to NE node (node 4, which sees the current element as element 1) + u_diag_b(I ,J ,1) = 0.25*((u_diag_qp(2,2,1)+u_diag_qp(2,2,4))+(u_diag_qp(2,2,2)+u_diag_qp(2,2,3))) + v_diag_b(I ,J ,1) = 0.25*((v_diag_qp(2,2,1)+v_diag_qp(2,2,4))+(v_diag_qp(2,2,2)+v_diag_qp(2,2,3))) + if (float_cond(i,j) == 1) then Hcell(:,:) = H_node(i-1:i,j-1:j) call CG_diagonal_subgrid_basal(Phisub, Hcell, CS%bed_elev(i,j), dens_ratio, sub_ground) - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - if (CS%umask(Itgt,Jtgt) == 1) then - u_diagonal(Itgt,Jtgt) = u_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) - endif - if (CS%vmask(Itgt,Jtgt) == 1) then - v_diagonal(Itgt,Jtgt) = v_diagonal(Itgt,Jtgt) + sub_ground(iphi,jphi) * basal_trac(i,j) - endif - enddo ; enddo + + if (CS%umask(I-1,J-1) == 1) u_diag_b(I-1,J-1,4) = u_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) + if (CS%umask(I-1,J ) == 1) u_diag_b(I-1,J ,2) = u_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) + if (CS%umask(I ,J-1) == 1) u_diag_b(I ,J-1,3) = u_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) + if (CS%umask(I ,J ) == 1) u_diag_b(I ,J ,1) = u_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) + + if (CS%vmask(I-1,J-1) == 1) v_diag_b(I-1,J-1,4) = v_diag_b(I-1,J-1,4) + sub_ground(1,1) * basal_trac(i,j) + if (CS%vmask(I-1,J ) == 1) v_diag_b(I-1,J ,2) = v_diag_b(I-1,J ,2) + sub_ground(1,2) * basal_trac(i,j) + if (CS%vmask(I ,J-1) == 1) v_diag_b(I ,J-1,3) = v_diag_b(I ,J-1,3) + sub_ground(2,1) * basal_trac(i,j) + if (CS%vmask(I ,J ) == 1) v_diag_b(I ,J ,1) = v_diag_b(I ,J ,1) + sub_ground(2,2) * basal_trac(i,j) endif endif ; enddo ; enddo + do J=jsc-2,jec+1 ; do I=isc-2,iec+1 + u_diagonal(I,J) = (u_diag_b(I,J,1)+u_diag_b(I,J,4)) + (u_diag_b(I,J,2)+u_diag_b(I,J,3)) + v_diagonal(I,J) = (v_diag_b(I,J,1)+v_diag_b(I,J,4)) + (v_diag_b(I,J,2)+v_diag_b(I,J,3)) + enddo ; enddo + end subroutine matrix_diagonal -subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_grnd) +subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd) real, dimension(:,:,:,:,:,:), & intent(in) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -2735,184 +2886,43 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, sub_gr real, intent(in) :: bathyT !< The depth of ocean bathymetry at tracer points [Z ~> m]. real, intent(in) :: dens_ratio !< The density of ice divided by the density !! of seawater [nondim] - real, dimension(2,2), intent(out) :: sub_grnd !< The weighted fraction of the sub-cell where the ice shelf - !! is grounded [nondim] - - ! bathyT = cellwise-constant bed elevation + real, dimension(2,2), intent(out) :: f_grnd !< The weighted fraction of the sub-cell where the ice shelf + !! is grounded [nondim] + real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: f_grnd_sub ! The contributions to nodal f_grnd + !! from each sub-cell + real, dimension(2,2) :: f_grnd_q !Contributions to a node from each quadrature point in a sub-grid cell real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-region thickness [Z ~> m] integer :: nsub, i, j, qx, qy, m, n - nsub = size(Phisub,1) + nsub = size(Phisub,3) subarea = 1.0 / (nsub**2) - sub_grnd(:,:) = 0.0 - do m=1,2 ; do n=1,2 ; do j=1,nsub ; do i=1,nsub ; do qx=1,2 ; do qy = 1,2 - - hloc = (Phisub(i,j,1,1,qx,qy)*H_node(1,1) + Phisub(i,j,2,2,qx,qy)*H_node(2,2)) + & - (Phisub(i,j,1,2,qx,qy)*H_node(1,2) + Phisub(i,j,2,1,qx,qy)*H_node(2,1)) + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub + do qy=1,2 ; do qx = 1,2 + !calculate quadrature point contributions for the sub-cell, to each node + hloc = (Phisub(qx,qy,i,j,1,1)*H_node(1,1) + Phisub(qx,qy,i,j,2,2)*H_node(2,2)) + & + (Phisub(qx,qy,i,j,1,2)*H_node(1,2) + Phisub(qx,qy,i,j,2,1)*H_node(2,1)) - if (dens_ratio * hloc - bathyT > 0) then - sub_grnd(m,n) = sub_grnd(m,n) + subarea * 0.25 * Phisub(i,j,m,n,qx,qy)**2 - endif + if (dens_ratio * hloc - bathyT > 0) then + f_grnd_q(qx,qy) = Phisub(qx,qy,i,j,m,n)**2 + else + f_grnd_q(qx,qy) = 0.0 + endif + enddo ; enddo + !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell + f_grnd_sub(i,j,m,n) = (subarea * 0.25) * ((f_grnd_q(1,1) + f_grnd_q(2,2)) + (f_grnd_q(1,2)+f_grnd_q(2,1))) + enddo ; enddo ; enddo ; enddo - enddo ; enddo ; enddo ; enddo ; enddo ; enddo + !sum up the sub-cell contributions to each node + do n=1,2 ; do m=1,2 + call sum_square_matrix(f_grnd(m,n),f_grnd_sub(:,:,m,n),nsub) + enddo ; enddo end subroutine CG_diagonal_subgrid_basal -subroutine apply_boundary_values(CS, ISS, G, US, time, Phisub, H_node, ice_visc, basal_trac, float_cond, & - dens_ratio, u_bdry_contr, v_bdry_contr) - - type(ice_shelf_dyn_CS), intent(in) :: CS !< A pointer to the ice shelf control structure - type(ice_shelf_state), intent(in) :: ISS !< A structure with elements that describe - !! the ice-shelf state - type(ocean_grid_type), intent(in) :: G !< The grid structure used by the ice shelf. - type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors - type(time_type), intent(in) :: Time !< The current model time - real, dimension(:,:,:,:,:,:), & - intent(in) :: Phisub !< Quadrature structure weights at subgridscale - !! locations for finite element calculations [nondim] - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(in) :: H_node !< The ice shelf thickness at nodal - !! (corner) points [Z ~> m]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: ice_visc !< A field related to the ice viscosity from Glen's - !! flow law. The exact form and units depend on the - !! basal law exponent. [R L4 Z T-1 ~> kg m2 s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: basal_trac !< Area-integrated taub_beta field related to the nonlinear - !! part of the "linearized" basal stress [R L3 T-1 ~> kg s-1]. - - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(in) :: float_cond !< An array indicating where the ice - !! shelf is floating: 0 if floating, 1 if not. - real, intent(in) :: dens_ratio !< The density of ice divided by the density - !! of seawater, nondimensional - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: u_bdry_contr !< Zonal force contributions due to the - !! open boundaries [R L3 Z T-2 ~> kg m s-2] - real, dimension(SZDIB_(G),SZDJB_(G)), & - intent(inout) :: v_bdry_contr !< Meridional force contributions due to the - !! open boundaries [R L3 Z T-2 ~> kg m s-2] - -! this will be a per-setup function. the boundary values of thickness and velocity -! (and possibly other variables) will be updated in this function - - real, dimension(8,4) :: Phi - real, dimension(2) :: xquad - real :: ux, uy, vx, vy ! Components of velocity shears or divergence [T-1 ~> s-1] - real :: uq, vq ! Interpolated velocities [L T-1 ~> m s-1] - real, dimension(2,2) :: Ucell,Vcell,Hcell,Usubcontr,Vsubcontr - integer :: i, j, isc, jsc, iec, jec, iq, jq, iphi, jphi, ilq, jlq, Itgt, Jtgt - real :: Ee - - isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec - - xquad(1) = .5 * (1-sqrt(1./3)) ; xquad(2) = .5 * (1+sqrt(1./3)) - - Ee=1.0 - - do j=jsc-1,jec+1 ; do i=isc-1,iec+1 ; if (ISS%hmask(i,j) == 1 .or. ISS%hmask(i,j) == 3) then - - ! process this cell if any corners have umask set to non-dirichlet bdry. - - if ((CS%umask(I-1,J-1) == 3) .OR. (CS%umask(I,J-1) == 3) .OR. & - (CS%umask(I-1,J) == 3) .OR. (CS%umask(I,J) == 3) .OR. & - (CS%vmask(I-1,J-1) == 3) .OR. (CS%vmask(I,J-1) == 3) .OR. & - (CS%vmask(I-1,J) == 3) .OR. (CS%vmask(I,J) == 3)) then - - call bilinear_shape_fn_grid(G, i, j, Phi) - - ! Phi(2*i-1,j) gives d(Phi_i)/dx at quadrature point j - ! Phi(2*i,j) gives d(Phi_i)/dy at quadrature point j - - do iq=1,2 ; do jq=1,2 - - uq = CS%u_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - CS%u_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - CS%u_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & - CS%u_bdry_val(I,J) * (xquad(iq) * xquad(jq)) - - vq = CS%v_bdry_val(I-1,J-1) * (xquad(3-iq) * xquad(3-jq)) + & - CS%v_bdry_val(I,J-1) * (xquad(iq) * xquad(3-jq)) + & - CS%v_bdry_val(I-1,J) * (xquad(3-iq) * xquad(jq)) + & - CS%v_bdry_val(I,J) * (xquad(iq) * xquad(jq)) - - ux = CS%u_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & - CS%u_bdry_val(I-1,J) * Phi(5,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J) * Phi(7,2*(jq-1)+iq) - - vx = CS%v_bdry_val(I-1,J-1) * Phi(1,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J-1) * Phi(3,2*(jq-1)+iq) + & - CS%v_bdry_val(I-1,J) * Phi(5,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J) * Phi(7,2*(jq-1)+iq) - - uy = CS%u_bdry_val(I-1,J-1) * Phi(2,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J-1) * Phi(4,2*(jq-1)+iq) + & - CS%u_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & - CS%u_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - - vy = CS%v_bdry_val(I-1,J-1) * Phi(2,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J-1) * Phi(4,2*(jq-1)+iq) + & - CS%v_bdry_val(I-1,J) * Phi(6,2*(jq-1)+iq) + & - CS%v_bdry_val(I,J) * Phi(8,2*(jq-1)+iq) - - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") Ee = CS%Ee(i,j,2*(jq-1)+iq) - - do iphi=1,2 ; do jphi=1,2 ; Itgt = I-2+iphi ; Jtgt = J-2+jphi - ilq = 1 ; if (iq == iphi) ilq = 2 - jlq = 1 ; if (jq == jphi) jlq = 2 - - if (CS%umask(Itgt,Jtgt) == 1) then - u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * Ee * ice_visc(i,j) * ( (4*ux+2*vy) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (uy+vx) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - - if (float_cond(i,j) == 0) then - u_bdry_contr(Itgt,Jtgt) = u_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * uq * (xquad(ilq) * xquad(jlq)) - endif - endif - - if (CS%vmask(Itgt,Jtgt) == 1) then - v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * Ee * ice_visc(i,j) * ( (uy+vx) * Phi(2*(2*(jphi-1)+iphi)-1,2*(jq-1)+iq) + & - (4*vy+2*ux) * Phi(2*(2*(jphi-1)+iphi),2*(jq-1)+iq) ) - - if (float_cond(i,j) == 0) then - v_bdry_contr(Itgt,Jtgt) = v_bdry_contr(Itgt,Jtgt) + & - 0.25 * basal_trac(i,j) * vq * (xquad(ilq) * xquad(jlq)) - endif - endif - enddo ; enddo - enddo ; enddo - - if (float_cond(i,j) == 1) then - Ucell(:,:) = CS%u_bdry_val(i-1:i,j-1:j) ; Vcell(:,:) = CS%v_bdry_val(i-1:i,j-1:j) - Hcell(:,:) = H_node(i-1:i,j-1:j) - call CG_action_subgrid_basal(Phisub, Hcell, Ucell, Vcell, CS%bed_elev(i,j), & - dens_ratio, Usubcontr, Vsubcontr) - - if (CS%umask(I-1,J-1) == 1) u_bdry_contr(I-1,J-1) = u_bdry_contr(I-1,J-1) + Usubcontr(1,1) * basal_trac(i,j) - if (CS%umask(I-1,J) == 1) u_bdry_contr(I-1,J) = u_bdry_contr(I-1,J) + Usubcontr(1,2) * basal_trac(i,j) - if (CS%umask(I,J-1) == 1) u_bdry_contr(I,J-1) = u_bdry_contr(I,J-1) + Usubcontr(2,1) * basal_trac(i,j) - if (CS%umask(I,J) == 1) u_bdry_contr(I,J) = u_bdry_contr(I,J) + Usubcontr(2,2) * basal_trac(i,j) - - if (CS%vmask(I-1,J-1) == 1) v_bdry_contr(I-1,J-1) = v_bdry_contr(I-1,J-1) + Vsubcontr(1,1) * basal_trac(i,j) - if (CS%vmask(I-1,J) == 1) v_bdry_contr(I-1,J) = v_bdry_contr(I-1,J) + Vsubcontr(1,2) * basal_trac(i,j) - if (CS%vmask(I,J-1) == 1) v_bdry_contr(I,J-1) = v_bdry_contr(I,J-1) + Vsubcontr(2,1) * basal_trac(i,j) - if (CS%vmask(I,J) == 1) v_bdry_contr(I,J) = v_bdry_contr(I,J) + Vsubcontr(2,2) * basal_trac(i,j) - endif - endif - endif ; enddo ; enddo - - call pass_vector(u_bdry_contr, v_bdry_contr, G%domain, TO_ALL, BGRID_NE) -end subroutine apply_boundary_values - - !> Update depth integrated viscosity, based on horizontal strain rates subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) type(ice_shelf_dyn_CS), intent(inout) :: CS !< A pointer to the ice shelf control structure @@ -2924,9 +2934,6 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) intent(inout) :: u_shlf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(G%IsdB:G%IedB,G%JsdB:G%JedB), & intent(inout) :: v_shlf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, pointer, dimension(:,:,:,:) :: Phi => NULL() ! The gradients of bilinear basis elements at Gaussian - ! quadrature points surrounding the cell vertices [L-1 ~> m-1]. - real, pointer, dimension(:,:,:) :: PhiC => NULL() ! Same as Phi, but 1 quadrature point per cell (rather than 4) ! update DEPTH_INTEGRATED viscosity, based on horizontal strain rates - this is for bilinear FEM solve @@ -2938,8 +2945,7 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) real :: Visc_coef, n_g real :: ux, uy, vx, vy real :: eps_min ! Velocity shears [T-1 ~> s-1] -! real, dimension(8,4) :: Phi -! real :: umid, vmid, unorm ! Velocities [L T-1 ~> m s-1] + logical :: model_qp1, model_qp4 isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -2948,99 +2954,94 @@ subroutine calc_shelf_visc(CS, ISS, G, US, u_shlf, v_shlf) gisc = G%domain%nihalo+1 ; gjsc = G%domain%njhalo+1 giec = G%domain%niglobal+gisc ; gjec = G%domain%njglobal+gjsc is = iscq - 1; js = jscq - 1 - i_off = G%idg_offset ; j_off = G%jdg_offset + i_off = G%idg_offset ; j_off = G%jdg_offset if (trim(CS%ice_viscosity_compute) == "MODEL") then - allocate(PhiC(1:8,isc:iec,jsc:jec), source=0.0) - do j=jsc,jec ; do i=isc,iec - call bilinear_shape_fn_grid_1qp(G, i, j, PhiC(:,i,j)) - enddo; enddo - elseif (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then - allocate(Phi(1:8,1:4,isc:iec,jsc:jec), source=0.0) - do j=jsc,jec ; do i=isc,iec - call bilinear_shape_fn_grid(G, i, j, Phi(:,:,i,j)) - enddo; enddo + if (CS%visc_qps==1) then + model_qp1=.true. + model_qp4=.false. + else + model_qp1=.false. + model_qp4=.true. + endif endif n_g = CS%n_glen; eps_min = CS%eps_glen_min - CS%ice_visc(:,:) = 1.0e22 -! Visc_coef = US%kg_m2s_to_RZ_T*US%m_to_L*US%Z_to_L*(CS%A_glen_isothermal)**(-1./CS%n_glen) + do j=jsc,jec ; do i=isc,iec if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then if (trim(CS%ice_viscosity_compute) == "CONSTANT") then - CS%ice_visc(i,j) = 1e15 * US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T * (G%areaT(i,j) * ISS%h_shelf(i,j)) + CS%ice_visc(i,j,1) = 1e15 * (US%kg_m3_to_R*US%m_to_L*US%m_s_to_L_T) * (G%areaT(i,j) * ISS%h_shelf(i,j)) ! constant viscocity for debugging elseif (trim(CS%ice_viscosity_compute) == "OBS") then - if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j) = CS%AGlen_visc(i,j)*(G%areaT(i,j) * ISS%h_shelf(i,j)) - ! Here CS%Aglen_visc(i,j) is the ice viscocity [Pa s-1] computed from obs and read from a file - elseif (trim(CS%ice_viscosity_compute) == "MODEL") then - - Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * & - (CS%AGlen_visc(i,j))**(-1./CS%n_glen) - ! Units of Aglen_visc [Pa-3 s-1] - - ux = u_shlf(I-1,J-1) * PhiC(1,i,j) + & - u_shlf(I,J) * PhiC(7,i,j) + & - u_shlf(I-1,J) * PhiC(5,i,j) + & - u_shlf(I,J-1) * PhiC(3,i,j) - - vx = v_shlf(I-1,J-1) * PhiC(1,i,j) + & - v_shlf(I,J) * PhiC(7,i,j) + & - v_shlf(I-1,J) * PhiC(5,i,j) + & - v_shlf(I,J-1) * PhiC(3,i,j) - - uy = u_shlf(I-1,J-1) * PhiC(2,i,j) + & - u_shlf(I,J) * PhiC(8,i,j) + & - u_shlf(I-1,J) * PhiC(6,i,j) + & - u_shlf(I,J-1) * PhiC(4,i,j) - - vy = v_shlf(I-1,J-1) * PhiC(2,i,j) + & - v_shlf(I,J) * PhiC(8,i,j) + & - v_shlf(I-1,J) * PhiC(6,i,j) + & - v_shlf(I,J-1) * PhiC(4,i,j) - - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & - (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) - elseif (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") then - !in this case, we will compute viscosity at quadrature points within subroutines CG_action - !and apply_boundary_values. CS%ice_visc(i,j) will include everything except the effective strain rate term: - Visc_coef = ( (US%RL2_T2_to_Pa)**(-CS%n_glen)*US%T_to_s )**(-1./CS%n_glen) * & - (CS%AGlen_visc(i,j))**(-1./CS%n_glen) - CS%ice_visc(i,j) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) + if (CS%AGlen_visc(i,j) >0) CS%ice_visc(i,j,1) = CS%AGlen_visc(i,j) * (G%areaT(i,j) * ISS%h_shelf(i,j)) + ! Here CS%Aglen_visc(i,j) is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file + elseif (model_qp1) then + !calculate viscosity at 1 cell-centered quadrature point per cell + + Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) + ! Units of Aglen_visc [Pa-(n_g) s-1] + + ux = (u_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & + u_shlf(I,J) * CS%PhiC(7,i,j)) + & + (u_shlf(I-1,J) * CS%PhiC(5,i,j) + & + u_shlf(I,J-1) * CS%PhiC(3,i,j)) + + vx = (v_shlf(I-1,J-1) * CS%PhiC(1,i,j) + & + v_shlf(I,J) * CS%PhiC(7,i,j)) + & + (v_shlf(I-1,J) * CS%PhiC(5,i,j) + & + v_shlf(I,J-1) * CS%PhiC(3,i,j)) + + uy = (u_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & + u_shlf(I,J) * CS%PhiC(8,i,j)) + & + (u_shlf(I-1,J) * CS%PhiC(6,i,j) + & + u_shlf(I,J-1) * CS%PhiC(4,i,j)) + + vy = (v_shlf(I-1,J-1) * CS%PhiC(2,i,j) + & + v_shlf(I,J) * CS%PhiC(8,i,j)) + & + (v_shlf(I-1,J) * CS%PhiC(6,i,j) + & + v_shlf(I,J-1) * CS%PhiC(4,i,j)) + + CS%ice_visc(i,j,1) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + (US%s_to_T**2 * ((ux**2 + vy**2) + (ux*vy + 0.25*(uy+vx)**2) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%Pa_to_RL2_T2*US%s_to_T) + elseif (model_qp4) then + !calculate viscosity at 4 quadrature points per cell + + Visc_coef = (CS%AGlen_visc(i,j))**(-1./n_g) do iq=1,2 ; do jq=1,2 - ux = u_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - - vx = v_shlf(I-1,J-1) * Phi(1,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(3,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * Phi(5,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(7,2*(jq-1)+iq,i,j) - - uy = u_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - u_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & - u_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - u_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - - vy = v_shlf(I-1,J-1) * Phi(2,2*(jq-1)+iq,i,j) + & - v_shlf(I,J-1) * Phi(4,2*(jq-1)+iq,i,j) + & - v_shlf(I-1,J) * Phi(6,2*(jq-1)+iq,i,j) + & - v_shlf(I,J) * Phi(8,2*(jq-1)+iq,i,j) - - CS%Ee(i,j,2*(jq-1)+iq) = & - (US%s_to_T**2 * (ux**2 + vy**2 + ux*vy + 0.25*(uy+vx)**2 + eps_min**2))**((1.-n_g)/(2.*n_g)) + ux = (u_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) + + vx = (v_shlf(I-1,J-1) * CS%Phi(1,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * CS%Phi(7,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J-1) * CS%Phi(3,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * CS%Phi(5,2*(jq-1)+iq,i,j)) + + uy = (u_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & + u_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & + (u_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & + u_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) + + vy = (v_shlf(I-1,J-1) * CS%Phi(2,2*(jq-1)+iq,i,j) + & + v_shlf(I,J) * CS%Phi(8,2*(jq-1)+iq,i,j)) + & + (v_shlf(I,J-1) * CS%Phi(4,2*(jq-1)+iq,i,j) + & + v_shlf(I-1,J) * CS%Phi(6,2*(jq-1)+iq,i,j)) + + CS%ice_visc(i,j,2*(jq-1)+iq) = 0.5 * Visc_coef * (G%areaT(i,j) * ISS%h_shelf(i,j)) * & + (US%s_to_T**2 * ((ux**2 + vy**2) + (ux*vy + 0.25*(uy+vx)**2) + eps_min**2))**((1.-n_g)/(2.*n_g)) * & + (US%Pa_to_RL2_T2*US%s_to_T) enddo; enddo endif endif enddo ; enddo - if (trim(CS%ice_viscosity_compute) == "MODEL") deallocate(PhiC) - if (trim(CS%ice_viscosity_compute) == "MODEL_QUADRATURE") deallocate(Phi) end subroutine calc_shelf_visc @@ -3066,7 +3067,8 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) real :: alpha !Coulomb coefficient [nondim] real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R L2 T-2 ~> Pa] - real :: fB !for Coulomb Friction [(L T-1)^CS%CF_PostPeak ~> (m s-1)^CS%CF_PostPeak] + real :: fB !for Coulomb Friction [(T L-1)^CS%CF_PostPeak ~> (s m-1)^CS%CF_PostPeak] + real :: fN_scale !To convert effective pressure to mks units during Coulomb friction isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB @@ -3079,11 +3081,12 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) eps_min = CS%eps_glen_min if (CS%CoulombFriction) then - if (CS%CF_PostPeak.ne.1.0) THEN + if (CS%CF_PostPeak/=1.0) THEN alpha = (CS%CF_PostPeak-1.0)**(CS%CF_PostPeak-1.0) / CS%CF_PostPeak**CS%CF_PostPeak ![nondim] else alpha = 1.0 endif + fN_scale = US%R_to_kg_m3 * US%L_T_to_m_s**2 endif do j=jsd+1,jed @@ -3091,20 +3094,22 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) if ((ISS%hmask(i,j) == 1) .OR. (ISS%hmask(i,j) == 3)) then umid = ((u_shlf(I,J) + u_shlf(I-1,J-1)) + (u_shlf(I,J-1) + u_shlf(I-1,J))) * 0.25 vmid = ((v_shlf(I,J) + v_shlf(I-1,J-1)) + (v_shlf(I,J-1) + v_shlf(I-1,J))) * 0.25 - unorm = US%L_T_to_m_s*sqrt(umid**2 + vmid**2 + eps_min**2*(G%dxT(i,j)**2 + G%dyT(i,j)**2)) + unorm = US%L_T_to_m_s * sqrt( (umid**2 + vmid**2) + (eps_min**2 * (G%dxT(i,j)**2 + G%dyT(i,j)**2)) ) !Coulomb friction (Schoof 2005, Gagliardini et al 2007) if (CS%CoulombFriction) then !Effective pressure - Hf = max(CS%density_ocean_avg * CS%bed_elev(i,j)/CS%density_ice, 0.0) - fN = max(CS%density_ice * CS%g_Earth * (ISS%h_shelf(i,j) - Hf),CS%CF_MinN) - + Hf = max((CS%density_ocean_avg/CS%density_ice) * CS%bed_elev(i,j), 0.0) + fN = max(fN_scale*((CS%density_ice * CS%g_Earth) * (ISS%h_shelf(i,j) - Hf)),CS%CF_MinN) fB = alpha * (CS%C_basal_friction(i,j) / (CS%CF_Max * fN))**(CS%CF_PostPeak/CS%n_basal_fric) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * & - unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric) + + CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * & + (unorm**(CS%n_basal_fric-1.0) / (1.0 + fB * unorm**CS%CF_PostPeak)**(CS%n_basal_fric))) * & + (US%Pa_to_RLZ_T2*US%L_T_to_m_s) else - !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric .ne. 1) - CS%basal_traction(i,j) = G%areaT(i,j) * CS%C_basal_friction(i,j) * unorm**(CS%n_basal_fric-1) + !linear (CS%n_basal_fric=1) or "Weertman"/power-law (CS%n_basal_fric /= 1) + CS%basal_traction(i,j) = ((G%areaT(i,j) * CS%C_basal_friction(i,j)) * (unorm**(CS%n_basal_fric-1))) * & + (US%Pa_to_RLZ_T2*US%L_T_to_m_s) endif endif enddo @@ -3353,8 +3358,8 @@ subroutine bilinear_shape_fn_grid(G, i, j, Phi) xexp = xquad(qpoint) endif - Phi(2*node-1,qpoint) = ( d * (2 * xnode - 3) * yexp ) / (a*d) - Phi(2*node,qpoint) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + Phi(2*node-1,qpoint) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d) + Phi(2*node,qpoint) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) enddo enddo @@ -3400,15 +3405,15 @@ subroutine bilinear_shape_fn_grid_1qp(G, i, j, Phi) do node=1,4 xnode = 2-mod(node,2) ; ynode = ceiling(REAL(node)/2) - Phi(2*node-1) = ( d * (2 * xnode - 3) * yexp ) / (a*d) - Phi(2*node) = ( a * (2 * ynode - 3) * xexp ) / (a*d) + Phi(2*node-1) = ( (d * (2 * xnode - 3)) * yexp ) / (a*d) + Phi(2*node) = ( (a * (2 * ynode - 3)) * xexp ) / (a*d) enddo end subroutine bilinear_shape_fn_grid_1qp subroutine bilinear_shape_functions_subgrid(Phisub, nsub) integer, intent(in) :: nsub !< The number of subgridscale quadrature locations in each direction - real, dimension(nsub,nsub,2,2,2,2), & + real, dimension(2,2,nsub,nsub,2,2), & intent(inout) :: Phisub !< Quadrature structure weights at subgridscale !! locations for finite element calculations [nondim] @@ -3420,13 +3425,13 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) ! i think this general approach may not work for nonrectangular elements... ! - ! Phisub(i,j,k,l,q1,q2) + ! Phisub(q1,q2,i,j,k,l) + ! q1: quad point x-index + ! q2: quad point y-index ! i: subgrid index in x-direction ! j: subgrid index in y-direction ! k: basis function x-index ! l: basis function y-index - ! q1: quad point x-index - ! q2: quad point y-index ! e.g. k=1,l=1 => node 1 ! q1=2,q2=1 => quad point 2 @@ -3447,10 +3452,10 @@ subroutine bilinear_shape_functions_subgrid(Phisub, nsub) do qy=1,2 ; do qx=1,2 x = x0 + fracx*xquad(qx) y = y0 + fracx*xquad(qy) - Phisub(i,j,1,1,qx,qy) = (1.0-x) * (1.0-y) - Phisub(i,j,1,2,qx,qy) = (1.0-x) * y - Phisub(i,j,2,1,qx,qy) = x * (1.0-y) - Phisub(i,j,2,2,qx,qy) = x * y + Phisub(qx,qy,i,j,1,1) = (1.0-x) * (1.0-y) + Phisub(qx,qy,i,j,1,2) = (1.0-x) * y + Phisub(qx,qy,i,j,2,1) = x * (1.0-y) + Phisub(qx,qy,i,j,2,2) = x * y enddo ; enddo enddo ; enddo @@ -3623,8 +3628,8 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) intent(inout) :: H_node !< The ice shelf thickness at nodal (corner) !! points [Z ~> m]. - integer :: i, j, isc, iec, jsc, jec, num_h, k, l - real :: summ + integer :: i, j, isc, iec, jsc, jec, num_h, k, l, ic, jc + real :: h_arr(2,2) isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec @@ -3635,19 +3640,18 @@ subroutine interpolate_H_to_B(G, h_shelf, hmask, H_node) do j=jsc-1,jec do i=isc-1,iec - summ = 0.0 num_h = 0 - do k=0,1 - do l=0,1 - if (hmask(i+k,j+l) == 1.0 .or. hmask(i+k,j+l) == 3.0) then - summ = summ + h_shelf(i+k,j+l) - num_h = num_h + 1 - endif - enddo - enddo - if (num_h > 0) then - H_node(i,j) = summ / num_h - endif + do l=1,2; jc=j-1+l; do k=1,2; ic=i-1+k + if (hmask(ic,jc) == 1.0 .or. hmask(ic,jc) == 3.0) then + h_arr(k,l)=h_shelf(ic,jc) + num_h = num_h + 1 + else + h_arr(k,l)=0.0 + endif + if (num_h > 0) then + H_node(i,j) = ((h_arr(1,1)+h_arr(2,2))+(h_arr(1,2)+h_arr(2,1))) / num_h + endif + enddo; enddo enddo enddo @@ -3667,9 +3671,11 @@ subroutine ice_shelf_dyn_end(CS) deallocate(CS%u_bdry_val, CS%v_bdry_val) deallocate(CS%u_face_mask, CS%v_face_mask) deallocate(CS%umask, CS%vmask) + deallocate(CS%u_face_mask_bdry, CS%v_face_mask_bdry) + deallocate(CS%h_bdry_val) + deallocate(CS%float_cond) deallocate(CS%ice_visc, CS%AGlen_visc) - deallocate(CS%Ee) deallocate(CS%basal_traction,CS%C_basal_friction) deallocate(CS%OD_rt, CS%OD_av) deallocate(CS%t_bdry_val, CS%bed_elev) diff --git a/src/ice_shelf/MOM_ice_shelf_initialize.F90 b/src/ice_shelf/MOM_ice_shelf_initialize.F90 index 1e2076f889..f976187c2b 100644 --- a/src/ice_shelf/MOM_ice_shelf_initialize.F90 +++ b/src/ice_shelf/MOM_ice_shelf_initialize.F90 @@ -274,8 +274,7 @@ end subroutine initialize_ice_thickness_channel !> Initialize ice shelf boundary conditions for a channel configuration subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_bdry, & u_flux_bdry_val, v_flux_bdry_val, u_bdry_val, v_bdry_val, u_shelf, v_shelf, h_bdry_val, & - thickness_bdry_val, hmask, h_shelf, G,& - US, PF ) + hmask, h_shelf, G, US, PF ) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZIB_(G),SZJB_(G)), & @@ -299,10 +298,6 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b intent(inout) :: u_shelf !< The zonal ice shelf velocity [L T-1 ~> m s-1]. real, dimension(SZIB_(G),SZJB_(G)), & intent(inout) :: v_shelf !< The meridional ice shelf velocity [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] - !! boundary vertices [L T-1 ~> m s-1]. - real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -350,8 +345,13 @@ subroutine initialize_ice_shelf_boundary_channel(u_face_mask_bdry, v_face_mask_b if (G%geoLonBu(i,j) == westlon) then hmask(i+1,j) = 3.0 - h_bdry_val(i+1,j) = h_shelf(i+1,j) - thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + !--- + !OLD: thickness_bdry_val was used for ice dynamics, and h_bdry_val was not used anywhere except here: + !h_bdry_val(i+1,j) = h_shelf(i+1,j) ; thickness_bdry_val(i+1,j) = h_bdry_val(i+0*1,j) + !--- + !NEW: h_bdry_val is used for ice dynamics instead of thickness_bdry_val, which was removed + h_bdry_val(i+1,j) = h_shelf(i+0*1,j) !why 0*1 + !--- u_face_mask_bdry(i+1,j) = 5.0 u_bdry_val(i+1,j) = input_vel*(1-16.0*((G%geoLatBu(i-1,j)/lenlat-0.5))**4) !velocity distribution endif @@ -393,8 +393,6 @@ end subroutine initialize_ice_shelf_boundary_channel !> Initialize ice shelf flow from file subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& G, US, PF) -!subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,ice_visc,& -! G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: bed_elev !< The bed elevation [Z ~> m]. @@ -412,9 +410,8 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& ! h_shelf [Z ~> m] and area_shelf_h [L2 ~> m2] (and dimensionless) and updates hmask character(len=200) :: filename,vel_file,inputdir,bed_topo_file ! Strings for file/path character(len=200) :: ushelf_varname, vshelf_varname, & - ice_visc_varname, floatfr_varname, bed_varname ! Variable name in file + floatfr_varname, bed_varname ! Variable name in file character(len=40) :: mdl = "initialize_ice_velocity_from_file" ! This subroutine's name. - real :: len_sidestress call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_velocity_from_file: reading velocity") @@ -423,9 +420,6 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& call get_param(PF, mdl, "ICE_VELOCITY_FILE", vel_file, & "The file from which the velocity is read.", & default="ice_shelf_vel.nc") - call get_param(PF, mdl, "LEN_SIDE_STRESS", len_sidestress, & - "position past which shelf sides are stress free.", & - default=0.0, units="axis_units") filename = trim(inputdir)//trim(vel_file) call log_param(PF, mdl, "INPUTDIR/THICKNESS_FILE", filename) @@ -435,9 +429,6 @@ subroutine initialize_ice_flow_from_file(bed_elev,u_shelf, v_shelf,float_cond,& call get_param(PF, mdl, "ICE_V_VEL_VARNAME", vshelf_varname, & "The name of the v velocity variable in ICE_VELOCITY_FILE.", & default="v_shelf") - call get_param(PF, mdl, "ICE_VISC_VARNAME", ice_visc_varname, & - "The name of the ice viscosity variable in ICE_VELOCITY_FILE.", & - default="viscosity") call get_param(PF, mdl, "ICE_FLOAT_FRAC_VARNAME", floatfr_varname, & "The name of the ice float fraction (grounding fraction) variable in ICE_VELOCITY_FILE.", & default="float_frac") @@ -462,7 +453,7 @@ end subroutine initialize_ice_flow_from_file !> Initialize ice shelf b.c.s from file subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask_bdry, & - u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, thickness_bdry_val, & + u_bdry_val, v_bdry_val, umask, vmask, h_bdry_val, & hmask, h_shelf, G, US, PF ) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure @@ -480,8 +471,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask intent(inout) :: umask !< A mask for ice shelf velocity [nondim] real, dimension(SZDIB_(G),SZDJB_(G)), & intent(inout) :: vmask !< A mask for ice shelf velocity [nondim] - real, dimension(SZDI_(G),SZDJ_(G)), & - intent(inout) :: thickness_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: h_bdry_val !< The ice shelf thickness at open boundaries [Z ~> m] real, dimension(SZDI_(G),SZDJ_(G)), & @@ -501,7 +490,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask integer :: i, j, isc, jsc, iec, jec h_bdry_val(:,:) = 0. - thickness_bdry_val(:,:) = 0. call MOM_mesg(" MOM_ice_shelf_init_profile.F90, initialize_b_c_s_from_file: reading b.c.s") @@ -542,9 +530,9 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask call MOM_read_data(filename, trim(ufcmskbdry_varname), u_face_mask_bdry, G%Domain, position=CORNER, & - scale=US%m_s_to_L_T) + scale=1.) call MOM_read_data(filename, trim(vfcmskbdry_varname), v_face_mask_bdry, G%Domain, position=CORNER, & - scale=US%m_s_to_L_T) + scale=1.) call MOM_read_data(filename, trim(ubdryv_varname), u_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(vbdryv_varname), v_bdry_val, G%Domain, position=CORNER, scale=US%m_s_to_L_T) call MOM_read_data(filename, trim(umask_varname), umask, G%Domain, position=CORNER, scale=1.) @@ -557,7 +545,6 @@ subroutine initialize_ice_shelf_boundary_from_file(u_face_mask_bdry, v_face_mask do j=jsc,jec do i=isc,iec if (hmask(i,j) == 3.) then - thickness_bdry_val(i,j) = h_shelf(i,j) h_bdry_val(i,j) = h_shelf(i,j) endif enddo @@ -587,7 +574,7 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) if (trim(config)=="CONSTANT") then call get_param(PF, mdl, "BASAL_FRICTION_COEFF", C_friction, & - "Coefficient in sliding law.", units="Pa (m s-1)^(n_basal_fric)", default=5.e10) + "Coefficient in sliding law.", units="Pa (s m-1)^(n_basal_fric)", default=5.e10) C_basal_friction(:,:) = C_friction elseif (trim(config)=="FILE") then @@ -615,10 +602,13 @@ subroutine initialize_ice_C_basal_friction(C_basal_friction, G, US, PF) !> Initialize ice-stiffness parameter -subroutine initialize_ice_AGlen(AGlen, G, US, PF) +subroutine initialize_ice_AGlen(AGlen, ice_viscosity_compute, G, US, PF) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure real, dimension(SZDI_(G),SZDJ_(G)), & intent(inout) :: AGlen !< The ice-stiffness parameter A_Glen, often in [Pa-3 s-1] + character(len=40) :: ice_viscosity_compute !< Specifies whether the ice viscosity is computed internally + !! according to Glen's flow law; is constant (for debugging purposes) + !! or using observed strain rates and read from a file type(unit_scale_type), intent(in) :: US !< A structure containing unit conversion factors type(param_file_type), intent(in) :: PF !< A structure to parse for run-time parameters @@ -635,7 +625,7 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) if (trim(config)=="CONSTANT") then call get_param(PF, mdl, "A_GLEN", A_Glen, & - "Ice-stiffness parameter.", units="Pa-3 s-1", default=2.261e-25) + "Ice-stiffness parameter.", units="Pa-n_g s-1", default=2.261e-25) AGlen(:,:) = A_Glen @@ -655,8 +645,14 @@ subroutine initialize_ice_AGlen(AGlen, G, US, PF) if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_stiffness_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(varname), AGlen, G%Domain) + if (trim(ice_viscosity_compute) == "OBS") then + !AGlen is the ice viscosity [Pa s ~> R L2 T-1] computed from obs and read from a file + call MOM_read_data(filename, trim(varname), AGlen, G%Domain, scale=US%Pa_to_RL2_T2*US%s_to_T) + else + !AGlen is the ice stiffness parameter [Pa-n_g s-1] + call MOM_read_data(filename, trim(varname), AGlen, G%Domain) + endif endif end subroutine initialize_ice_AGlen @@ -681,7 +677,7 @@ subroutine initialize_ice_SMB(SMB, G, US, PF) if (trim(config)=="CONSTANT") then call get_param(PF, mdl, "SMB", SMB_val, & - "Surface mass balance.", units="kg m-2 s-1", default=0.0) + "Surface mass balance.", units="kg m-2 s-1", default=0.0, scale=US%kg_m2s_to_RZ_T) SMB(:,:) = SMB_val @@ -701,7 +697,7 @@ subroutine initialize_ice_SMB(SMB, G, US, PF) if (.not.file_exists(filename, G%Domain)) call MOM_error(FATAL, & " initialize_ice_SMV_from_file: Unable to open "//trim(filename)) - call MOM_read_data(filename,trim(varname), SMB, G%Domain) + call MOM_read_data(filename,trim(varname), SMB, G%Domain, scale=US%kg_m2s_to_RZ_T) endif end subroutine initialize_ice_SMB From b0ff6bd18feb797e146fc574bb1fb29ecad8cc2c Mon Sep 17 00:00:00 2001 From: alex-huth Date: Mon, 27 Nov 2023 18:58:38 -0500 Subject: [PATCH 502/629] fixed documentation of inputs to subroutine sum_square_matrix --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 4bfcc3605c..7a92b679f8 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -2683,8 +2683,8 @@ end subroutine CG_action_subgrid_basal !! Returns the sum of the elements in a square matrix. This sum is bitwise identical even if the matrices are rotated. subroutine sum_square_matrix(sum_out, mat_in, n) integer, intent(in) :: n !< The length and width of each matrix in mat_in - real, dimension(n,n), intent(in) :: mat_in !< The four n x n matrices to be summed individually - real, intent(out) :: sum_out !< The sums of each of the 4 matrices given in mat_in + real, dimension(n,n), intent(in) :: mat_in !< The n x n matrix whose elements will be summed + real, intent(out) :: sum_out !< The sum of the elements of matrix mat_in integer :: s0,e0,s1,e1 sum_out=0.0 From f7233e058eea1ae775a01a99d6b0dbc466a5e6a9 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Thu, 30 Nov 2023 14:34:09 -0500 Subject: [PATCH 503/629] Optimized sub-cell grounding subroutines, increasing computational efficiency --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 49 +++++++++++++----------- 1 file changed, 27 insertions(+), 22 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index 7a92b679f8..d1efc4599d 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -2640,6 +2640,8 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: Ucontr_sub, Vcontr_sub ! The contributions to Ucontr and Vcontr !! at each sub-cell + real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: uloc_arr !The local sub-cell u-velocity [L T-1 ~> m s-1] + real, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: vloc_arr !The local sub-cell v-velocity [L T-1 ~> m s-1] real, dimension(2,2) :: Ucontr_q, Vcontr_q !Contributions to a node from each quadrature point in a sub-grid cell real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-cell ice thickness [Z ~> m] @@ -2648,22 +2650,24 @@ subroutine CG_action_subgrid_basal(Phisub, H, U, V, bathyT, dens_ratio, Ucontr, nsub = size(Phisub,3) subarea = 1.0 / (nsub**2) + uloc_arr(:,:,:,:) = 0.0; vloc_arr(:,:,:,:)=0.0 + + do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 + hloc = (Phisub(qx,qy,i,j,1,1)*H(1,1) + Phisub(qx,qy,i,j,2,2)*H(2,2)) + & + (Phisub(qx,qy,i,j,1,2)*H(1,2) + Phisub(qx,qy,i,j,2,1)*H(2,1)) + if (dens_ratio * hloc - bathyT > 0) then + uloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * U(1,1) + Phisub(qx,qy,i,j,2,2) * U(2,2)) + & + (Phisub(qx,qy,i,j,1,2) * U(1,2) + Phisub(qx,qy,i,j,2,1) * U(2,1))) + vloc_arr(qx,qy,i,j) = ((Phisub(qx,qy,i,j,1,1) * V(1,1) + Phisub(qx,qy,i,j,2,2) * V(2,2)) + & + (Phisub(qx,qy,i,j,1,2) * V(1,2) + Phisub(qx,qy,i,j,2,1) * V(2,1))) + endif + enddo; enddo ; enddo ; enddo + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub do qy=1,2 ; do qx=1,2 !calculate quadrature point contributions for the sub-cell, to each node - hloc = (Phisub(qx,qy,i,j,1,1)*H(1,1) + Phisub(qx,qy,i,j,2,2)*H(2,2)) + & - (Phisub(qx,qy,i,j,1,2)*H(1,2) + Phisub(qx,qy,i,j,2,1)*H(2,1)) - - if (dens_ratio * hloc - bathyT > 0) then - Ucontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * & - ((Phisub(qx,qy,i,j,1,1) * U(1,1) + Phisub(qx,qy,i,j,2,2) * U(2,2)) + & - (Phisub(qx,qy,i,j,1,2) * U(1,2) + Phisub(qx,qy,i,j,2,1) * U(2,1))) - Vcontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * & - ((Phisub(qx,qy,i,j,1,1) * V(1,1) + Phisub(qx,qy,i,j,2,2) * V(2,2)) + & - (Phisub(qx,qy,i,j,1,2) * V(1,2) + Phisub(qx,qy,i,j,2,1) * V(2,1))) - else - Ucontr_q(qx,qy) = 0.0; Vcontr_q(qx,qy) = 0.0 - endif + Ucontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * uloc_arr(qx,qy,i,j) + Vcontr_q(qx,qy) = Phisub(qx,qy,i,j,m,n) * vloc_arr(qx,qy,i,j) enddo; enddo !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell @@ -2891,6 +2895,7 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd real, dimension(SIZE(Phisub,3),SIZE(Phisub,3),2,2) :: f_grnd_sub ! The contributions to nodal f_grnd !! from each sub-cell + integer, dimension(2,2,SIZE(Phisub,3),SIZE(Phisub,3)) :: grnd_stat !0 at floating quad points, 1 at grounded real, dimension(2,2) :: f_grnd_q !Contributions to a node from each quadrature point in a sub-grid cell real :: subarea ! The fractional sub-cell area [nondim] real :: hloc ! The local sub-region thickness [Z ~> m] @@ -2899,17 +2904,17 @@ subroutine CG_diagonal_subgrid_basal (Phisub, H_node, bathyT, dens_ratio, f_grnd nsub = size(Phisub,3) subarea = 1.0 / (nsub**2) + grnd_stat(:,:,:,:)=0 + + do j=1,nsub ; do i=1,nsub; do qy=1,2 ; do qx=1,2 + hloc = (Phisub(qx,qy,i,j,1,1)*H_node(1,1) + Phisub(qx,qy,i,j,2,2)*H_node(2,2)) + & + (Phisub(qx,qy,i,j,1,2)*H_node(1,2) + Phisub(qx,qy,i,j,2,1)*H_node(2,1)) + if (dens_ratio * hloc - bathyT > 0) grnd_stat(qx,qy,i,j) = 1 + enddo; enddo ; enddo ; enddo + do n=1,2 ; do m=1,2 ; do j=1,nsub ; do i=1,nsub do qy=1,2 ; do qx = 1,2 - !calculate quadrature point contributions for the sub-cell, to each node - hloc = (Phisub(qx,qy,i,j,1,1)*H_node(1,1) + Phisub(qx,qy,i,j,2,2)*H_node(2,2)) + & - (Phisub(qx,qy,i,j,1,2)*H_node(1,2) + Phisub(qx,qy,i,j,2,1)*H_node(2,1)) - - if (dens_ratio * hloc - bathyT > 0) then - f_grnd_q(qx,qy) = Phisub(qx,qy,i,j,m,n)**2 - else - f_grnd_q(qx,qy) = 0.0 - endif + f_grnd_q(qx,qy) = grnd_stat(qx,qy,i,j) * Phisub(qx,qy,i,j,m,n)**2 enddo ; enddo !calculate sub-cell contribution to each node by summing up quadrature point contributions from the sub-cell f_grnd_sub(i,j,m,n) = (subarea * 0.25) * ((f_grnd_q(1,1) + f_grnd_q(2,2)) + (f_grnd_q(1,2)+f_grnd_q(2,1))) From d7096bdd26b8998bcef069e001be6fa8a08f06af Mon Sep 17 00:00:00 2001 From: alex-huth Date: Tue, 19 Dec 2023 16:49:35 -0500 Subject: [PATCH 504/629] fixed documented units of fN and fN_scale for ice shelf coulomb friction law --- src/ice_shelf/MOM_ice_shelf_dynamics.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 index d1efc4599d..ec49081baf 100644 --- a/src/ice_shelf/MOM_ice_shelf_dynamics.F90 +++ b/src/ice_shelf/MOM_ice_shelf_dynamics.F90 @@ -3071,9 +3071,9 @@ subroutine calc_shelf_taub(CS, ISS, G, US, u_shlf, v_shlf) real :: umid, vmid, unorm, eps_min ! Velocities [L T-1 ~> m s-1] real :: alpha !Coulomb coefficient [nondim] real :: Hf !"floatation thickness" for Coulomb friction [Z ~> m] - real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [R L2 T-2 ~> Pa] + real :: fN !Effective pressure (ice pressure - ocean pressure) for Coulomb friction [Pa] real :: fB !for Coulomb Friction [(T L-1)^CS%CF_PostPeak ~> (s m-1)^CS%CF_PostPeak] - real :: fN_scale !To convert effective pressure to mks units during Coulomb friction + real :: fN_scale !To convert effective pressure to mks units during Coulomb friction [Pa T2 R-1 L-2 ~> 1] isc = G%isc ; jsc = G%jsc ; iec = G%iec ; jec = G%jec iscq = G%iscB ; iecq = G%iecB ; jscq = G%jscB ; jecq = G%jecB From 90de5de86820a4f4384e5e504769e7b6b53f9b57 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Dec 2023 16:44:47 -0500 Subject: [PATCH 505/629] Rename u arg to step_MOM_dyn_split_RK2 as u_inst Renamed the arguments u and v to step_MOM_dyn_split_RK2 as u_inst and v_inst to more clearly differentiate between the instantaneous velocities (u_inst and v_inst) and the velocities with a time-averaged phase in the barotropic mode (u_av and v_av). A comment is also added at one point where the wrong velocities are being used to calculate and apply the Orlanski-style radiation open boundary conditions, with the intention of adding the option to correct this in a subsequent commit. This commit only changes the name of a pair of internal variables in one routine, and all answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2.F90 | 89 ++++++++++++++--------------- 1 file changed, 43 insertions(+), 46 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index debc63cb46..11b1eb5c16 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -70,7 +70,7 @@ module MOM_dynamics_split_RK2 use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units -use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF +use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member @@ -284,16 +284,16 @@ module MOM_dynamics_split_RK2 contains !> RK2 splitting for time stepping MOM adiabatic dynamics -subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_surf_begin, p_surf_end, & - uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, calc_dtbt, VarMix, & - MEKE, thickness_diffuse_CSp, pbv, Waves) +subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, G, GV, US, CS, & + calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, Waves) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - target, intent(inout) :: u !< Zonal velocity [L T-1 ~> m s-1] + target, intent(inout) :: u_inst !< Instantaneous zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - target, intent(inout) :: v !< Meridional velocity [L T-1 ~> m s-1] + target, intent(inout) :: v_inst !< Instantaneous meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type @@ -355,9 +355,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC ! The starting zonal velocities, which are - ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + ! saved for use in the radiation open boundary condition code [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are - ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + ! saved for use in the radiation open boundary condition code [L T-1 ~> m s-1] ! GMM, TODO: make these allocatable? real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix @@ -423,8 +423,8 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) 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 MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) + call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) endif @@ -475,7 +475,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_uv, u, v, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) @@ -503,7 +503,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call Stokes_PGF(G, GV, US, dz, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv ! will therefore report the sum total PGF and we avoid other @@ -576,15 +576,15 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * u_bc_accel(I,j,k)) + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * v_bc_accel(i,J,k)) + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k)) enddo ; enddo enddo call enable_averages(dt, Time_local, CS%diag) - call set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call set_viscous_ML(u_inst, v_inst, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) if (CS%debug) then @@ -628,7 +628,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! u_accel_bt = layer accelerations due to barotropic solver if (associated(CS%BT_cont) .or. CS%BT_use_layer_fluxes) then call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) call cpu_clock_end(id_clock_continuity) if (BT_cont_BT_thick) then @@ -639,7 +639,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif if (CS%BT_use_layer_fluxes) then - uh_ptr => uh_in ; vh_ptr => vh_in; u_ptr => u ; v_ptr => v + uh_ptr => uh_in ; vh_ptr => vh_in; u_ptr => u_inst ; v_ptr => v_inst endif call cpu_clock_begin(id_clock_btstep) @@ -647,7 +647,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the predictor step call to btstep. ! The CS%ADp argument here stores the weights for certain integrated diagnostics. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) @@ -661,11 +661,11 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !$OMP parallel do default(shared) do k=1,nz do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt_pred * & + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * & (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) enddo ; enddo do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt_pred * & + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * & (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) enddo ; enddo enddo @@ -679,7 +679,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! 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, & + call MOM_state_chksum("Predictor 1 init", u_inst, v_inst, 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_MKS*US%L_to_m**2*US%s_to_T) @@ -809,7 +809,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call Stokes_PGF(G, GV, US, dz, u, v, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) if (.not.Waves%Passive_Stokes_PGF) then do k=1,nz do j=js,je ; do I=Isq,Ieq @@ -899,7 +899,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") ! This is the corrector step call to btstep. - call btstep(u, v, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) @@ -920,22 +920,22 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - u(I,j,k) = G%mask2dCu(I,j) * (u(I,j,k) + dt * & + u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * & (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - v(i,J,k) = G%mask2dCv(i,J) * (v(i,J,k) + dt * & + v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * & (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) enddo ; enddo enddo call cpu_clock_end(id_clock_mom_update) 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 uvchksum("Corrector 1 [uv]", u_inst, v_inst, 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_MKS) call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & 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_state_chksum("Corrector 1", u_inst, v_inst, 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, & symmetric=sym) @@ -951,26 +951,26 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s do k = 1, nz do j = js , je do I = Isq, Ieq - uold(I,j,k) = u(I,j,k) + uold(I,j,k) = u_inst(I,j,k) enddo enddo do J = Jsq, Jeq do i = is, ie - vold(i,J,k) = v(i,J,k) + vold(i,J,k) = v_inst(i,J,k) enddo enddo enddo endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call vertvisc_coef(u, v, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) - call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) if (CS%fpmix) then - call vertFPmix(u, v, uold, vold, hbl, h, forces, dt, & + call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u, v, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) endif @@ -1000,7 +1000,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s ! h = h + dt * div . uh ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) - call continuity(u, v, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) @@ -1016,7 +1016,9 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s endif if (associated(CS%OBC)) then - call radiation_open_bdry_conds(CS%OBC, u, u_old_rad_OBC, v, v_old_rad_OBC, G, GV, US, dt) + !### I suspect that there is a bug here when u_inst is compared with a previous value of u_av + ! to estimate the dominant outward group velocity, but a fix is not available yet. + call radiation_open_bdry_conds(CS%OBC, u_inst, u_old_rad_OBC, v_inst, v_old_rad_OBC, G, GV, US, dt) endif ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. @@ -1156,7 +1158,7 @@ subroutine step_MOM_dyn_split_RK2(u, v, h, tv, visc, Time_local, dt, forces, p_s if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) if (CS%debug) then - call MOM_state_chksum("Corrector ", u, v, h, uh, vh, G, GV, US, symmetric=sym) + call MOM_state_chksum("Corrector ", u_inst, v_inst, 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_MKS) ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) @@ -1471,8 +1473,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param ! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt ! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av - id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', & - grain=CLOCK_ROUTINE) + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', grain=CLOCK_ROUTINE) call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) @@ -1482,17 +1483,14 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & CS%SAL_CSp, CS%tides_CSp) call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) - call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & - ntrunc, CS%vertvisc_CSp) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, ntrunc, CS%vertvisc_CSp) CS%set_visc_CSp => set_visc - call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, & - activate=is_new_run(restart_CS) ) + call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, activate=is_new_run(restart_CS) ) if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp if (associated(OBC)) then CS%OBC => OBC - if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, & - activate=is_new_run(restart_CS) ) + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, activate=is_new_run(restart_CS) ) endif if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp @@ -1515,8 +1513,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & - CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & - CS%SAL_CSp) + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, CS%SAL_CSp) if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then From ab3b0aaa3b7688ee362589ea63a7bbf2d5042487 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Wed, 20 Dec 2023 16:03:42 -0700 Subject: [PATCH 506/629] Automated Runtime Land Block Elimination (#263) * Enhancements for adding land block elimination to NUOPC cap: - Add sum_across_PEs_int4_2d to the sum_across_PEs interface - Allow mask_table file to be placed in run directory (now, the first dir that is looked at). * Enhance NUOPC cap to support MOM_mask_table. - Determine masked blocks. - Evenly distribute eliminated cells. - Fill ESMF gindex array accordingly. - During Export phase, set fields of eliminated cells to zero. * set %label in register_netcdf_field and register_netcdf_axis * first working version of an automated mask table generator * While determining masked blocks, take reentrancy and tripolar stitch into account * apply tripolar stitch fix in auto mask_table generation * add AUTO_IO_LAYOUT_FAC parameter to control IO_LOAYUT when AUTO_MASKTABLE is on * Miscellaneous auto masking fixes to address reviews: - Dimensionalize topographic depth variables used to determine cell masks in auto masktable routine. - Raise error if the user provided PE layout is inconsistent with auto masktable generation. - Save the masktable parameter description to a string variable to avoid repetition. - Fix typos, whitespaces, use modern array syntax. * Disable FPEs in MacOS testing Due to poor handling of floating point in HDF5 1.14.3, it is currently not possible to use floating point exceptions (FPEs) whenever this version is present. The GitHub Actions CI nodes would randomly select either 1.14.2 or 1.14.3, and would raise an FPE error if 1.14.3 was selected. Additionally, the homebrew installation does not provide a clean method for selecting a different version of HDF5. Thus, for now we disable FPEs in the MacOS testing, and hope to catch any legitimate FP errors in the Ubuntu version. We will restore these tests as soon as this has been fixed in an easily-accessible version of HDF5. As part of this PR, I have also moved the FCFLAGS configuration to the platform specific Actions files, allowing for independent compiler configuration for each platform. --------- Co-authored-by: Marshall Ward --- .github/actions/macos-setup/action.yml | 15 + .github/actions/testing-setup/action.yml | 11 - .github/actions/ubuntu-setup/action.yml | 12 + config_src/drivers/nuopc_cap/mom_cap.F90 | 138 ++++++-- .../drivers/nuopc_cap/mom_cap_methods.F90 | 9 +- config_src/infra/FMS1/MOM_domain_infra.F90 | 15 +- config_src/infra/FMS2/MOM_coms_infra.F90 | 10 + config_src/infra/FMS2/MOM_domain_infra.F90 | 17 +- src/core/MOM.F90 | 4 +- src/framework/MOM_domains.F90 | 321 +++++++++++++++++- src/ice_shelf/MOM_ice_shelf.F90 | 2 +- src/ocean_data_assim/MOM_oda_driver.F90 | 2 +- 12 files changed, 497 insertions(+), 59 deletions(-) diff --git a/.github/actions/macos-setup/action.yml b/.github/actions/macos-setup/action.yml index fecbe787b5..4c248abd11 100644 --- a/.github/actions/macos-setup/action.yml +++ b/.github/actions/macos-setup/action.yml @@ -16,3 +16,18 @@ runs: brew install netcdf-fortran brew install mpich echo "::endgroup::" + + # NOTE: Floating point exceptions are currently disabled due to an error in + # HDF5 1.4.3. They will be re-enabled when the default brew version has + # been updated to a working version. + + - name: Set compiler flags + shell: bash + run: | + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml index 6ba149d927..a15dd6d0a2 100644 --- a/.github/actions/testing-setup/action.yml +++ b/.github/actions/testing-setup/action.yml @@ -31,17 +31,6 @@ runs: REPORT_ERROR_LOGS=true make deps/lib/libFMS.a -s -j echo "::endgroup::" - - name: Store compiler flags used in Makefile - shell: bash - run: | - echo "::group::config.mk" - cd .testing - echo "FCFLAGS_DEBUG=-g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk - echo "FCFLAGS_REPRO=-g -O2 -fbacktrace" >> config.mk - echo "FCFLAGS_INIT=-finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk - cat config.mk - echo "::endgroup::" - - name: Compile MOM6 in symmetric memory mode shell: bash run: | diff --git a/.github/actions/ubuntu-setup/action.yml b/.github/actions/ubuntu-setup/action.yml index 3f3ba5f0b6..83d6795954 100644 --- a/.github/actions/ubuntu-setup/action.yml +++ b/.github/actions/ubuntu-setup/action.yml @@ -17,3 +17,15 @@ runs: sudo apt-get install libopenmpi-dev sudo apt-get install linux-tools-common echo "::endgroup::" + + - name: Store compiler flags used in Makefile + shell: bash + run: | + echo "::group::config.mk" + cd .testing + echo "FCFLAGS_DEBUG = -g -O0 -Wextra -Wno-compare-reals -fbacktrace -ffpe-trap=invalid,zero,overflow -fcheck=bounds" >> config.mk + echo "FCFLAGS_REPRO = -g -O2 -fbacktrace" >> config.mk + echo "FCFLAGS_INIT = -finit-real=snan -finit-integer=2147483647 -finit-derived" >> config.mk + echo "FCFLAGS_FMS = -g -fbacktrace -O0" >> config.mk + cat config.mk + echo "::endgroup::" diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 120078b11e..843e8c2ef1 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -16,7 +16,7 @@ module MOM_cap_mod 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 +use MOM_domains, only: pass_var, pe_here use MOM_error_handler, only: MOM_error, FATAL, is_root_pe use MOM_grid, only: ocean_grid_type, get_global_grid_size use MOM_ocean_model_nuopc, only: ice_ocean_boundary_type @@ -29,6 +29,7 @@ module MOM_cap_mod use MOM_cap_methods, only: med2mod_areacor, state_diagnose use MOM_cap_methods, only: ChkErr use MOM_ensemble_manager, only: ensemble_manager_init +use MOM_coms, only: sum_across_PEs #ifdef CESMCOUPLED use shr_log_mod, only: shr_log_setLogUnit @@ -826,6 +827,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) type(ocean_grid_type) , pointer :: ocean_grid type(ocean_internalstate_wrapper) :: ocean_internalstate integer :: npet, ntiles + integer :: npes ! number of PEs (from FMS). integer :: nxg, nyg, cnt integer :: isc,iec,jsc,jec integer, allocatable :: xb(:),xe(:),yb(:),ye(:),pe(:) @@ -852,6 +854,8 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) integer :: lsize integer :: ig,jg, ni,nj,k integer, allocatable :: gindex(:) ! global index space + integer, allocatable :: gindex_ocn(:) ! global index space for ocean cells (excl. masked cells) + integer, allocatable :: gindex_elim(:) ! global index space for eliminated cells character(len=128) :: fldname character(len=256) :: cvalue character(len=256) :: frmt ! format specifier for several error msgs @@ -875,6 +879,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) real(ESMF_KIND_R8) :: min_areacor_glob(2) real(ESMF_KIND_R8) :: max_areacor_glob(2) character(len=*), parameter :: subname='(MOM_cap:InitializeRealize)' + integer :: niproc, njproc + integer :: ip, jp, pe_ix + integer :: num_elim_blocks ! number of blocks to be eliminated + integer :: num_elim_cells_global, num_elim_cells_local, num_elim_cells_remaining + integer, allocatable :: cell_mask(:,:) !-------------------------------- rc = ESMF_SUCCESS @@ -919,19 +928,19 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) rc = ESMF_FAILURE call ESMF_LogWrite(subname//' ntiles must be 1', ESMF_LOGMSG_ERROR) endif - ntiles = mpp_get_domain_npes(ocean_public%domain) - write(tmpstr,'(a,1i6)') subname//' ntiles = ',ntiles + npes = mpp_get_domain_npes(ocean_public%domain) + write(tmpstr,'(a,1i6)') subname//' npes = ',npes call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) !--------------------------------- ! get start and end indices of each tile and their PET !--------------------------------- - allocate(xb(ntiles),xe(ntiles),yb(ntiles),ye(ntiles),pe(ntiles)) + allocate(xb(npes),xe(npes),yb(npes),ye(npes),pe(npes)) call mpp_get_compute_domains(ocean_public%domain, xbegin=xb, xend=xe, ybegin=yb, yend=ye) call mpp_get_pelist(ocean_public%domain, pe) if (dbug > 1) then - do n = 1,ntiles + do n = 1,npes write(tmpstr,'(a,6i6)') subname//' tiles ',n,pe(n),xb(n),xe(n),yb(n),ye(n) call ESMF_LogWrite(trim(tmpstr), ESMF_LOGMSG_INFO) enddo @@ -953,17 +962,102 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call get_global_grid_size(ocean_grid, ni, nj) lsize = ( ocean_grid%iec - ocean_grid%isc + 1 ) * ( ocean_grid%jec - ocean_grid%jsc + 1 ) - ! Create the global index space for the computational domain - allocate(gindex(lsize)) - k = 0 - do j = ocean_grid%jsc, ocean_grid%jec - jg = j + ocean_grid%jdg_offset - do i = ocean_grid%isc, ocean_grid%iec - ig = i + ocean_grid%idg_offset - k = k + 1 ! Increment position within gindex - gindex(k) = ni * (jg - 1) + ig + num_elim_blocks = 0 + num_elim_cells_global = 0 + num_elim_cells_local = 0 + num_elim_cells_remaining = 0 + + ! Compute the number of eliminated blocks (specified in MOM_mask_table) + if (associated(ocean_grid%Domain%maskmap)) then + njproc = size(ocean_grid%Domain%maskmap, 1) + niproc = size(ocean_grid%Domain%maskmap, 2) + + do ip = 1, niproc + do jp = 1, njproc + if (.not. ocean_grid%Domain%maskmap(jp,ip)) then + num_elim_blocks = num_elim_blocks+1 + endif + enddo enddo - enddo + endif + + ! Apply land block elimination to ESMF gindex + ! (Here we assume that each processor gets assigned a single tile. If multi-tile implementation is to be added + ! in MOM6 NUOPC cap in the future, below code must be updated accordingly.) + if (num_elim_blocks>0) then + + allocate(cell_mask(ni, nj), source=0) + allocate(gindex_ocn(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex_ocn(k) = ni * (jg - 1) + ig + cell_mask(ig, jg) = 1 + enddo + enddo + call sum_across_PEs(cell_mask, ni*nj) + + if (maxval(cell_mask) /= 1 ) then + call MOM_error(FATAL, "Encountered cells shared by multiple PEs while attempting to determine masked cells.") + endif + + num_elim_cells_global = ni * nj - sum(cell_mask) + num_elim_cells_local = num_elim_cells_global / npes + + if (pe_here() == pe(npes)) then + ! assign all remaining cells to the last PE. + num_elim_cells_remaining = num_elim_cells_global - num_elim_cells_local * npes + allocate(gindex_elim(num_elim_cells_local+num_elim_cells_remaining)) + else + allocate(gindex_elim(num_elim_cells_local)) + endif + + ! Zero-based PE index. + pe_ix = pe_here() - pe(1) + + k = 0 + do jg = 1, nj + do ig = 1, ni + if (cell_mask(ig, jg) == 0) then + k = k + 1 + if (k > pe_ix * num_elim_cells_local .and. & + k <= ((pe_ix+1) * num_elim_cells_local + num_elim_cells_remaining)) then + gindex_elim(k - pe_ix * num_elim_cells_local) = ni * (jg -1) + ig + endif + endif + enddo + enddo + + allocate(gindex(lsize + num_elim_cells_local + num_elim_cells_remaining)) + do k = 1, lsize + gindex(k) = gindex_ocn(k) + enddo + do k = 1, num_elim_cells_local + num_elim_cells_remaining + gindex(k+lsize) = gindex_elim(k) + enddo + + deallocate(cell_mask) + deallocate(gindex_ocn) + deallocate(gindex_elim) + + else ! no eliminated land blocks + + ! Create the global index space for the computational domain + allocate(gindex(lsize)) + k = 0 + do j = ocean_grid%jsc, ocean_grid%jec + jg = j + ocean_grid%jdg_offset + do i = ocean_grid%isc, ocean_grid%iec + ig = i + ocean_grid%idg_offset + k = k + 1 ! Increment position within gindex + gindex(k) = ni * (jg - 1) + ig + enddo + enddo + + endif DistGrid = ESMF_DistGridCreate(arbSeqIndexList=gindex, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -987,6 +1081,10 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) call ESMF_MeshGet(Emesh, spatialDim=spatialDim, numOwnedElements=numOwnedElements, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (lsize /= numOwnedElements - num_elim_cells_local - num_elim_cells_remaining) then + call MOM_error(FATAL, "Discrepancy detected between ESMF mesh and internal MOM6 domain sizes. Check mask table.") + endif + allocate(ownedElemCoords(spatialDim*numOwnedElements)) allocate(lonMesh(numOwnedElements), lon(numOwnedElements)) allocate(latMesh(numOwnedElements), lat(numOwnedElements)) @@ -1018,7 +1116,7 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) end do eps_omesh = get_eps_omesh(ocean_state) - do n = 1,numOwnedElements + do n = 1,lsize diff_lon = abs(mod(lonMesh(n) - lon(n),360.0)) if (diff_lon > eps_omesh) then frmt = "('ERROR: Difference between ESMF Mesh and MOM6 domain coords is "//& @@ -1122,11 +1220,11 @@ subroutine InitializeRealize(gcomp, importState, exportState, clock, rc) ! generate delayout and dist_grid - allocate(deBlockList(2,2,ntiles)) - allocate(petMap(ntiles)) - allocate(deLabelList(ntiles)) + allocate(deBlockList(2,2,npes)) + allocate(petMap(npes)) + allocate(deLabelList(npes)) - do n = 1, ntiles + do n = 1, npes deLabelList(n) = n deBlockList(1,1,n) = xb(n) deBlockList(1,2,n) = xe(n) diff --git a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 index db8bc33c90..3aa6278e9f 100644 --- a/config_src/drivers/nuopc_cap/mom_cap_methods.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap_methods.F90 @@ -852,7 +852,7 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid ! local variables type(ESMF_StateItem_Flag) :: itemFlag - integer :: n, i, j, i1, j1, ig,jg + integer :: n, i, j, k, i1, j1, ig,jg integer :: lbnd1,lbnd2 real(ESMF_KIND_R8), pointer :: dataPtr1d(:) real(ESMF_KIND_R8), pointer :: dataPtr2d(:,:) @@ -888,6 +888,13 @@ subroutine State_SetExport(state, fldname, isc, iec, jsc, jec, input, ocean_grid enddo end if + ! if a maskmap is provided, set exports of all eliminated cells to zero. + if (associated(ocean_grid%Domain%maskmap)) then + do k = n+1, size(dataPtr1d) + dataPtr1d(k) = 0.0 + enddo + endif + else if (geomtype == ESMF_GEOMTYPE_GRID) then call state_getfldptr(state, trim(fldname), dataptr2d, rc) diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 2c97a0bb31..1de9a6d658 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -16,7 +16,7 @@ module MOM_domain_infra use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update -use mpp_domains_mod, only : mpp_compute_block_extent +use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE @@ -40,7 +40,7 @@ module MOM_domain_infra public :: domain2D, domain1D, group_pass_type ! These interfaces are actually implemented or have explicit interfaces in this file. public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent -public :: deallocate_MOM_domain, get_global_shape, compute_block_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass @@ -1945,6 +1945,17 @@ subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) end subroutine compute_block_extent +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_extent + !> Broadcast a 2-d domain from the root PE to the other PEs subroutine broadcast_domain(domain) type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. diff --git a/config_src/infra/FMS2/MOM_coms_infra.F90 b/config_src/infra/FMS2/MOM_coms_infra.F90 index cf9a724734..06a9b9f343 100644 --- a/config_src/infra/FMS2/MOM_coms_infra.F90 +++ b/config_src/infra/FMS2/MOM_coms_infra.F90 @@ -42,6 +42,7 @@ module MOM_coms_infra interface sum_across_PEs module procedure sum_across_PEs_int4_0d module procedure sum_across_PEs_int4_1d + module procedure sum_across_PEs_int4_2d module procedure sum_across_PEs_int8_0d module procedure sum_across_PEs_int8_1d module procedure sum_across_PEs_int8_2d @@ -357,6 +358,15 @@ subroutine sum_across_PEs_int4_1d(field, length, pelist) call mpp_sum(field, length, pelist) end subroutine sum_across_PEs_int4_1d +!> Find the sum of the values in corresponding positions of field across PEs, and return these sums in field. +subroutine sum_across_PEs_int4_2d(field, length, pelist) + integer(kind=int32), dimension(:,:), intent(inout) :: field !< The values to add, the sums upon return + integer, intent(in) :: length !< Number of elements in field to add + integer, optional, intent(in) :: pelist(:) !< List of PEs to work with + + call mpp_sum(field, length, pelist) +end subroutine sum_across_PEs_int4_2d + !> Find the sum of field across PEs, and return this sum in field. subroutine sum_across_PEs_int8_0d(field, pelist) integer(kind=int64), intent(inout) :: field !< Value on this PE, and the sum across PEs upon return diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index ff1d888c47..95159f7fe1 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -16,7 +16,7 @@ module MOM_domain_infra use mpp_domains_mod, only : mpp_create_group_update, mpp_do_group_update use mpp_domains_mod, only : mpp_reset_group_update_field, mpp_group_update_initialized use mpp_domains_mod, only : mpp_start_group_update, mpp_complete_group_update -use mpp_domains_mod, only : mpp_compute_block_extent +use mpp_domains_mod, only : mpp_compute_block_extent, mpp_compute_extent use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE @@ -38,7 +38,7 @@ module MOM_domain_infra public :: domain2D, domain1D, group_pass_type ! These interfaces are actually implemented or have explicit interfaces in this file. public :: create_MOM_domain, clone_MOM_domain, get_domain_components, get_domain_extent -public :: deallocate_MOM_domain, get_global_shape, compute_block_extent +public :: deallocate_MOM_domain, get_global_shape, compute_block_extent, compute_extent public :: pass_var, pass_vector, fill_symmetric_edges, rescale_comp_data public :: pass_var_start, pass_var_complete, pass_vector_start, pass_vector_complete public :: create_group_pass, do_group_pass, start_group_pass, complete_group_pass @@ -1936,7 +1936,7 @@ subroutine get_global_shape(domain, niglobal, njglobal) njglobal = domain%njglobal end subroutine get_global_shape -!> Get the array ranges in one dimension for the divisions of a global index space +!> Get the array ranges in one dimension for the divisions of a global index space (alternative to compute_extent) subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) integer, intent(in) :: isg !< The starting index of the global index space integer, intent(in) :: ieg !< The ending index of the global index space @@ -1947,6 +1947,17 @@ subroutine compute_block_extent(isg, ieg, ndivs, ibegin, iend) call mpp_compute_block_extent(isg, ieg, ndivs, ibegin, iend) end subroutine compute_block_extent +!> Get the array ranges in one dimension for the divisions of a global index space +subroutine compute_extent(isg, ieg, ndivs, ibegin, iend) + integer, intent(in) :: isg !< The starting index of the global index space + integer, intent(in) :: ieg !< The ending index of the global index space + integer, intent(in) :: ndivs !< The number of divisions + integer, dimension(:), intent(out) :: ibegin !< The starting index of each division + integer, dimension(:), intent(out) :: iend !< The ending index of each division + + call mpp_compute_extent(isg, ieg, ndivs, ibegin, iend) +end subroutine compute_extent + !> Broadcast a 2-d domain from the root PE to the other PEs subroutine broadcast_domain(domain) type(domain2d), intent(inout) :: domain !< The domain2d type that will be shared across PEs. diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 89d1ee2004..447f77117f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2430,12 +2430,12 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, restart_CSp, & #endif G_in => CS%G_in #ifdef STATIC_MEMORY_ - call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + call MOM_domains_init(G_in%domain, US, param_file, symmetric=symmetric, & static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & NJPROC=NJPROC_) #else - call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + call MOM_domains_init(G_in%domain, US, param_file, symmetric=symmetric, & domain_name="MOM_in") #endif diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index a0f3855d19..f2c3225025 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -20,10 +20,13 @@ module MOM_domains use MOM_domain_infra, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR use MOM_domain_infra, only : CORNER, CENTER, NORTH_FACE, EAST_FACE use MOM_domain_infra, only : To_East, To_West, To_North, To_South, To_All, Omit_Corners -use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL +use MOM_domain_infra, only : compute_extent +use MOM_error_handler, only : MOM_error, MOM_mesg, NOTE, WARNING, FATAL, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type -use MOM_io_infra, only : file_exists +use MOM_io_infra, only : file_exists, read_field, open_ASCII_file, close_file, WRITEONLY_FILE use MOM_string_functions, only : slasher +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE +use MOM_unit_scaling, only : unit_scale_type implicit none ; private @@ -60,11 +63,12 @@ module MOM_domains !> MOM_domains_init initializes a MOM_domain_type variable, based on the information !! read in from a param_file_type, and optionally returns data describing various !! properties of the domain type. -subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & +subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & NIHALO, NJHALO, NIGLOBAL, NJGLOBAL, NIPROC, NJPROC, & min_halo, domain_name, include_name, param_suffix) type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type !! being defined here. + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters logical, optional, intent(in) :: symmetric !< If present, this specifies @@ -98,6 +102,7 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Local variables integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions + integer, dimension(2) :: auto_layout ! The layout determined by the auto masking routine integer, dimension(2) :: io_layout ! The layout of logical processors for input and output !$ integer :: ocean_nthreads ! Number of openMP threads !$ logical :: ocean_omp_hyper_thread ! If true use openMP hyper-threads @@ -112,6 +117,8 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & logical :: nonblocking ! If true, nonblocking halo updates will be used. logical :: thin_halos ! If true, If true, optional arguments may be used to specify the ! width of the halos that are updated with each call. + logical :: auto_mask_table ! Runtime flag that turns on automatic mask table generator + integer :: auto_io_layout_fac ! Used to compute IO layout when auto_mask_table is True. logical :: mask_table_exists ! True if there is a mask table file character(len=128) :: inputdir ! The directory in which to find the diag table character(len=200) :: mask_table ! The file name and later the full path to the diag table @@ -122,6 +129,10 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & character(len=8) :: char_xsiz, char_ysiz, char_niglobal, char_njglobal character(len=40) :: nihalo_nm, njhalo_nm, layout_nm, io_layout_nm, masktable_nm character(len=40) :: niproc_nm, njproc_nm + character(len=200) :: topo_config + integer :: id_clock_auto_mask + character(len=:), allocatable :: masktable_desc + character(len=:), allocatable :: auto_mask_table_fname ! Auto-generated mask table file name ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl ! This module's name. @@ -277,18 +288,52 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "INPUTDIR", inputdir, do_not_log=.true., default=".") inputdir = slasher(inputdir) - call get_param(param_file, mdl, trim(masktable_nm), mask_table, & - "A text file to specify n_mask, layout and mask_list. This feature masks out "//& - "processors that contain only land points. The first line of mask_table is the "//& - "number of regions to be masked out. The second line is the layout of the "//& - "model and must be consistent with the actual model layout. The following "//& - "(n_mask) lines give the logical positions of the processors that are masked "//& - "out. The mask_table can be created by tools like check_mask. The following "//& - "example of mask_table masks out 2 processors, (1,2) and (3,6), out of the 24 "//& - "in a 4x6 layout: \n 2\n 4,6\n 1,2\n 3,6\n", default="MOM_mask_table", & - layoutParam=.true.) - mask_table = trim(inputdir)//trim(mask_table) - mask_table_exists = file_exists(mask_table) + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, do_not_log=.true., fail_if_missing=.true.) + + auto_mask_table = .false. + if (.not. present(param_suffix) .and. .not. is_static .and. trim(topo_config) == 'file') then + call get_param(param_file, mdl, 'AUTO_MASKTABLE', auto_mask_table, & + "Turn on automatic mask table generation to eliminate land blocks.", & + default=.false., layoutParam=.true.) + endif + + masktable_desc = "A text file to specify n_mask, layout and mask_list. This feature masks out "//& + "processors that contain only land points. The first line of mask_table is the "//& + "number of regions to be masked out. The second line is the layout of the "//& + "model and must be consistent with the actual model layout. The following "//& + "(n_mask) lines give the logical positions of the processors that are masked "//& + "out. The mask_table can be created by tools like check_mask. The following "//& + "example of mask_table masks out 2 processors, (1,2) and (3,6), out of the 24 "//& + "in a 4x6 layout: \n 2\n 4,6\n 1,2\n 3,6\n" + + if (auto_mask_table) then + id_clock_auto_mask = cpu_clock_id('(Ocean gen_auto_mask_table)', grain=CLOCK_ROUTINE) + auto_mask_table_fname = "MOM_auto_mask_table" + + ! Auto-generate a mask file and determine the layout + call cpu_clock_begin(id_clock_auto_mask) + if (is_root_PE()) then + call gen_auto_mask_table(n_global, reentrant, tripolar_N, PEs_used, param_file, inputdir, & + auto_mask_table_fname, US, auto_layout) + endif + call broadcast(auto_layout, length=2) + call cpu_clock_end(id_clock_auto_mask) + + mask_table = auto_mask_table_fname + call log_param(param_file, mdl, trim(masktable_nm), mask_table, masktable_desc, & + default="MOM_mask_table", layoutParam=.true.) + else + call get_param(param_file, mdl, trim(masktable_nm), mask_table, masktable_desc, & + default="MOM_mask_table", layoutParam=.true.) + endif + + ! First, check the run directory for the mask_table input file. + mask_table_exists = file_exists(trim(mask_table)) + ! If not found, check the input directory + if (.not. mask_table_exists) then + mask_table = trim(inputdir)//trim(mask_table) + mask_table_exists = file_exists(mask_table) + endif if (is_static) then layout(1) = NIPROC ; layout(2) = NJPROC @@ -317,6 +362,16 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & "Shift to using "//trim(layout_nm)//" instead.") endif + if (auto_mask_table) then + if (layout(1) /= 0 .and. layout(1) /= auto_layout(1)) then + call MOM_error(FATAL, "Cannot set LAYOUT or NIPROC when AUTO_MASKTABLE is enabled.") + endif + if (layout(2) /= 0 .and. layout(2) /= auto_layout(2)) then + call MOM_error(FATAL, "Cannot set LAYOUT or NJPROC when AUTO_MASKTABLE is enabled.") + endif + layout(:) = auto_layout(:) + endif + if ( (layout(1) == 0) .and. (layout(2) == 0) ) & call MOM_define_layout(n_global, PEs_used, layout) if ( (layout(1) /= 0) .and. (layout(2) == 0) ) layout(2) = PEs_used / layout(1) @@ -351,9 +406,28 @@ subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & ! Set up the I/O layout, it will be checked later that it uses an even multiple of the number of ! PEs in each direction. io_layout(:) = (/ 1, 1 /) - call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & - "The processor layout to be used, or 0,0 to automatically set the io_layout "//& - "to be the same as the layout.", default=1, layoutParam=.true.) + + ! Compute a valid IO layout if auto_mask_table is on. Otherwise, read in IO_LAYOUT parameter, + if (auto_mask_table) then + call get_param(param_file, mdl, "AUTO_IO_LAYOUT_FAC", auto_io_layout_fac, & + "When AUTO_MASKTABLE is enabled, io layout is calculated by performing integer "//& + "division of the runtime-determined domain layout with this factor. If the factor "//& + "is set to 0 (default), the io layout is set to 1,1.", & + default=0, layoutParam=.true.) + if (auto_io_layout_fac>0) then + io_layout(1) = max(layout(1)/auto_io_layout_fac, 1) + io_layout(2) = max(layout(2)/auto_io_layout_fac, 1) + elseif (auto_io_layout_fac<0) then + call MOM_error(FATAL, 'AUTO_IO_LAYOUT_FAC must be a nonnegative integer.') + endif + call log_param(param_file, mdl, trim(io_layout_nm), io_layout, & + "The processor layout to be used, or 0,0 to automatically set the io_layout "//& + "to be the same as the layout.", layoutParam=.true.) + else + call get_param(param_file, mdl, trim(io_layout_nm), io_layout, & + "The processor layout to be used, or 0,0 to automatically set the io_layout "//& + "to be the same as the layout.", default=1, layoutParam=.true.) + endif call create_MOM_domain(MOM_dom, n_global, n_halo, reentrant, tripolar_N, layout, & io_layout=io_layout, domain_name=domain_name, mask_table=mask_table, & @@ -387,4 +461,215 @@ subroutine MOM_define_layout(n_global, ndivs, layout) layout = (/ idiv, jdiv /) end subroutine MOM_define_layout +!> Given a desired number of active npes, generate a layout and mask_table +subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file, inputdir, filename, US, layout) + integer, dimension(2), intent(in) :: n_global !< The total number of gridpoints in 2 directions + logical, dimension(2), intent(in) :: reentrant !< True if the x- and y- directions are periodic. + logical :: tripolar_N !< A flag indicating whether there is n. tripolar connectivity + integer, intent(in) :: npes !< The desired number of active PEs. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + character(len=128), intent(in) :: inputdir !< INPUTDIR parameter + character(len=:), allocatable, intent(in) :: filename !< Mask table file path (to be auto-generated.) + type(unit_scale_type), pointer :: US !< A dimensional unit scaling type + integer, dimension(2), intent(out) :: layout !< The generated layout of PEs (incl. masked blocks) + !local + real, dimension(n_global(1), n_global(2)) :: D ! Bathymetric depth (to be read in from TOPO_FILE) [Z ~> m] + integer, dimension(:,:), allocatable :: mask ! Cell masks (based on D and MINIMUM_DEPTH) + character(len=200) :: topo_filepath, topo_file ! Strings for file/path + character(len=200) :: topo_varname ! Variable name in file + character(len=200) :: topo_config + character(len=40) :: mdl = "gen_auto_mask_table" ! This subroutine's name. + integer :: i, j, p + real :: Dmask ! The depth for masking in the same units as D [Z ~> m] + real :: min_depth ! The minimum ocean depth in the same units as D [Z ~> m] + real :: mask_depth ! The depth shallower than which to mask a point as land. [Z ~> m] + real :: glob_ocn_frac ! ratio of ocean points to total number of points + real :: r_p ! aspect ratio for division count p. + integer :: nx, ny ! global domain sizes + integer, parameter :: ibuf=2, jbuf=2 + real, parameter :: r_extreme = 4.0 ! aspect ratio limit (>1) for a layout to be considered. + integer :: num_masked_blocks + integer, allocatable :: mask_table(:,:) + + ! Read in params necessary for auto-masking + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, do_not_log=.true., units="m", default=0.0) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, do_not_log=.true., units="m", default=-9999.0) + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, do_not_log=.true., fail_if_missing=.true.) + call get_param(param_file, mdl, "TOPO_FILE", topo_file, do_not_log=.true., default="topog.nc") + call get_param(param_file, mdl, "TOPO_VARNAME", topo_varname, do_not_log=.true., default="depth") + topo_filepath = trim(inputdir)//trim(topo_file) + + ! Sanity checks + if (.not. is_root_pe()) then + call MOM_error(FATAL, 'gen_auto_mask_table should only be called by the root PE.') + endif + if (trim(topo_config) /= "file") then + call MOM_error(FATAL, 'Auto mask table only works with TOPO_CONFIG="file"') + endif + if (.not.file_exists(topo_filepath)) then + call MOM_error(FATAL, " gen_auto_mask_table: Unable to open "//trim(topo_filepath)) + endif + + nx = n_global(1) + ny = n_global(2) + + ! Read in bathymetric depth. + D(:,:) = -9.0e30 * US%m_to_Z ! Initializing to a very large negative depth (tall mountains) everywhere. + call read_field(topo_filepath, trim(topo_varname), D, start=(/1, 1/), nread=n_global, no_domain=.true., & + scale=US%m_to_Z) + + allocate(mask(nx+2*ibuf, ny+2*jbuf), source=0) + + ! Determine cell masks + Dmask = mask_depth + if (mask_depth == -9999.0) Dmask = min_depth + do i=1,nx ; do j=1,ny + if (D(i,j) <= Dmask) then + mask(i+ibuf,j+jbuf) = 0 + else + mask(i+ibuf,j+jbuf) = 1 + endif + enddo ; enddo + + ! fill in buffer cells + + if (reentrant(1)) then ! REENTRANT_X + mask(1:ibuf, :) = mask(nx+1:nx+ibuf, :) + mask(ibuf+nx+1:nx+2*ibuf, :) = mask(ibuf+1:2*ibuf, :) + endif + + if (reentrant(2)) then ! REENTRANT_Y + mask(:, 1:jbuf) = mask(:, ny+1:ny+jbuf) + mask(:, jbuf+ny+1:ny+2*jbuf) = mask(:, jbuf+1:2*jbuf) + endif + + if (tripolar_N) then ! TRIPOLAR_N + do i=1,nx+2*ibuf + do j=1,jbuf + mask(i, jbuf+ny+j) = mask(nx+2*ibuf+1-i, jbuf+ny+1-j) + enddo + enddo + endif + + ! Tripolar Stitch Fix: In cases where masking is asymmetrical across the tripolar stitch, there's a possibility + ! that certain unmasked blocks won't be able to obtain grid metrics from the halo points. This occurs when the + ! neighboring block on the opposite side of the tripolar stitch is masked. As a consequence, certain metrics like + ! dxT and dyT may be calculated through extrapolation (refer to extrapolate_metric), potentially leading to the + ! generation of non-positive values. This can result in divide-by-zero errors elsewhere, e.g., in MOM_hor_visc.F90. + ! Currently, the safest and most general solution is to prohibit masking along the tripolar stitch: + if (tripolar_N) then + mask(:, jbuf+ny) = 1 + endif + + glob_ocn_frac = real(sum(mask(1+ibuf:nx+ibuf, 1+jbuf:ny+jbuf))) / (nx * ny) + + ! Iteratively check for all possible division counts starting from the upper bound of npes/glob_ocn_frac, + ! which is over-optimistic for realistic domains, but may be satisfied with idealized domains. + do p = ceiling(npes/glob_ocn_frac), npes, -1 + + ! compute the layout for the current division count, p + call MOM_define_layout(n_global, p, layout) + + ! don't bother checking this p if the aspect ratio is extreme + r_p = (real(nx)/layout(1)) / (real(ny)/layout(2)) + if ( r_p * r_extreme < 1 .or. r_extreme < r_p ) cycle + + ! Get the number of masked_blocks for this particular division count + call determine_land_blocks(mask, nx, ny, layout(1), layout(2), ibuf, jbuf, num_masked_blocks) + + ! If we can eliminate enough blocks to reach the target npes, adopt + ! this p (and the associated layout) and terminate the iteration. + if (p-num_masked_blocks <= npes) then + call MOM_error(NOTE, "Found the optimum layout for auto-masking. Terminating iteration...") + exit + endif + enddo + + if (num_masked_blocks == 0) then + call MOM_error(FATAL, "Couldn't auto-eliminate any land blocks. Try to increase the number "//& + "of MOM6 PEs or set AUTO_MASKTABLE to False.") + endif + + ! Call determine_land_blocks once again, this time to retrieve and write out the mask_table. + allocate(mask_table(num_masked_blocks,2)) + call determine_land_blocks(mask, nx, ny, layout(1), layout(2), ibuf, jbuf, num_masked_blocks, mask_table) + call write_auto_mask_file(mask_table, layout, npes, filename) + deallocate(mask_table) + deallocate(mask) + +end subroutine gen_auto_mask_table + +!> Given a number of domain divisions, compute the max number of land blocks that can be eliminated, +!! and return the resulting mask table if requested. +subroutine determine_land_blocks(mask, nx, ny, idiv, jdiv, ibuf, jbuf, num_masked_blocks, mask_table) + integer, dimension(:,:), intent(in) :: mask !< cell masks based on depth and MINIMUM_DEPTH + integer, intent(in) :: nx !< Total number of gridpoints in x-dir (global) + integer, intent(in) :: ny !< Total number of gridpoints in y-dir (global) + integer, intent(in) :: idiv !< number of divisions along x-dir + integer, intent(in) :: jdiv !< number of divisions along y-dir + integer, intent(in) :: ibuf !< number of buffer cells in x-dir. + !! (not necessarily the same as NIHALO) + integer, intent(in) :: jbuf !< number of buffer cells in y-dir. + !! (not necessarily the same as NJHALO) + integer, intent(out) :: num_masked_blocks !< the final number of masked blocks + integer, intent(out), optional :: mask_table(:,:) !< the resulting array of mask_table + ! integer + integer, dimension(idiv) :: ibegin !< The starting index of each division along x axis + integer, dimension(idiv) :: iend !< The ending index of each division along x axis + integer, dimension(jdiv) :: jbegin !< The starting index of each division along y axis + integer, dimension(jdiv) :: jend !< The ending index of each division along y axis + integer :: i, j, ib, ie, jb,je + + call compute_extent(1, nx, idiv, ibegin, iend) + call compute_extent(1, ny, jdiv, jbegin, jend) + + num_masked_blocks = 0 + + do i=1,idiv + ib = ibegin(i) + ie = iend(i) + 2 * ibuf + do j=1,jdiv + jb = jbegin(j) + je = jend(j) + 2 * jbuf + + if (any(mask(ib:ie,jb:je)==1)) cycle + + num_masked_blocks = num_masked_blocks + 1 + + if (present(mask_table)) then + if ( num_masked_blocks > size(mask_table, dim=1)) then + call MOM_error(FATAL, "The mask_table argument passed to determine_land_blocks() has insufficient size.") + endif + + mask_table(num_masked_blocks,1) = i + mask_table(num_masked_blocks,2) = j + endif + enddo + enddo + +end subroutine determine_land_blocks + +!> Write out the auto-generated mask information to a file in the run directory. +subroutine write_auto_mask_file(mask_table, layout, npes, filename) + integer, intent(in) :: mask_table(:,:) !> mask table array to be written out. + integer, dimension(2), intent(in) :: layout !> PE layout + integer, intent(in) :: npes !> Number of divisions (incl. eliminated ones) + character(len=:), allocatable, intent(in) :: filename !> file name for the mask_table to be written + ! local + integer :: file_ascii= -1 !< The unit number of the auto-generated mask_file file. + integer :: true_num_masked_blocks + integer :: p + + ! Eliminate only enough blocks to ensure that the number of active blocks precisely matches the target npes. + true_num_masked_blocks = layout(1) * layout(2) - npes + + call open_ASCII_file(file_ascii, trim(filename), action=WRITEONLY_FILE) + write(file_ascii, '(I0)'), true_num_masked_blocks + write(file_ascii, '(I0,",",I0)'), layout(1), layout(2) + do p = 1, true_num_masked_blocks + write(file_ascii, '(I0,",",I0)'), mask_table(p,1), mask_table(p,2) + enddo + call close_file(file_ascii) +end subroutine write_auto_mask_file + end module MOM_domains diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index 8e0e58c1b6..b5ed3f91cf 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1276,7 +1276,7 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, forces_in, ! Set up the ice-shelf domain and grid wd_halos(:)=0 allocate(CS%Grid) - call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + call MOM_domains_init(CS%Grid%domain, CS%US, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& domain_name='MOM_Ice_Shelf_in') !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index 53615b0063..1fdf09e258 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -305,7 +305,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) CS%G => G allocate(CS%Grid) ! params NIHALO_ODA, NJHALO_ODA set the DA halo size - call MOM_domains_init(CS%Grid%Domain,PF,param_suffix='_ODA') + call MOM_domains_init(CS%Grid%Domain,CS%US,PF,param_suffix='_ODA') allocate(HI) call hor_index_init(CS%Grid%Domain, HI, PF) call verticalGridInit( PF, CS%GV, CS%US ) From eac3bb33c49a47e5d31a43fadede9e84eae50396 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 15 Dec 2023 16:34:56 -0500 Subject: [PATCH 507/629] +FIX_UNSPLIT_DT_VISC_BUG is now UNSPLIT_DT_VISC_BUG Renamed the runtime parameter FIX_UNSPLIT_DT_VISC_BUG to UNSPLIT_DT_VISC_BUG (with a switch between the meanings of true and false for the two parameters) for consistency with the syntax of other bug-fix flags in MOM6 and to partially address dev/gfdl MOM6 issue #237. Input parameter files need not be changed right away because MOM6 will still work if FIX_UNSPLIT_DT_VISC_BUG is specified instead of UNSPLIT_DT_VISC_BUG, but UNSPLIT_DT_VISC_BUG will be logged, so there are changes to the MOM_parameter_doc files. By default or with existing input parameter files, all answers are bitwise identical, and there is error handling if inconsistent settings of FIX_UNSPLIT_DT_VISC_BUG and UNSPLIT_DT_VISC_BUG are both specified. --- src/core/MOM_dynamics_unsplit.F90 | 57 ++++++++++++++++++----- src/core/MOM_dynamics_unsplit_RK2.F90 | 65 ++++++++++++++++++++------- 2 files changed, 94 insertions(+), 28 deletions(-) diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index c87e6e9958..f9e4aa0efe 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -65,7 +65,7 @@ module MOM_dynamics_unsplit use MOM_domains, only : pass_vector, pass_vector_start, pass_vector_complete use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_time_manager, only : time_type, real_to_time, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) @@ -116,13 +116,13 @@ module MOM_dynamics_unsplit real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] - logical :: use_correct_dt_visc !< If true, use the correct timestep in the viscous terms applied - !! in the first predictor step with the unsplit time stepping scheme, - !! and in the calculation of the turbulent mixed layer properties - !! for viscosity. The default should be true, but it is false. - logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: calculate_SAL !< If true, calculate self-attraction and loading. - logical :: use_tides !< If true, tidal forcing is enabled. + logical :: dt_visc_bug !< If false, use the correct timestep in viscous terms applied in the + !! first predictor step and in the calculation of the turbulent mixed + !! layer properties for viscosity. If this is true, an older incorrect + !! setting is used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -346,11 +346,11 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! up <- up + dt/2 d/dz visc d/dz up call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt + dt_visc = dt ; if (CS%dt_visc_bug) dt_visc = 0.5*dt call set_viscous_ML(u, v, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) - dt_visc = 0.5*dt ; if (CS%use_correct_dt_visc) dt_visc = dt_pred + dt_visc = dt_pred ; if (CS%dt_visc_bug) dt_visc = 0.5*dt call thickness_to_dz(h_av, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h_av, dz, forces, visc, tv, dt_visc, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(up, vp, h_av, forces, visc, dt_visc, CS%OBC, CS%ADp, CS%CDp, & @@ -630,6 +630,9 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" + logical :: use_correct_dt_visc + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -646,11 +649,41 @@ subroutine initialize_dyn_unsplit(u, v, h, Time, G, GV, US, param_file, diag, CS CS%diag => diag call log_version(param_file, mdl, version, "") - call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & + + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false., do_not_log=.true.) + ! This is used to test whether UNSPLIT_DT_VISC_BUG is being actively set. + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%dt_visc_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", use_correct_dt_visc, & "If true, use the correct timestep in the viscous terms applied in the first "//& "predictor step with the unsplit time stepping scheme, and in the calculation "//& "of the turbulent mixed layer properties for viscosity with unsplit or "//& - "unsplit_RK2.", default=.true.) + "unsplit_RK2.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = use_correct_dt_visc .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (use_correct_dt_visc .eqv. CS%dt_visc_bug)) then + ! UNSPLIT_DT_VISC_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "UNSPLIT_DT_VISC_BUG and FIX_UNSPLIT_DT_VISC_BUG are both being set "//& + "with inconsistent values. FIX_UNSPLIT_DT_VISC_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_UNSPLIT_DT_VISC_BUG is an obsolete parameter. "//& + "Use UNSPLIT_DT_VISC_BUG instead (noting that it has the opposite sense).") + CS%dt_visc_bug = .not.use_correct_dt_visc + endif + call log_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false.) + call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index b515229566..1c589f509c 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -64,7 +64,7 @@ module MOM_dynamics_unsplit_RK2 use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe use MOM_error_handler, only : MOM_set_verbosity -use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_get_input, only : directories use MOM_time_manager, only : time_type, time_type_to_real, operator(+) use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) @@ -114,18 +114,18 @@ module MOM_dynamics_unsplit_RK2 real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] - real :: be !< A nondimensional number from 0.5 to 1 that controls - !! the backward weighting of the time stepping scheme [nondim]. - real :: begw !< A nondimensional number from 0 to 1 that controls - !! the extent to which the treatment of gravity waves - !! is forward-backward (0) or simulated backward - !! Euler (1) [nondim]. 0 is often used. - logical :: use_correct_dt_visc !< If true, use the correct timestep in the calculation of the - !! turbulent mixed layer properties for viscosity. - !! The default should be true, but it is false. - logical :: debug !< If true, write verbose checksums for debugging purposes. - logical :: calculate_SAL !< If true, calculate self-attraction and loading. - logical :: use_tides !< If true, tidal forcing is enabled. + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim]. + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: dt_visc_bug !< If false, use the correct timestep in the calculation of the + !! turbulent mixed layer properties for viscosity. Otherwise if + !! this is true, an older incorrect setting is used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. logical :: module_is_initialized = .false. !< Record whether this module has been initialized. @@ -344,7 +344,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, ! up[n-1/2] <- up*[n-1/2] + dt/2 d/dz visc d/dz up[n-1/2] call cpu_clock_begin(id_clock_vertvisc) call enable_averages(dt, Time_local, CS%diag) - dt_visc = dt_pred ; if (CS%use_correct_dt_visc) dt_visc = dt + dt_visc = dt ; if (CS%dt_visc_bug) dt_visc = dt_pred call set_viscous_ML(u_in, v_in, h_av, tv, forces, visc, dt_visc, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) @@ -578,6 +578,9 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag character(len=48) :: flux_units ! This include declares and sets the variable "version". # include "version_variable.h" + logical :: use_correct_dt_visc + logical :: test_value ! This is used to determine whether a logical parameter is being set explicitly. + logical :: explicit_bug, explicit_fix ! These indicate which parameters are set explicitly. integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB @@ -610,11 +613,41 @@ subroutine initialize_dyn_unsplit_RK2(u, v, h, Time, G, GV, US, param_file, diag "If SPLIT is false and USE_RK2 is true, BEGW can be "//& "between 0 and 0.5 to damp gravity waves.", & units="nondim", default=0.0) - call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", CS%use_correct_dt_visc, & + + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false., do_not_log=.true.) + ! This is used to test whether UNSPLIT_DT_VISC_BUG is being explicitly set. + call get_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", test_value, default=.true., do_not_log=.true.) + explicit_bug = CS%dt_visc_bug .eqv. test_value + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", use_correct_dt_visc, & "If true, use the correct timestep in the viscous terms applied in the first "//& "predictor step with the unsplit time stepping scheme, and in the calculation "//& "of the turbulent mixed layer properties for viscosity with unsplit or "//& - "unsplit_RK2.", default=.true.) + "unsplit_RK2.", default=.true., do_not_log=.true.) + call get_param(param_file, mdl, "FIX_UNSPLIT_DT_VISC_BUG", test_value, default=.false., do_not_log=.true.) + explicit_fix = use_correct_dt_visc .eqv. test_value + + if (explicit_bug .and. explicit_fix .and. (use_correct_dt_visc .eqv. CS%dt_visc_bug)) then + ! UNSPLIT_DT_VISC_BUG is being explicitly set, and should not be changed. + call MOM_error(FATAL, "UNSPLIT_DT_VISC_BUG and FIX_UNSPLIT_DT_VISC_BUG are both being set "//& + "with inconsistent values. FIX_UNSPLIT_DT_VISC_BUG is an obsolete "//& + "parameter and should be removed.") + elseif (explicit_fix) then + call MOM_error(WARNING, "FIX_UNSPLIT_DT_VISC_BUG is an obsolete parameter. "//& + "Use UNSPLIT_DT_VISC_BUG instead (noting that it has the opposite sense).") + CS%dt_visc_bug = .not.use_correct_dt_visc + endif + call log_param(param_file, mdl, "UNSPLIT_DT_VISC_BUG", CS%dt_visc_bug, & + "If false, use the correct timestep in the viscous terms applied in the first "//& + "predictor step with the unsplit time stepping scheme, and in the calculation "//& + "of the turbulent mixed layer properties for viscosity with unsplit or "//& + "unsplit_RK2. If true, an older incorrect value is used.", & + default=.false.) + call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) From 2ea0ac32d18027bd213667846a0f6c7a3d099f63 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 12 Nov 2023 16:54:11 -0500 Subject: [PATCH 508/629] +Add MOM_dynamics_split_RK2b enabled by SPLIT_RK2B Add the new module MOM_dynamics_split_RK2b and calls to the routines in this module to MOM.F90. These calls are exercised when the run time parameter SPLIT_RK2B is true. For now, all answers are bitwise identical when this new code is being exercised, but there is a new module with multiple public interfaces and a new entry in many MOM_parameter_doc files. --- src/core/MOM.F90 | 55 +- src/core/MOM_dynamics_split_RK2b.F90 | 1842 ++++++++++++++++++++++++++ 2 files changed, 1887 insertions(+), 10 deletions(-) create mode 100644 src/core/MOM_dynamics_split_RK2b.F90 diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index bcba4d37c7..e1f31b7558 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -77,6 +77,9 @@ module MOM use MOM_dynamics_split_RK2, only : step_MOM_dyn_split_RK2, register_restarts_dyn_split_RK2 use MOM_dynamics_split_RK2, only : initialize_dyn_split_RK2, end_dyn_split_RK2 use MOM_dynamics_split_RK2, only : MOM_dyn_split_RK2_CS, remap_dyn_split_rk2_aux_vars +use MOM_dynamics_split_RK2b, only : step_MOM_dyn_split_RK2b, register_restarts_dyn_split_RK2b +use MOM_dynamics_split_RK2b, only : initialize_dyn_split_RK2b, end_dyn_split_RK2b +use MOM_dynamics_split_RK2b, only : MOM_dyn_split_RK2b_CS, remap_dyn_split_RK2b_aux_vars use MOM_dynamics_unsplit_RK2, only : step_MOM_dyn_unsplit_RK2, register_restarts_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : initialize_dyn_unsplit_RK2, end_dyn_unsplit_RK2 use MOM_dynamics_unsplit_RK2, only : MOM_dyn_unsplit_RK2_CS @@ -284,6 +287,9 @@ module MOM logical :: do_dynamics !< If false, does not call step_MOM_dyn_*. This is an !! undocumented run-time flag that is fragile. logical :: split !< If true, use the split time stepping scheme. + logical :: use_alt_split !< If true, use a version of the split explicit time stepping + !! with a heavier emphasis on consistent tranports between the + !! layered and barotroic variables. logical :: use_RK2 !< If true, use RK2 instead of RK3 in unsplit mode !! (i.e., no split between barotropic and baroclinic). logical :: interface_filter !< If true, apply an interface height filter immediately @@ -379,6 +385,8 @@ module MOM !< Pointer to the control structure used for the unsplit RK2 dynamics type(MOM_dyn_split_RK2_CS), pointer :: dyn_split_RK2_CSp => NULL() !< Pointer to the control structure used for the mode-split RK2 dynamics + type(MOM_dyn_split_RK2b_CS), pointer :: dyn_split_RK2b_CSp => NULL() + !< Pointer to the control structure used for an alternate version of the mode-split RK2 dynamics type(thickness_diffuse_CS) :: thickness_diffuse_CSp !< Pointer to the control structure used for the isopycnal height diffusive transport. !! This is also common referred to as Gent-McWilliams diffusion @@ -1220,10 +1228,17 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif endif - call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & - p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & - CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & - CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + if (CS%use_alt_split) then + call step_MOM_dyn_split_RK2b(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2b_CSp, calc_dtbt, CS%VarMix, & + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + else + call step_MOM_dyn_split_RK2(u, v, h, CS%tv, CS%visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, CS%uh, CS%vh, CS%uhtr, CS%vhtr, & + CS%eta_av_bc, G, GV, US, CS%dyn_split_RK2_CSp, calc_dtbt, CS%VarMix, & + CS%MEKE, CS%thickness_diffuse_CSp, CS%pbv, waves=waves) + endif if (showCallTree) call callTree_waypoint("finished step_MOM_dyn_split (step_MOM)") elseif (CS%do_dynamics) then ! ------------------------------------ not SPLIT @@ -1646,8 +1661,12 @@ subroutine step_MOM_thermo(CS, G, GV, US, u, v, h, tv, fluxes, dtdia, & if (allocated(tv%SpV_avg)) tv%valid_SpV_halo = -1 ! Record that SpV_avg is no longer valid. if (CS%remap_aux_vars) then - if (CS%split) & + if (CS%split .and. CS%use_alt_split) then + call remap_dyn_split_RK2b_aux_vars(G, GV, CS%dyn_split_RK2b_CSp, h_old_u, h_old_v, & + h_new_u, h_new_v, CS%ALE_CSp) + elseif (CS%split) then call remap_dyn_split_RK2_aux_vars(G, GV, CS%dyn_split_RK2_CSp, h_old_u, h_old_v, h_new_u, h_new_v, CS%ALE_CSp) + endif if (associated(CS%OBC)) then call pass_var(h, G%Domain, complete=.false.) @@ -2154,6 +2173,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) + call get_param(param_file, "MOM", "SPLIT_RK2B", CS%use_alt_split, & + "If true, use a version of the split explicit time stepping with a heavier "//& + "emphasis on consistent tranports between the layered and barotroic variables.", & + default=.false., do_not_log=.not.CS%split) if (CS%split) then CS%use_RK2 = .false. else @@ -2771,7 +2794,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & restart_CSp => CS%restart_CS call set_restart_fields(GV, US, param_file, CS, restart_CSp) - if (CS%split) then + if (CS%split .and. CS%use_alt_split) then + call register_restarts_dyn_split_RK2b(HI, GV, US, param_file, & + CS%dyn_split_RK2b_CSp, restart_CSp, CS%uh, CS%vh) + elseif (CS%split) then call register_restarts_dyn_split_RK2(HI, GV, US, param_file, & CS%dyn_split_RK2_CSp, restart_CSp, CS%uh, CS%vh) elseif (CS%use_RK2) then @@ -3157,12 +3183,19 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (CS%split) then allocate(eta(SZI_(G),SZJ_(G)), source=0.0) - call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + if (CS%use_alt_split) then + call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, restart_CSp, & + CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & + CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & + CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + else + call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & - CS%thickness_diffuse_CSp, & - CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & + CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) + endif if (CS%dtbt_reset_period > 0.0) then CS%dtbt_reset_interval = real_to_time(US%T_to_s*CS%dtbt_reset_period) ! Set dtbt_reset_time to be the next even multiple of dtbt_reset_interval. @@ -4116,7 +4149,9 @@ subroutine MOM_end(CS) if (CS%offline_tracer_mode) call offline_transport_end(CS%offline_CSp) - if (CS%split) then + if (CS%split .and. CS%use_alt_split) then + call end_dyn_split_RK2b(CS%dyn_split_RK2b_CSp) + elseif (CS%split) then call end_dyn_split_RK2(CS%dyn_split_RK2_CSp) elseif (CS%use_RK2) then call end_dyn_unsplit_RK2(CS%dyn_unsplit_RK2_CSp) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 new file mode 100644 index 0000000000..a289014313 --- /dev/null +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -0,0 +1,1842 @@ +!> Time step the adiabatic dynamic core of MOM using RK2 method with greater use of the +!! time-filtered velocities and less inheritance of tedencies from the previous step in the +!! predictor step than in the original MOM_dyanmics_split_RK2. +module MOM_dynamics_split_RK2b + +! This file is part of MOM6. See LICENSE.md for the license. + +use MOM_variables, only : vertvisc_type, thermo_var_ptrs, porous_barrier_type +use MOM_variables, only : BT_cont_type, alloc_bt_cont_type, dealloc_bt_cont_type +use MOM_variables, only : accel_diag_ptrs, ocean_internal_state, cont_diag_ptrs +use MOM_forcing_type, only : mech_forcing + +use MOM_checksum_packages, only : MOM_thermo_chksum, MOM_state_chksum, MOM_accel_chksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_COMPONENT, CLOCK_SUBCOMPONENT +use MOM_cpu_clock, only : CLOCK_MODULE_DRIVER, CLOCK_MODULE, CLOCK_ROUTINE +use MOM_diag_mediator, only : diag_mediator_init, enable_averages +use MOM_diag_mediator, only : disable_averaging, post_data, safe_alloc_ptr +use MOM_diag_mediator, only : post_product_u, post_product_sum_u +use MOM_diag_mediator, only : post_product_v, post_product_sum_v +use MOM_diag_mediator, only : register_diag_field, register_static_field +use MOM_diag_mediator, only : set_diag_mediator_grid, diag_ctrl, diag_update_remap_grids +use MOM_domains, only : To_South, To_West, To_All, CGRID_NE, SCALAR_PAIR +use MOM_domains, only : To_North, To_East, Omit_Corners +use MOM_domains, only : create_group_pass, do_group_pass, group_pass_type +use MOM_domains, only : start_group_pass, complete_group_pass, pass_var, pass_vector +use MOM_debugging, only : hchksum, uvchksum +use MOM_error_handler, only : MOM_error, MOM_mesg, FATAL, WARNING, is_root_pe +use MOM_error_handler, only : MOM_set_verbosity, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint +use MOM_file_parser, only : get_param, log_version, param_file_type +use MOM_get_input, only : directories +use MOM_io, only : vardesc, var_desc, EAST_FACE, NORTH_FACE +use MOM_restart, only : register_restart_field, register_restart_pair +use MOM_restart, only : query_initialized, set_initialized, save_restart +use MOM_restart, only : only_read_from_restarts +use MOM_restart, only : restart_init, is_new_run, MOM_restart_CS +use MOM_time_manager, only : time_type, time_type_to_real, operator(+) +use MOM_time_manager, only : operator(-), operator(>), operator(*), operator(/) + +use MOM_ALE, only : ALE_CS, ALE_remap_velocities +use MOM_barotropic, only : barotropic_init, btstep, btcalc, bt_mass_source +use MOM_barotropic, only : register_barotropic_restarts, set_dtbt, barotropic_CS +use MOM_barotropic, only : barotropic_end +use MOM_boundary_update, only : update_OBC_data, update_OBC_CS +use MOM_continuity, only : continuity, continuity_CS +use MOM_continuity, only : continuity_init, continuity_stencil +use MOM_CoriolisAdv, only : CorAdCalc, CoriolisAdv_CS +use MOM_CoriolisAdv, only : CoriolisAdv_init, CoriolisAdv_end +use MOM_debugging, only : check_redundant +use MOM_grid, only : ocean_grid_type +use MOM_hor_index, only : hor_index_type +use MOM_hor_visc, only : horizontal_viscosity, hor_visc_CS +use MOM_hor_visc, only : hor_visc_init, hor_visc_end +use MOM_interface_heights, only : thickness_to_dz, find_col_avg_SpV +use MOM_lateral_mixing_coeffs, only : VarMix_CS +use MOM_MEKE_types, only : MEKE_type +use MOM_open_boundary, only : ocean_OBC_type, radiation_open_bdry_conds +use MOM_open_boundary, only : open_boundary_zero_normal_flow, open_boundary_query +use MOM_open_boundary, only : open_boundary_test_extern_h, update_OBC_ramp +use MOM_PressureForce, only : PressureForce, PressureForce_CS +use MOM_PressureForce, only : PressureForce_init +use MOM_set_visc, only : set_viscous_ML, set_visc_CS +use MOM_thickness_diffuse, only : thickness_diffuse_CS +use MOM_self_attr_load, only : SAL_CS +use MOM_self_attr_load, only : SAL_init, SAL_end +use MOM_tidal_forcing, only : tidal_forcing_CS +use MOM_tidal_forcing, only : tidal_forcing_init, tidal_forcing_end +use MOM_unit_scaling, only : unit_scale_type +use MOM_vert_friction, only : vertvisc, vertvisc_coef, vertvisc_remnant +use MOM_vert_friction, only : vertvisc_init, vertvisc_end, vertvisc_CS +use MOM_vert_friction, only : updateCFLtruncationValue, vertFPmix +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units +use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units +use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF +use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS +use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS +use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member + +implicit none ; private + +#include + +!> MOM_dynamics_split_RK2b module control structure +type, public :: MOM_dyn_split_RK2b_CS ; private + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: & + CAu, & !< CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + CAu_pred, & !< The predictor step value of CAu = f*v - u.grad(u) [L T-2 ~> m s-2] + PFu, & !< PFu = -dM/dx [L T-2 ~> m s-2] + PFu_Stokes, & !< PFu_Stokes = -d/dx int_r (u_L*duS/dr) [L T-2 ~> m s-2] + diffu !< Zonal acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: & + CAv, & !< CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + CAv_pred, & !< The predictor step value of CAv = -f*u - u.grad(v) [L T-2 ~> m s-2] + PFv, & !< PFv = -dM/dy [L T-2 ~> m s-2] + PFv_Stokes, & !< PFv_Stokes = -d/dy int_r (v_L*dvS/dr) [L T-2 ~> m s-2] + diffv !< Meridional acceleration due to convergence of the along-isopycnal stress tensor [L T-2 ~> m s-2] + + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: visc_rem_u + !< Both the fraction of the zonal momentum originally in a + !! layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_accel_bt + !< The zonal layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: visc_rem_v + !< Both the fraction of the meridional momentum originally in + !! a layer that remains after a time-step of viscosity, and the + !! fraction of a time-step worth of a barotropic acceleration + !! that a layer experiences after viscosity is applied [nondim]. + !! Nondimensional between 0 (at the bottom) and 1 (far above). + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_accel_bt + !< The meridional layer accelerations due to the difference between + !! the barotropic accelerations and the baroclinic accelerations + !! that were fed into the barotopic calculation [L T-2 ~> m s-2] + + ! The following variables are only used with the split time stepping scheme. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta !< Instantaneous free surface height (in Boussinesq + !! mode) or column mass anomaly (in non-Boussinesq + !! mode) [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_,NKMEM_) :: u_av !< layer x-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_,NKMEM_) :: v_av !< layer y-velocity with vertical mean replaced by + !! time-mean barotropic velocity over a baroclinic + !! timestep [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: h_av !< arithmetic mean of two successive layer + !! thicknesses [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_PF !< instantaneous SSH used in calculating PFu and + !! PFv [H ~> m or kg m-2] + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: uhbt !< average x-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! uhbt is roughly equal to the vertical sum of uh. + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: vhbt !< average y-volume or mass flux determined by the + !! barotropic solver [H L2 T-1 ~> m3 s-1 or kg s-1]. + !! vhbt is roughly equal to vertical sum of vh. + real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure + !! anomaly in each layer due to free surface height + !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge + type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure + + real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + real, pointer, dimension(:,:) :: tauy_bot => NULL() !< frictional y-bottom stress from the ocean + !! to the seafloor [R L Z T-2 ~> Pa] + type(BT_cont_type), pointer :: BT_cont => NULL() !< A structure with elements that describe the + !! effective summed open face areas as a function + !! of barotropic flow. + + logical :: split_bottom_stress !< If true, provide the bottom stress + !! calculated by the vertical viscosity to the + !! barotropic solver. + logical :: calc_dtbt !< If true, calculate the barotropic time-step + !! dynamically. + logical :: store_CAu !< If true, store the Coriolis and advective accelerations at the + !! end of the timestep for use in the next predictor step. + logical :: CAu_pred_stored !< If true, the Coriolis and advective accelerations at the + !! end of the timestep have been stored for use in the next + !! predictor step. This is used to accomodate various generations + !! of restart files. + logical :: calculate_SAL !< If true, calculate self-attraction and loading. + logical :: use_tides !< If true, tidal forcing is enabled. + logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D + !! variables that are needed to reproduce across restarts, + !! similarly to what is done with the primary state variables. + + real :: be !< A nondimensional number from 0.5 to 1 that controls + !! the backward weighting of the time stepping scheme [nondim] + real :: begw !< A nondimensional number from 0 to 1 that controls + !! the extent to which the treatment of gravity waves + !! is forward-backward (0) or simulated backward + !! Euler (1) [nondim]. 0 is often used. + logical :: debug !< If true, write verbose checksums for debugging purposes. + logical :: debug_OBC !< If true, do debugging calls for open boundary conditions. + logical :: fpmix = .false. !< If true, applies profiles of momentum flux magnitude and direction. + logical :: module_is_initialized = .false. !< Record whether this module has been initialized. + + !>@{ Diagnostic IDs + integer :: id_uold = -1, id_vold = -1 + integer :: id_uh = -1, id_vh = -1 + integer :: id_umo = -1, id_vmo = -1 + integer :: id_umo_2d = -1, id_vmo_2d = -1 + integer :: id_PFu = -1, id_PFv = -1 + integer :: id_CAu = -1, id_CAv = -1 + integer :: id_ueffA = -1, id_veffA = -1 + ! integer :: id_hf_PFu = -1, id_hf_PFv = -1 + integer :: id_h_PFu = -1, id_h_PFv = -1 + integer :: id_hf_PFu_2d = -1, id_hf_PFv_2d = -1 + integer :: id_intz_PFu_2d = -1, id_intz_PFv_2d = -1 + integer :: id_PFu_visc_rem = -1, id_PFv_visc_rem = -1 + ! integer :: id_hf_CAu = -1, id_hf_CAv = -1 + integer :: id_h_CAu = -1, id_h_CAv = -1 + integer :: id_hf_CAu_2d = -1, id_hf_CAv_2d = -1 + integer :: id_intz_CAu_2d = -1, id_intz_CAv_2d = -1 + integer :: id_CAu_visc_rem = -1, id_CAv_visc_rem = -1 + integer :: id_deta_dt = -1 + + ! Split scheme only. + integer :: id_uav = -1, id_vav = -1 + integer :: id_u_BT_accel = -1, id_v_BT_accel = -1 + ! integer :: id_hf_u_BT_accel = -1, id_hf_v_BT_accel = -1 + integer :: id_h_u_BT_accel = -1, id_h_v_BT_accel = -1 + integer :: id_hf_u_BT_accel_2d = -1, id_hf_v_BT_accel_2d = -1 + integer :: id_intz_u_BT_accel_2d = -1, id_intz_v_BT_accel_2d = -1 + integer :: id_u_BT_accel_visc_rem = -1, id_v_BT_accel_visc_rem = -1 + !>@} + + type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to regulate the + !! timing of diagnostic output. + type(accel_diag_ptrs), pointer :: ADp => NULL() !< A structure pointing to the various + !! accelerations in the momentum equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + type(accel_diag_ptrs), pointer :: AD_pred => NULL() !< A structure pointing to the various + !! predictor step accelerations in the momentum equations, + !! which can be used to debug truncations. + type(cont_diag_ptrs), pointer :: CDp => NULL() !< A structure with pointers to various + !! terms in the continuity equations, + !! which can later be used to calculate + !! derived diagnostics like energy budgets. + + ! The remainder of the structure points to child subroutines' control structures. + !> A pointer to the horizontal viscosity control structure + type(hor_visc_CS) :: hor_visc + !> A pointer to the continuity control structure + type(continuity_CS) :: continuity_CSp + !> The CoriolisAdv control structure + type(CoriolisAdv_CS) :: CoriolisAdv + !> A pointer to the PressureForce control structure + type(PressureForce_CS) :: PressureForce_CSp + !> A pointer to a structure containing interface height diffusivities + type(vertvisc_CS), pointer :: vertvisc_CSp => NULL() + !> A pointer to the set_visc control structure + type(set_visc_CS), pointer :: set_visc_CSp => NULL() + !> A pointer to the barotropic stepping control structure + type(barotropic_CS) :: barotropic_CSp + !> A pointer to the SAL control structure + type(SAL_CS) :: SAL_CSp + !> A pointer to the tidal forcing control structure + type(tidal_forcing_CS) :: tides_CSp + !> A pointer to the ALE control structure. + type(ALE_CS), pointer :: ALE_CSp => NULL() + + type(ocean_OBC_type), pointer :: OBC => NULL() !< A pointer to an open boundary + !! condition type that specifies whether, where, and what open boundary + !! conditions are used. If no open BCs are used, this pointer stays + !! nullified. Flather OBCs use open boundary_CS as well. + !> A pointer to the update_OBC control structure + type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() + + type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass + type(group_pass_type) :: pass_uv !< Structure for group halo pass + type(group_pass_type) :: pass_h !< Structure for group halo pass + type(group_pass_type) :: pass_av_uvh !< Structure for group halo pass + +end type MOM_dyn_split_RK2b_CS + + +public step_MOM_dyn_split_RK2b +public register_restarts_dyn_split_RK2b +public initialize_dyn_split_RK2b +public remap_dyn_split_RK2b_aux_vars +public end_dyn_split_RK2b + +!>@{ CPU time clock IDs +integer :: id_clock_Cor, id_clock_pres, id_clock_vertvisc +integer :: id_clock_horvisc, id_clock_mom_update +integer :: id_clock_continuity, id_clock_thick_diff +integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce +integer :: id_clock_pass, id_clock_pass_init +!>@} + +contains + +!> RK2 splitting for time stepping MOM adiabatic dynamics +subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, forces, & + p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, & + G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, Waves) + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: u_inst !< Zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: v_inst !< Meridional velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type + type(vertvisc_type), intent(inout) :: visc !< Vertical visc, bottom drag, and related + type(time_type), intent(in) :: Time_local !< Model time at end of time step + real, intent(in) :: dt !< Baroclinic dynamics time step [T ~> s] + type(mech_forcing), intent(in) :: forces !< A structure with the driving mechanical forces + real, dimension(:,:), pointer :: p_surf_begin !< Surface pressure at the start of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(:,:), pointer :: p_surf_end !< Surface pressure at the end of this dynamic + !! time step [R L2 T-2 ~> Pa] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + target, intent(inout) :: uh !< Zonal volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< Meridional volume or mass transport + !! [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: uhtr !< Accumulated zonal volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: vhtr !< Accumulated meridional volume or mass transport + !! since last tracer advection [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJ_(G)), intent(out) :: eta_av !< Free surface height or column mass + !! averaged over time step [H ~> m or kg m-2] + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< Module control structure + logical, intent(in) :: calc_dtbt !< If true, recalculate the barotropic time step + type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to a structure containing + !! interface height diffusivities + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + type(wave_parameters_CS), optional, pointer :: Waves !< A pointer to a structure containing + !! fields related to the surface wave conditions + + ! local variables + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_bc_accel ! The summed zonal baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_bc_accel ! The summed meridional baroclinic accelerations + ! of each layer calculated by the non-barotropic + ! part of the model [L T-2 ~> m s-2] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in ! The zonal mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! The meridional mass transports that would be + ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] + + real, dimension(SZI_(G),SZJ_(G)) :: eta_pred ! The predictor value of the free surface height + ! or column mass [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)) :: SpV_avg ! The column averaged specific volume [R-1 ~> m3 kg-1] + real, dimension(SZI_(G),SZJ_(G)) :: deta_dt ! A diagnostic of the time derivative of the free surface + ! height or column mass [H T-1 ~> m s-1 or kg m-2 s-1] + + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: u_old_rad_OBC ! The starting zonal velocities, which are + ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: v_old_rad_OBC ! The starting meridional velocities, which are + ! saved for use in the Flather open boundary condition code [L T-1 ~> m s-1] + + ! GMM, TODO: make these allocatable? + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uold ! u-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vold ! v-velocity before vert_visc is applied, for fpmix + ! [L T-1 ~> m s-1] + real :: pres_to_eta ! A factor that converts pressures to the units of eta + ! [H T2 R-1 L-2 ~> m Pa-1 or kg m-2 Pa-1] + real, pointer, dimension(:,:) :: & + p_surf => NULL(), & ! A pointer to the surface pressure [R L2 T-2 ~> Pa] + eta_PF_start => NULL(), & ! The value of eta that corresponds to the starting pressure + ! for the barotropic solver [H ~> m or kg m-2] + taux_bot => NULL(), & ! A pointer to the zonal bottom stress in some cases [R L Z T-2 ~> Pa] + tauy_bot => NULL(), & ! A pointer to the meridional bottom stress in some cases [R L Z T-2 ~> Pa] + ! This pointer is just used as shorthand for CS%eta. + eta => NULL() ! A pointer to the instantaneous free surface height (in Boussinesq + ! mode) or column mass anomaly (in non-Boussinesq mode) [H ~> m or kg m-2] + + real, pointer, dimension(:,:,:) :: & + ! These pointers are used to alter which fields are passed to btstep with various options: + u_ptr => NULL(), & ! A pointer to a zonal velocity [L T-1 ~> m s-1] + v_ptr => NULL(), & ! A pointer to a meridional velocity [L T-1 ~> m s-1] + uh_ptr => NULL(), & ! A pointer to a zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + vh_ptr => NULL(), & ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + ! These pointers are just used as shorthand for CS%u_av, CS%v_av, and CS%h_av. + u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. + v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. + h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + + real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] + real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. + real :: Idt_bc ! Inverse of the baroclinic timestep [T-1 ~> s-1] + logical :: dyn_p_surf + logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the + ! relative weightings of the layers in calculating + ! the barotropic accelerations. + logical :: Use_Stokes_PGF ! If true, add Stokes PGF to hydrostatic PGF + !---For group halo pass + logical :: showCallTree, sym + + integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz + integer :: cont_stencil, obc_stencil + + 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 + u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta + + Idt_bc = 1.0 / dt + + sym = G%Domain%symmetric ! switch to include symmetric domain in checksums + + showCallTree = callTree_showQuery() + if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2b(), MOM_dynamics_split_RK2b.F90") + + !$OMP parallel do default(shared) + do k=1,nz + do j=G%jsd,G%jed ; do i=G%isdB,G%iedB ; up(i,j,k) = 0.0 ; enddo ; enddo + do j=G%jsdB,G%jedB ; do i=G%isd,G%ied ; vp(i,j,k) = 0.0 ; enddo ; enddo + do j=G%jsd,G%jed ; do i=G%isd,G%ied ; hp(i,j,k) = h(i,j,k) ; enddo ; enddo + enddo + + ! Update CFL truncation value as function of time + call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) + + if (CS%debug) then + call MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) + call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) + 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) + if (dyn_p_surf) then + p_surf => p_surf_end + call safe_alloc_ptr(eta_PF_start,G%isd,G%ied,G%jsd,G%jed) + eta_PF_start(:,:) = 0.0 + else + p_surf => forces%p_surf + endif + + if (associated(CS%OBC)) then + if (CS%debug_OBC) call open_boundary_test_extern_h(G, GV, CS%OBC, h) + + ! Update OBC ramp value as function of time + call update_OBC_ramp(Time_local, CS%OBC, US) + + do k=1,nz ; do j=G%jsd,G%jed ; do I=G%IsdB,G%IedB + u_old_rad_OBC(I,j,k) = u_av(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=G%JsdB,G%JedB ; do i=G%isd,G%ied + v_old_rad_OBC(i,J,k) = v_av(i,J,k) + enddo ; enddo ; enddo + endif + + BT_cont_BT_thick = .false. + if (associated(CS%BT_cont)) BT_cont_BT_thick = & + (allocated(CS%BT_cont%h_u) .and. allocated(CS%BT_cont%h_v)) + + if (CS%split_bottom_stress) then + taux_bot => CS%taux_bot ; tauy_bot => CS%tauy_bot + endif + + !--- begin set up for group halo pass + + cont_stencil = continuity_stencil(CS%continuity_CSp) + obc_stencil = 2 + if (associated(CS%OBC)) then + if (CS%OBC%oblique_BCs_exist_globally) obc_stencil = 3 + endif + call cpu_clock_begin(id_clock_pass) + call create_group_pass(CS%pass_eta, eta, G%Domain, halo=1) + call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & + To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + + call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call cpu_clock_end(id_clock_pass) + !--- end set up for group halo pass + + +! PFu = d/dx M(h,T,S) +! pbce = dM/deta + if (CS%begw == 0.0) call enable_averages(dt, Time_local, CS%diag) + call cpu_clock_begin(id_clock_pres) + call PressureForce(h, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + if (dyn_p_surf) then + pres_to_eta = 1.0 / (GV%g_Earth * GV%H_to_RZ) + !$OMP parallel do default(shared) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + eta_PF_start(i,j) = CS%eta_PF(i,j) - pres_to_eta * (p_surf_begin(i,j) - p_surf_end(i,j)) + enddo ; enddo + endif + ! Stokes shear force contribution to pressure gradient + Use_Stokes_PGF = present(Waves) + if (Use_Stokes_PGF) then + Use_Stokes_PGF = associated(Waves) + if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF + if (Use_Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + + ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv + ! will therefore report the sum total PGF and we avoid other + ! modifications in the code. The PFu_Stokes is output within the waves routines. + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo + enddo + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo + enddo + endif + endif + endif + call cpu_clock_end(id_clock_pres) + call disable_averaging(CS%diag) + if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)") + + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + if (associated(CS%OBC) .and. CS%debug_OBC) & + call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) + + if (G%nonblocking_updates) & + call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + if (.not.CS%CAu_pred_stored) then + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms, + ! if it was not already stored from the end of the previous time step. + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") + endif + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%CAu_pred(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%CAv_pred(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("pre-btstep accel", CS%CAu_pred, CS%CAv_pred, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + call check_redundant("pre-btstep CS%CA ", CS%CAu_pred, CS%CAv_pred, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + + call cpu_clock_begin(id_clock_vertvisc) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k)) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k)) + enddo ; enddo + enddo + + call enable_averages(dt, Time_local, CS%diag) + call set_viscous_ML(u_inst, v_inst, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call disable_averaging(CS%diag) + + if (CS%debug) then + call uvchksum("before vertvisc: up", up, vp, G%HI, haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + endif + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc_coef (step_MOM_dyn_split_RK2b)") + + + call cpu_clock_begin(id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_eta, G%Domain) + call start_group_pass(CS%pass_visc_rem, G%Domain) + else + call do_group_pass(CS%pass_eta, G%Domain) + call do_group_pass(CS%pass_visc_rem, G%Domain) + endif + call cpu_clock_end(id_clock_pass) + + call cpu_clock_begin(id_clock_btcalc) + ! Calculate the relative layer weights for determining barotropic quantities. + if (.not.BT_cont_BT_thick) & + call btcalc(h, G, GV, CS%barotropic_CSp, OBC=CS%OBC) + call bt_mass_source(h, eta, .true., G, GV, CS%barotropic_CSp) + + SpV_avg(:,:) = 0.0 + if ((.not.GV%Boussinesq) .and. associated(CS%OBC)) then + ! Determine the column average specific volume if it is needed due to the + ! use of Flather open boundary conditions in non-Boussinesq mode. + if (open_boundary_query(CS%OBC, apply_Flather_OBC=.true.)) & + call find_col_avg_SpV(h, SpV_avg, tv, G, GV, US) + endif + call cpu_clock_end(id_clock_btcalc) + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + +! u_accel_bt = layer accelerations due to barotropic solver + call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + visc_rem_u=CS%visc_rem_u, visc_rem_v=CS%visc_rem_v, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + endif + if (showCallTree) call callTree_wayPoint("done with continuity[BT_cont] (step_MOM_dyn_split_RK2b)") + + uh_ptr => uh_in ; vh_ptr => vh_in ; u_ptr => u_inst ; v_ptr => v_inst + + call cpu_clock_begin(id_clock_btstep) + if (calc_dtbt) call set_dtbt(G, GV, US, CS%barotropic_CSp, eta, CS%pbce) + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the predictor step call to btstep. + ! The CS%ADp argument here stores the weights for certain integrated diagnostics. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr) + if (showCallTree) call callTree_leave("btstep()") + call cpu_clock_end(id_clock_btstep) + +! up = u + dt_pred*( u_bc_accel + u_accel_bt ) + dt_pred = dt * CS%be + call cpu_clock_begin(id_clock_mom_update) + + !$OMP parallel do default(shared) + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt_pred * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + do j=js,je ; do I=Isq,Ieq + up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt_pred * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + 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_MKS) + call uvchksum("Predictor 1 [uv]h", uh, vh, G%HI,haloshift=2, & + 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_inst, v_inst, 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_MKS*US%L_to_m**2*US%s_to_T) + endif + +! up <- up + dt_pred d/dz visc d/dz up +! u_av <- u_av + dt_pred d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + if (CS%debug) then + call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) + endif + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + uold(I,j,k) = up(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vold(i,J,k) = vp(i,J,k) + enddo ; enddo ; enddo + endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & + CS%OBC, VarMix) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + + if (CS%fpmix) then + hbl(:,:) = 0.0 + if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + if (ASSOCIATED(CS%energetic_PBL_CSp)) & + call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + call vertFPmix(up, vp, uold, vold, hbl, h, forces, & + dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt_pred, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uvp, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! hp = h + dt * div . uh + call cpu_clock_begin(id_clock_continuity) + call continuity(up, vp, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, & + u_av, v_av, BT_cont=CS%BT_cont) + call cpu_clock_end(id_clock_continuity) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") + + call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) + + if (associated(CS%OBC)) then + + if (CS%debug) & + call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt_pred) + + if (CS%debug) & + call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) + + ! These should be done with a pass that excludes uh & vh. +! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) + endif + + if (G%nonblocking_updates) then + call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + endif + + ! h_av = (h + hp)/2 + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) + enddo ; enddo ; enddo + + ! The correction phase of the time step starts here. + call enable_averages(dt, Time_local, CS%diag) + + ! Calculate a revised estimate of the free-surface height correction to be + ! used in the next call to btstep. This call is at this point so that + ! hp can be changed if CS%begw /= 0. + ! eta_cor = ... (hidden inside CS%barotropic_CSp) + call cpu_clock_begin(id_clock_btcalc) + call bt_mass_source(hp, eta_pred, .false., G, GV, CS%barotropic_CSp) + call cpu_clock_end(id_clock_btcalc) + + if (CS%begw /= 0.0) then + ! hp <- (1-begw)*h_in + begw*hp + ! Back up hp to the value it would have had after a time-step of + ! begw*dt. hp is not used again until recalculated by continuity. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-1,je+1 ; do i=is-1,ie+1 + hp(i,j,k) = (1.0-CS%begw)*h(i,j,k) + CS%begw*hp(i,j,k) + enddo ; enddo ; enddo + + ! PFu = d/dx M(hp,T,S) + ! pbce = dM/deta + call cpu_clock_begin(id_clock_pres) + call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & + CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) + ! Stokes shear force contribution to pressure gradient + Use_Stokes_PGF = present(Waves) + if (Use_Stokes_PGF) then + Use_Stokes_PGF = associated(Waves) + if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF + if (Use_Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz + do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo + enddo + do k=1,nz + do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo + enddo + endif + endif + endif + call cpu_clock_end(id_clock_pres) + if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2b)") + endif + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + + if (BT_cont_BT_thick) then + call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & + OBC=CS%OBC) + if (showCallTree) call callTree_wayPoint("done with btcalc[BT_cont_BT_thick] (step_MOM_dyn_split_RK2b)") + endif + + 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_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_MKS*US%L_to_m**2*US%s_to_T) + endif + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & + MEKE, Varmix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + ADp=CS%ADp) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") + +! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu, CS%CAv, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") + +! Calculate the momentum forcing terms for the barotropic equations. + +! u_bc_accel = CAu + PFu + diffu(u[n-1]) + call cpu_clock_begin(id_clock_btforce) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_bc_accel(I,j,k) = (CS%Cau(I,j,k) + CS%PFu(I,j,k)) + CS%diffu(I,j,k) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_bc_accel(i,J,k) = (CS%Cav(i,J,k) + CS%PFv(i,J,k)) + CS%diffv(i,J,k) + enddo ; enddo + enddo + if (associated(CS%OBC)) then + call open_boundary_zero_normal_flow(CS%OBC, G, GV, u_bc_accel, v_bc_accel) + endif + call cpu_clock_end(id_clock_btforce) + + if (CS%debug) then + call MOM_accel_chksum("corr pre-btstep accel", CS%CAu, CS%CAv, CS%PFu, CS%PFv, & + CS%diffu, CS%diffv, G, GV, US, CS%pbce, u_bc_accel, v_bc_accel, & + symmetric=sym) + call check_redundant("corr pre-btstep CS%CA ", CS%CAu, CS%CAv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%PF ", CS%PFu, CS%PFv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep CS%diff ", CS%diffu, CS%diffv, G, unscale=US%L_T2_to_m_s2) + call check_redundant("corr pre-btstep u_bc_accel ", u_bc_accel, v_bc_accel, G, unscale=US%L_T2_to_m_s2) + endif + + ! u_accel_bt = layer accelerations due to barotropic solver + ! pbce = dM/deta + call cpu_clock_begin(id_clock_btstep) + + uh_ptr => uh ; vh_ptr => vh ; u_ptr => u_av ; v_ptr => v_av + + if (showCallTree) call callTree_enter("btstep(), MOM_barotropic.F90") + ! This is the corrector step call to btstep. + call btstep(u_inst, v_inst, eta, dt, u_bc_accel, v_bc_accel, forces, CS%pbce, CS%eta_PF, u_av, v_av, & + CS%u_accel_bt, CS%v_accel_bt, eta_pred, CS%uhbt, CS%vhbt, G, GV, US, & + CS%barotropic_CSp, CS%visc_rem_u, CS%visc_rem_v, SpV_avg, CS%ADp, CS%OBC, CS%BT_cont, & + eta_PF_start, taux_bot, tauy_bot, uh_ptr, vh_ptr, u_ptr, v_ptr, etaav=eta_av) + if (CS%id_deta_dt>0) then + do j=js,je ; do i=is,ie ; deta_dt(i,j) = (eta_pred(i,j) - eta(i,j))*Idt_bc ; enddo ; enddo + endif + do j=js,je ; do i=is,ie ; eta(i,j) = eta_pred(i,j) ; enddo ; enddo + + call cpu_clock_end(id_clock_btstep) + if (showCallTree) call callTree_leave("btstep()") + + if (CS%debug) then + call check_redundant("u_accel_bt ", CS%u_accel_bt, CS%v_accel_bt, G, unscale=US%L_T2_to_m_s2) + endif + + ! u = u + dt*( u_bc_accel + u_accel_bt ) + call cpu_clock_begin(id_clock_mom_update) + !$OMP parallel do default(shared) + do k=1,nz + do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * & + (u_bc_accel(I,j,k) + CS%u_accel_bt(I,j,k))) + enddo ; enddo + do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * & + (v_bc_accel(i,J,k) + CS%v_accel_bt(i,J,k))) + enddo ; enddo + enddo + call cpu_clock_end(id_clock_mom_update) + + if (CS%debug) then + call uvchksum("Corrector 1 [uv]", u_inst, v_inst, 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_MKS) + call uvchksum("Corrector 1 [uv]h", uh, vh, G%HI, haloshift=2, & + symmetric=sym, scale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + ! call MOM_state_chksum("Corrector 1", u_inst, v_inst, 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, & + symmetric=sym) + endif + + ! u <- u + dt d/dz visc d/dz u + ! u_av <- u_av + dt d/dz visc d/dz u_av + call cpu_clock_begin(id_clock_vertvisc) + + if (CS%fpmix) then + uold(:,:,:) = 0.0 + vold(:,:,:) = 0.0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + uold(I,j,k) = u_inst(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + vold(i,J,k) = v_inst(i,J,k) + enddo ; enddo ; enddo + endif + + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) + + if (CS%fpmix) then + call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & + G, GV, US, CS%vertvisc_CSp, CS%OBC) + call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + endif + + if (G%nonblocking_updates) then + call cpu_clock_end(id_clock_vertvisc) + call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + call cpu_clock_begin(id_clock_vertvisc) + endif + call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) + call cpu_clock_end(id_clock_vertvisc) + if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") + +! Later, h_av = (h_in + h_out)/2, but for now use h_av to store h_in. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = h(i,j,k) + enddo ; enddo ; enddo + + call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + endif + + ! uh = u_av * h + ! h = h + dt * div . uh + ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. + call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + call cpu_clock_end(id_clock_continuity) + call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) + ! 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) + if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") + + if (G%nonblocking_updates) then + call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_av_uvh, G%domain, clock=id_clock_pass) + endif + + if (associated(CS%OBC)) then + call radiation_open_bdry_conds(CS%OBC, u_inst, u_old_rad_OBC, v_inst, v_old_rad_OBC, G, GV, US, dt) + endif + +! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k)) + enddo ; enddo ; enddo + + if (G%nonblocking_updates) & + call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) + + !$OMP parallel do default(shared) + do k=1,nz + do j=js-2,je+2 ; do I=Isq-2,Ieq+2 + uhtr(I,j,k) = uhtr(I,j,k) + uh(I,j,k)*dt + enddo ; enddo + do J=Jsq-2,Jeq+2 ; do i=is-2,ie+2 + vhtr(i,J,k) = vhtr(i,J,k) + vh(i,J,k)*dt + enddo ; enddo + enddo + + if (CS%store_CAu) then + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms + ! for use in the next time step, possibly after it has been vertically remapped. + call cpu_clock_begin(id_clock_Cor) + call disable_averaging(CS%diag) ! These calculations should not be used for diagnostics. + ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + CS%CAu_pred_stored = .true. + call enable_averages(dt, Time_local, CS%diag) ! Reenable the averaging + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") + else + CS%CAu_pred_stored = .false. + endif + + if (CS%fpmix) then + if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) + endif + + ! The time-averaged free surface height has already been set by the last call to btstep. + + ! Deallocate this memory to avoid a memory leak. ### We should revisit how this array is declared. -RWH + if (dyn_p_surf .and. associated(eta_PF_start)) deallocate(eta_PF_start) + + ! Here various terms used in to update the momentum equations are + ! offered for time averaging. + if (CS%id_PFu > 0) call post_data(CS%id_PFu, CS%PFu, CS%diag) + if (CS%id_PFv > 0) call post_data(CS%id_PFv, CS%PFv, CS%diag) + if (CS%id_CAu > 0) call post_data(CS%id_CAu, CS%CAu, CS%diag) + if (CS%id_CAv > 0) call post_data(CS%id_CAv, CS%CAv, CS%diag) + + ! Here the thickness fluxes are offered for time averaging. + if (CS%id_uh > 0) call post_data(CS%id_uh, uh, CS%diag) + if (CS%id_vh > 0) call post_data(CS%id_vh, vh, CS%diag) + if (CS%id_uav > 0) call post_data(CS%id_uav, u_av, CS%diag) + if (CS%id_vav > 0) call post_data(CS%id_vav, v_av, CS%diag) + if (CS%id_u_BT_accel > 0) call post_data(CS%id_u_BT_accel, CS%u_accel_bt, CS%diag) + if (CS%id_v_BT_accel > 0) call post_data(CS%id_v_BT_accel, CS%v_accel_bt, CS%diag) + + ! Calculate effective areas and post data + if (CS%id_ueffA > 0) then + ueffA(:,:,:) = 0 + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k) / up(I,j,k) + enddo ; enddo ; enddo + call post_data(CS%id_ueffA, ueffA, CS%diag) + endif + + if (CS%id_veffA > 0) then + veffA(:,:,:) = 0 + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k) / vp(i,J,k) + enddo ; enddo ; enddo + call post_data(CS%id_veffA, veffA, CS%diag) + endif + + ! Diagnostics of the fractional thicknesses times momentum budget terms + ! 3D diagnostics hf_PFu etc. are commented because there is no clarity on proper remapping grid option. + ! The code is retained for debugging purposes in the future. + !if (CS%id_hf_PFu > 0) call post_product_u(CS%id_hf_PFu, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_PFv > 0) call post_product_v(CS%id_hf_PFv, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_CAu > 0) call post_product_u(CS%id_hf_CAu, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_CAv > 0) call post_product_v(CS%id_hf_CAv, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + !if (CS%id_hf_u_BT_accel > 0) & + ! call post_product_u(CS%id_hf_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + !if (CS%id_hf_v_BT_accel > 0) & + ! call post_product_v(CS%id_hf_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for the vertical sum of layer thickness x prssure force accelerations + if (CS%id_intz_PFu_2d > 0) call post_product_sum_u(CS%id_intz_PFu_2d, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_PFv_2d > 0) call post_product_sum_v(CS%id_intz_PFv_2d, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for thickness-weighted vertically averaged prssure force accelerations + if (CS%id_hf_PFu_2d > 0) call post_product_sum_u(CS%id_hf_PFu_2d, CS%PFu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_PFv_2d > 0) call post_product_sum_v(CS%id_hf_PFv_2d, CS%PFv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + + ! Diagnostics for thickness x prssure force accelerations + if (CS%id_h_PFu > 0) call post_product_u(CS%id_h_PFu, CS%PFu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_PFv > 0) call post_product_v(CS%id_h_PFv, CS%PFv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of Coriolis acceleratations + if (CS%id_intz_CAu_2d > 0) call post_product_sum_u(CS%id_intz_CAu_2d, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_CAv_2d > 0) call post_product_sum_v(CS%id_intz_CAv_2d, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_CAu_2d > 0) call post_product_sum_u(CS%id_hf_CAu_2d, CS%CAu, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_CAv_2d > 0) call post_product_sum_v(CS%id_hf_CAv_2d, CS%CAv, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_CAu > 0) call post_product_u(CS%id_h_CAu, CS%CAu, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_CAv > 0) call post_product_v(CS%id_h_CAv, CS%CAv, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics of barotropic solver acceleratations + if (CS%id_intz_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_intz_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_intz_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_intz_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + if (CS%id_hf_u_BT_accel_2d > 0) & + call post_product_sum_u(CS%id_hf_u_BT_accel_2d, CS%u_accel_bt, CS%ADp%diag_hfrac_u, G, nz, CS%diag) + if (CS%id_hf_v_BT_accel_2d > 0) & + call post_product_sum_v(CS%id_hf_v_BT_accel_2d, CS%v_accel_bt, CS%ADp%diag_hfrac_v, G, nz, CS%diag) + if (CS%id_h_u_BT_accel > 0) & + call post_product_u(CS%id_h_u_BT_accel, CS%u_accel_bt, CS%ADp%diag_hu, G, nz, CS%diag) + if (CS%id_h_v_BT_accel > 0) & + call post_product_v(CS%id_h_v_BT_accel, CS%v_accel_bt, CS%ADp%diag_hv, G, nz, CS%diag) + + ! Diagnostics for momentum budget terms multiplied by visc_rem_[uv], + if (CS%id_PFu_visc_rem > 0) call post_product_u(CS%id_PFu_visc_rem, CS%PFu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_PFv_visc_rem > 0) call post_product_v(CS%id_PFv_visc_rem, CS%PFv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_CAu_visc_rem > 0) call post_product_u(CS%id_CAu_visc_rem, CS%CAu, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_CAv_visc_rem > 0) call post_product_v(CS%id_CAv_visc_rem, CS%CAv, CS%ADp%visc_rem_v, G, nz, CS%diag) + if (CS%id_u_BT_accel_visc_rem > 0) & + call post_product_u(CS%id_u_BT_accel_visc_rem, CS%u_accel_bt, CS%ADp%visc_rem_u, G, nz, CS%diag) + if (CS%id_v_BT_accel_visc_rem > 0) & + call post_product_v(CS%id_v_BT_accel_visc_rem, CS%v_accel_bt, CS%ADp%visc_rem_v, G, nz, CS%diag) + + ! Diagnostics related to changes in eta + if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) + + if (CS%debug) then + call MOM_state_chksum("Corrector ", u_inst, v_inst, 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_MKS) + ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) + endif + + if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2b()") + +end subroutine step_MOM_dyn_split_RK2b + +!> This subroutine sets up any auxiliary restart variables that are specific +!! to the split-explicit time stepping scheme. All variables registered here should +!! have the ability to be recreated if they are not present in a restart file. +subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_CS, uh, vh) + type(hor_index_type), intent(in) :: HI !< Horizontal index structure + type(verticalGrid_type), intent(in) :: GV !< ocean 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 + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, dimension(SZIB_(HI),SZJ_(HI),SZK_(GV)), & + target, intent(inout) :: uh !< zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(HI),SZJB_(HI),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + + character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name. + type(vardesc) :: vd(2) + character(len=48) :: thickness_units, flux_units + + integer :: isd, ied, jsd, jed, nz, IsdB, IedB, JsdB, JedB + + isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke + IsdB = HI%IsdB ; IedB = HI%IedB ; JsdB = HI%JsdB ; JedB = HI%JedB + + ! This is where a control structure specific to this module would be allocated. + if (associated(CS)) then + call MOM_error(WARNING, "register_restarts_dyn_split_RK2b called with an associated "// & + "control structure.") + return + endif + allocate(CS) + + ALLOC_(CS%diffu(IsdB:IedB,jsd:jed,nz)) ; CS%diffu(:,:,:) = 0.0 + ALLOC_(CS%diffv(isd:ied,JsdB:JedB,nz)) ; CS%diffv(:,:,:) = 0.0 + ALLOC_(CS%CAu(IsdB:IedB,jsd:jed,nz)) ; CS%CAu(:,:,:) = 0.0 + ALLOC_(CS%CAv(isd:ied,JsdB:JedB,nz)) ; CS%CAv(:,:,:) = 0.0 + ALLOC_(CS%CAu_pred(IsdB:IedB,jsd:jed,nz)) ; CS%CAu_pred(:,:,:) = 0.0 + ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0 + ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 + ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + + ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 + ALLOC_(CS%u_av(IsdB:IedB,jsd:jed,nz)) ; CS%u_av(:,:,:) = 0.0 + ALLOC_(CS%v_av(isd:ied,JsdB:JedB,nz)) ; CS%v_av(:,:,:) = 0.0 + ALLOC_(CS%h_av(isd:ied,jsd:jed,nz)) ; CS%h_av(:,:,:) = GV%Angstrom_H + + thickness_units = get_thickness_units(GV) + flux_units = get_flux_units(GV) + + call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & + "If true, calculate the Coriolis accelerations at the end of each "//& + "timestep for use in the predictor step of the next split RK2 timestep.", & + default=.true., do_not_log=.true.) + + if (GV%Boussinesq) then + call register_restart_field(CS%eta, "sfc", .false., restart_CS, & + longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) + else + call register_restart_field(CS%eta, "p_bot", .false., restart_CS, & + longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) + endif + + ! These are needed, either to calculate CAu and CAv or to calculate the velocity anomalies in + ! the barotropic solver's Coriolis terms. + vd(1) = var_desc("u2", "m s-1", "Auxiliary Zonal velocity", 'u', 'L') + vd(2) = var_desc("v2", "m s-1", "Auxiliary Meridional velocity", 'v', 'L') + call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T_to_m_s) + + if (CS%store_CAu) then + vd(1) = var_desc("CAu", "m s-2", "Zonal Coriolis and advactive acceleration", 'u', 'L') + vd(2) = var_desc("CAv", "m s-2", "Meridional Coriolis and advactive acceleration", 'v', 'L') + call register_restart_pair(CS%CAu_pred, CS%CAv_pred, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) + else + call register_restart_field(CS%h_av, "h2", .false., restart_CS, & + longname="Auxiliary Layer Thickness", units=thickness_units, conversion=GV%H_to_mks) + + vd(1) = var_desc("uh", flux_units, "Zonal thickness flux", 'u', 'L') + vd(2) = var_desc("vh", flux_units, "Meridional thickness flux", 'v', 'L') + call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS, & + conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) + endif + + vd(1) = var_desc("diffu", "m s-2", "Zonal horizontal viscous acceleration", 'u', 'L') + vd(2) = var_desc("diffv", "m s-2", "Meridional horizontal viscous acceleration", 'v', 'L') + call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS, & + conversion=US%L_T2_to_m_s2) + + call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) + +end subroutine register_restarts_dyn_split_RK2b + +!> This subroutine does remapping for the auxiliary restart variables that are used +!! with the split RK2 time stepping scheme. +subroutine remap_dyn_split_RK2b_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h_new_v, ALE_CSp) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_old_u !< Source grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_old_v !< Source grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h_new_u !< Destination grid thickness at zonal + !! velocity points [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(in) :: h_new_v !< Destination grid thickness at meridional + !! velocity points [H ~> m or kg m-2] + type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping + + if (.not.CS%remap_aux) return + + if (CS%store_CAu) then + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) + call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) + call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) + endif + + call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) + +end subroutine remap_dyn_split_RK2b_aux_vars + +!> This subroutine initializes all of the variables that are used by this +!! dynamic core, including diagnostics and the cpu clocks. +subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & + diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & + VarMix, MEKE, thickness_diffuse_CSp, & + OBC, update_OBC_CSp, ALE_CSp, set_visc, & + visc, dirs, ntrunc, pbv, calc_dtbt, cont_stencil) + type(ocean_grid_type), intent(inout) :: G !< ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + intent(inout) :: u !< zonal velocity [L T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] + 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)), & + target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + target, intent(inout) :: vh !< merid volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: eta !< free surface height or column mass [H ~> m or kg m-2] + type(time_type), target, intent(in) :: Time !< current model time + type(param_file_type), intent(in) :: param_file !< parameter file for parsing + type(diag_ctrl), target, intent(inout) :: diag !< to control diagnostics + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + type(MOM_restart_CS), intent(inout) :: restart_CS !< MOM restart control structure + real, intent(in) :: dt !< time step [T ~> s] + type(accel_diag_ptrs), target, intent(inout) :: Accel_diag !< points to momentum equation terms for + !! budget analysis + type(cont_diag_ptrs), target, intent(inout) :: Cont_diag !< points to terms in continuity equation + type(ocean_internal_state), intent(inout) :: MIS !< "MOM6 internal state" used to pass + !! diagnostic pointers + type(VarMix_CS), intent(inout) :: VarMix !< points to spatially variable viscosities + type(MEKE_type), intent(inout) :: MEKE !< MEKE fields + type(thickness_diffuse_CS), intent(inout) :: thickness_diffuse_CSp !< Pointer to the control structure + !! used for the isopycnal height diffusive transport. + type(ocean_OBC_type), pointer :: OBC !< points to OBC related fields + type(update_OBC_CS), pointer :: update_OBC_CSp !< points to OBC update related fields + type(ALE_CS), pointer :: ALE_CSp !< points to ALE control structure + type(set_visc_CS), target, intent(in) :: set_visc !< set_visc control structure + type(vertvisc_type), intent(inout) :: visc !< vertical viscosities, bottom drag, and related + type(directories), intent(in) :: dirs !< contains directory paths + integer, target, intent(inout) :: ntrunc !< A target for the variable that records + !! the number of times the velocity is + !! truncated (this should be 0). + logical, intent(out) :: calc_dtbt !< If true, recalculate the barotropic time step + type(porous_barrier_type), intent(in) :: pbv !< porous barrier fractional cell metrics + integer, intent(out) :: cont_stencil !< The stencil for thickness + !! from the continuity solver. + + ! local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_tmp ! A temporary copy of the layer thicknesses [H ~> m or kg m-2] + character(len=40) :: mdl = "MOM_dynamics_split_RK2b" ! This module's name. + ! This include declares and sets the variable "version". +# include "version_variable.h" + character(len=48) :: thickness_units, flux_units, eta_rest_name + type(group_pass_type) :: pass_av_h_uvh + logical :: debug_truncations + logical :: read_uv, read_h2 + + integer :: i, j, k, is, ie, js, je, isd, ied, jsd, jed, nz + integer :: IsdB, IedB, JsdB, JedB + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed + IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB + + if (.not.associated(CS)) call MOM_error(FATAL, & + "initialize_dyn_split_RK2b called with an unassociated control structure.") + if (CS%module_is_initialized) then + call MOM_error(WARNING, "initialize_dyn_split_RK2b called with a control "// & + "structure that has already been initialized.") + return + endif + CS%module_is_initialized = .true. + + CS%diag => diag + + call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "TIDES", CS%use_tides, & + "If true, apply tidal momentum forcing.", default=.false.) + call get_param(param_file, mdl, "CALCULATE_SAL", CS%calculate_SAL, & + "If true, calculate self-attraction and loading.", default=CS%use_tides) + call get_param(param_file, mdl, "BE", CS%be, & + "If SPLIT is true, BE determines the relative weighting "//& + "of a 2nd-order Runga-Kutta baroclinic time stepping "//& + "scheme (0.5) and a backward Euler scheme (1) that is "//& + "used for the Coriolis and inertial terms. BE may be "//& + "from 0.5 to 1, but instability may occur near 0.5. "//& + "BE is also applicable if SPLIT is false and USE_RK2 "//& + "is true.", units="nondim", default=0.6) + call get_param(param_file, mdl, "BEGW", CS%begw, & + "If SPLIT is true, BEGW is a number from 0 to 1 that "//& + "controls the extent to which the treatment of gravity "//& + "waves is forward-backward (0) or simulated backward "//& + "Euler (1). 0 is almost always used. "//& + "If SPLIT is false and USE_RK2 is true, BEGW can be "//& + "between 0 and 0.5 to damp gravity waves.", & + units="nondim", default=0.0) + + call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & + "If true, provide the bottom stress calculated by the "//& + "vertical viscosity to the barotropic solver.", default=.false.) + call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & + "If true, calculate the Coriolis accelerations at the end of each "//& + "timestep for use in the predictor step of the next split RK2 timestep.", & + default=.true.) + call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + "If true, apply profiles of momentum flux magnitude and direction.", & + default=.false.) + call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & + "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& + "variables that are needed to reproduce across restarts, similarly to "//& + "what is already being done with the primary state variables. "//& + "The default should be changed to true.", default=.false., do_not_log=.true.) + if (CS%remap_aux .and. .not.CS%store_CAu) call MOM_error(FATAL, & + "REMAP_AUXILIARY_VARS requires that STORE_CORIOLIS_ACCEL = True.") + call get_param(param_file, mdl, "DEBUG", CS%debug, & + "If true, write out verbose debugging data.", & + default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEBUG_OBC", CS%debug_OBC, default=.false.) + call get_param(param_file, mdl, "DEBUG_TRUNCATIONS", debug_truncations, & + default=.false.) + + allocate(CS%taux_bot(IsdB:IedB,jsd:jed), source=0.0) + allocate(CS%tauy_bot(isd:ied,JsdB:JedB), source=0.0) + + ALLOC_(CS%uhbt(IsdB:IedB,jsd:jed)) ; CS%uhbt(:,:) = 0.0 + ALLOC_(CS%vhbt(isd:ied,JsdB:JedB)) ; CS%vhbt(:,:) = 0.0 + ALLOC_(CS%visc_rem_u(IsdB:IedB,jsd:jed,nz)) ; CS%visc_rem_u(:,:,:) = 0.0 + ALLOC_(CS%visc_rem_v(isd:ied,JsdB:JedB,nz)) ; CS%visc_rem_v(:,:,:) = 0.0 + ALLOC_(CS%eta_PF(isd:ied,jsd:jed)) ; CS%eta_PF(:,:) = 0.0 + ALLOC_(CS%pbce(isd:ied,jsd:jed,nz)) ; CS%pbce(:,:,:) = 0.0 + + ALLOC_(CS%u_accel_bt(IsdB:IedB,jsd:jed,nz)) ; CS%u_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%v_accel_bt(isd:ied,JsdB:JedB,nz)) ; CS%v_accel_bt(:,:,:) = 0.0 + ALLOC_(CS%PFu_Stokes(IsdB:IedB,jsd:jed,nz)) ; CS%PFu_Stokes(:,:,:) = 0.0 + ALLOC_(CS%PFv_Stokes(isd:ied,JsdB:JedB,nz)) ; CS%PFv_Stokes(:,:,:) = 0.0 + + MIS%diffu => CS%diffu + MIS%diffv => CS%diffv + MIS%PFu => CS%PFu + MIS%PFv => CS%PFv + MIS%CAu => CS%CAu + MIS%CAv => CS%CAv + MIS%pbce => CS%pbce + MIS%u_accel_bt => CS%u_accel_bt + MIS%v_accel_bt => CS%v_accel_bt + MIS%u_av => CS%u_av + MIS%v_av => CS%v_av + + CS%ADp => Accel_diag + CS%CDp => Cont_diag + Accel_diag%diffu => CS%diffu + Accel_diag%diffv => CS%diffv + Accel_diag%PFu => CS%PFu + Accel_diag%PFv => CS%PFv + Accel_diag%CAu => CS%CAu + Accel_diag%CAv => CS%CAv + Accel_diag%u_accel_bt => CS%u_accel_bt + Accel_diag%v_accel_bt => CS%v_accel_bt + + allocate(CS%AD_pred) + CS%AD_pred%diffu => CS%diffu + CS%AD_pred%diffv => CS%diffv + CS%AD_pred%PFu => CS%PFu + CS%AD_pred%PFv => CS%PFv + CS%AD_pred%CAu => CS%CAu_pred + CS%AD_pred%CAv => CS%CAv_pred + CS%AD_pred%u_accel_bt => CS%u_accel_bt + CS%AD_pred%v_accel_bt => CS%v_accel_bt + +! Accel_diag%pbce => CS%pbce +! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt +! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av + + id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', & + grain=CLOCK_ROUTINE) + + call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) + cont_stencil = continuity_stencil(CS%continuity_CSp) + call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) + if (CS%calculate_SAL) call SAL_init(G, US, param_file, CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_init(Time, G, US, param_file, CS%tides_CSp) + call PressureForce_init(Time, G, GV, US, param_file, diag, CS%PressureForce_CSp, & + CS%SAL_CSp, CS%tides_CSp) + call hor_visc_init(Time, G, GV, US, param_file, diag, CS%hor_visc, ADp=CS%ADp) + call vertvisc_init(MIS, Time, G, GV, US, param_file, diag, CS%ADp, dirs, & + ntrunc, CS%vertvisc_CSp) + CS%set_visc_CSp => set_visc + call updateCFLtruncationValue(Time, CS%vertvisc_CSp, US, & + activate=is_new_run(restart_CS) ) + + if (associated(ALE_CSp)) CS%ALE_CSp => ALE_CSp + if (associated(OBC)) then + CS%OBC => OBC + if (OBC%ramp) call update_OBC_ramp(Time, CS%OBC, US, & + activate=is_new_run(restart_CS) ) + endif + if (associated(update_OBC_CSp)) CS%update_OBC_CSp => update_OBC_CSp + + eta_rest_name = "sfc" ; if (.not.GV%Boussinesq) eta_rest_name = "p_bot" + if (.not. query_initialized(CS%eta, trim(eta_rest_name), restart_CS)) then + ! Estimate eta based on the layer thicknesses - h. With the Boussinesq + ! approximation, eta is the free surface height anomaly, while without it + ! eta is the mass of ocean per unit area. eta always has the same + ! dimensions as h, either m or kg m-3. + ! CS%eta(:,:) = 0.0 already from initialization. + if (GV%Boussinesq) then + do j=js,je ; do i=is,ie ; CS%eta(i,j) = -GV%Z_to_H * G%bathyT(i,j) ; enddo ; enddo + endif + do k=1,nz ; do j=js,je ; do i=is,ie + 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) + endif + ! Copy eta into an output array. + do j=js,je ; do i=is,ie ; eta(i,j) = CS%eta(i,j) ; enddo ; enddo + + call barotropic_init(u, v, h, CS%eta, Time, G, GV, US, param_file, diag, & + CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & + CS%SAL_CSp) + + if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & + .not. query_initialized(CS%diffv, "diffv", restart_CS)) then + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & + 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) + endif + + if (.not. query_initialized(CS%u_av, "u2", restart_CS) .or. & + .not. query_initialized(CS%v_av, "v2", restart_CS)) then + do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = u(I,j,k) ; enddo ; enddo ; enddo + 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) + endif + + if (CS%store_CAu) then + if (query_initialized(CS%CAu_pred, "CAu", restart_CS) .and. & + query_initialized(CS%CAv_pred, "CAv", restart_CS)) then + CS%CAu_pred_stored = .true. + else + call only_read_from_restarts(uh, vh, 'uh', 'vh', G, restart_CS, stagger=CGRID_NE, & + filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_uv, scale=US%m_to_L**2*US%T_to_s/GV%H_to_mks) + call only_read_from_restarts('h2', CS%h_av, G, restart_CS, & + filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_h2, scale=1.0/GV%H_to_mks) + if (read_uv .and. read_h2) then + call pass_var(CS%h_av, G%Domain, clock=id_clock_pass_init) + else + do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo + call continuity(CS%u_av, CS%v_av, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) + enddo ; enddo ; enddo + endif + call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=2, clock=id_clock_pass_init, complete=.false.) + call pass_vector(uh, vh, G%Domain, halo=2, clock=id_clock_pass_init, complete=.true.) + call CorAdCalc(CS%u_av, CS%v_av, CS%h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%ADp, & + G, GV, US, CS%CoriolisAdv, pbv) !, Waves=Waves) + CS%CAu_pred_stored = .true. + endif + else + CS%CAu_pred_stored = .false. + ! This call is just here to initialize uh and vh. + if (.not. query_initialized(uh, "uh", restart_CS) .or. & + .not. query_initialized(vh, "vh", restart_CS)) then + do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo + call continuity(u, v, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) + do k=1,nz ; do j=jsd,jed ; do i=isd,ied + CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) + enddo ; enddo ; enddo + call set_initialized(uh, "uh", restart_CS) + call set_initialized(vh, "vh", restart_CS) + call set_initialized(CS%h_av, "h2", restart_CS) + ! Try reading the CAu and CAv fields from the restart file, in case this restart file is + ! using a newer format. + call only_read_from_restarts(CS%CAu_pred, CS%CAv_pred, "CAu", "CAv", G, restart_CS, & + stagger=CGRID_NE, filename=dirs%input_filename, directory=dirs%restart_input_dir, & + success=read_uv, scale=US%m_s_to_L_T*US%T_to_s) + CS%CAu_pred_stored = read_uv + else + if (.not. query_initialized(CS%h_av, "h2", restart_CS)) then + CS%h_av(:,:,:) = h(:,:,:) + call set_initialized(CS%h_av, "h2", restart_CS) + endif + endif + endif + call cpu_clock_begin(id_clock_pass_init) + call create_group_pass(pass_av_h_uvh, CS%u_av, CS%v_av, G%Domain, halo=2) + if (CS%CAu_pred_stored) then + call create_group_pass(pass_av_h_uvh, CS%CAu_pred, CS%CAv_pred, G%Domain, halo=2) + else + call create_group_pass(pass_av_h_uvh, CS%h_av, G%Domain, halo=2) + call create_group_pass(pass_av_h_uvh, uh, vh, G%Domain, halo=2) + endif + call do_group_pass(pass_av_h_uvh, G%Domain) + call cpu_clock_end(id_clock_pass_init) + + flux_units = get_flux_units(GV) + thickness_units = get_thickness_units(GV) + CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & + 'Zonal Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + y_cell_method='sum', v_extensive=.true.) + CS%id_vh = register_diag_field('ocean_model', 'vh', diag%axesCvL, Time, & + 'Meridional Thickness Flux', flux_units, conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T, & + x_cell_method='sum', v_extensive=.true.) + + CS%id_CAu = register_diag_field('ocean_model', 'CAu', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_CAv = register_diag_field('ocean_model', 'CAv', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFu = register_diag_field('ocean_model', 'PFu', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_PFv = register_diag_field('ocean_model', 'PFv', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_ueffA = register_diag_field('ocean_model', 'ueffA', diag%axesCuL, Time, & + 'Effective U-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + y_cell_method='sum', v_extensive=.true.) + CS%id_veffA = register_diag_field('ocean_model', 'veffA', diag%axesCvL, Time, & + 'Effective V-Face Area', 'm^2', conversion=GV%H_to_m*US%L_to_m, & + x_cell_method='sum', v_extensive=.true.) + if (GV%Boussinesq) then + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic SSH tendency due to dynamics', trim(thickness_units)//' s-1', conversion=GV%H_to_MKS*US%s_to_T) + else + CS%id_deta_dt = register_diag_field('ocean_model', 'deta_dt', diag%axesT1, Time, & + 'Barotropic column-mass tendency due to dynamics', trim(thickness_units)//' s-1', & + conversion=GV%H_to_mks*US%s_to_T) + endif + + !CS%id_hf_PFu = register_diag_field('ocean_model', 'hf_PFu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_PFv = register_diag_field('ocean_model', 'hf_PFv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + !CS%id_hf_CAu = register_diag_field('ocean_model', 'hf_CAu', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_CAv = register_diag_field('ocean_model', 'hf_CAv', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_PFu_2d = register_diag_field('ocean_model', 'hf_PFu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_PFv_2d = register_diag_field('ocean_model', 'hf_PFv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Pressure Force Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_PFu = register_diag_field('ocean_model', 'h_PFu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_PFv = register_diag_field('ocean_model', 'h_PFv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_PFv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_PFu_2d = register_diag_field('ocean_model', 'intz_PFu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_PFv_2d = register_diag_field('ocean_model', 'intz_PFv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Pressure Force Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_PFv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_hf_CAu_2d = register_diag_field('ocean_model', 'hf_CAu_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Zonal Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_CAv_2d = register_diag_field('ocean_model', 'hf_CAv_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Meridional Coriolis and Advective Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_CAu = register_diag_field('ocean_model', 'h_CAu', diag%axesCuL, Time, & + 'Thickness Multiplied Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAu > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_CAv = register_diag_field('ocean_model', 'h_CAv', diag%axesCvL, Time, & + 'Thickness Multiplied Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_CAv > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_CAu_2d = register_diag_field('ocean_model', 'intz_CAu_2d', diag%axesCu1, Time, & + 'Depth-integral of Zonal Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAu_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_CAv_2d = register_diag_field('ocean_model', 'intz_CAv_2d', diag%axesCv1, Time, & + 'Depth-integral of Meridional Coriolis and Advective Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_CAv_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_uav = register_diag_field('ocean_model', 'uav', diag%axesCuL, Time, & + 'Barotropic-step Averaged Zonal Velocity', 'm s-1', conversion=US%L_T_to_m_s) + CS%id_vav = register_diag_field('ocean_model', 'vav', diag%axesCvL, Time, & + 'Barotropic-step Averaged Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) + + CS%id_u_BT_accel = register_diag_field('ocean_model', 'u_BT_accel', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + CS%id_v_BT_accel = register_diag_field('ocean_model', 'v_BT_accel', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration', 'm s-2', conversion=US%L_T2_to_m_s2) + + !CS%id_hf_u_BT_accel = register_diag_field('ocean_model', 'hf_u_BT_accel', diag%axesCuL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + !CS%id_hf_v_BT_accel = register_diag_field('ocean_model', 'hf_v_BT_accel', diag%axesCvL, Time, & + ! 'Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + ! 'm s-2', v_extensive=.true., conversion=US%L_T2_to_m_s2) + !if (CS%id_hf_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_hf_u_BT_accel_2d = register_diag_field('ocean_model', 'hf_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Zonal Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_u,IsdB,IedB,jsd,jed,nz) + + CS%id_hf_v_BT_accel_2d = register_diag_field('ocean_model', 'hf_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-sum Fractional Thickness-weighted Barotropic Anomaly Meridional Acceleration', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_hf_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hfrac_v,isd,ied,JsdB,JedB,nz) + + CS%id_h_u_BT_accel = register_diag_field('ocean_model', 'h_u_BT_accel', diag%axesCuL, Time, & + 'Thickness Multiplied Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_u_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_h_v_BT_accel = register_diag_field('ocean_model', 'h_v_BT_accel', diag%axesCvL, Time, & + 'Thickness Multiplied Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_h_v_BT_accel > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_intz_u_BT_accel_2d = register_diag_field('ocean_model', 'intz_u_BT_accel_2d', diag%axesCu1, Time, & + 'Depth-integral of Barotropic Anomaly Zonal Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_u_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hu,IsdB,IedB,jsd,jed,nz) + + CS%id_intz_v_BT_accel_2d = register_diag_field('ocean_model', 'intz_v_BT_accel_2d', diag%axesCv1, Time, & + 'Depth-integral of Barotropic Anomaly Meridional Acceleration', & + 'm2 s-2', conversion=GV%H_to_m*US%L_T2_to_m_s2) + if (CS%id_intz_v_BT_accel_2d > 0) call safe_alloc_ptr(CS%ADp%diag_hv,isd,ied,JsdB,JedB,nz) + + CS%id_PFu_visc_rem = register_diag_field('ocean_model', 'PFu_visc_rem', diag%axesCuL, Time, & + 'Zonal Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_PFv_visc_rem = register_diag_field('ocean_model', 'PFv_visc_rem', diag%axesCvL, Time, & + 'Meridional Pressure Force Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_PFv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_CAu_visc_rem = register_diag_field('ocean_model', 'CAu_visc_rem', diag%axesCuL, Time, & + 'Zonal Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAu_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_CAv_visc_rem = register_diag_field('ocean_model', 'CAv_visc_rem', diag%axesCvL, Time, & + 'Meridional Coriolis and Advective Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_CAv_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + CS%id_u_BT_accel_visc_rem = register_diag_field('ocean_model', 'u_BT_accel_visc_rem', diag%axesCuL, Time, & + 'Barotropic Anomaly Zonal Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_u_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_u,IsdB,IedB,jsd,jed,nz) + CS%id_v_BT_accel_visc_rem = register_diag_field('ocean_model', 'v_BT_accel_visc_rem', diag%axesCvL, Time, & + 'Barotropic Anomaly Meridional Acceleration multiplied by the viscous remnant', & + 'm s-2', conversion=US%L_T2_to_m_s2) + if (CS%id_v_BT_accel_visc_rem > 0) call safe_alloc_ptr(CS%ADp%visc_rem_v,isd,ied,JsdB,JedB,nz) + + id_clock_Cor = cpu_clock_id('(Ocean Coriolis & mom advection)', grain=CLOCK_MODULE) + id_clock_continuity = cpu_clock_id('(Ocean continuity equation)', grain=CLOCK_MODULE) + id_clock_pres = cpu_clock_id('(Ocean pressure force)', grain=CLOCK_MODULE) + id_clock_vertvisc = cpu_clock_id('(Ocean vertical viscosity)', grain=CLOCK_MODULE) + id_clock_horvisc = cpu_clock_id('(Ocean horizontal viscosity)', grain=CLOCK_MODULE) + id_clock_mom_update = cpu_clock_id('(Ocean momentum increments)', grain=CLOCK_MODULE) + id_clock_pass = cpu_clock_id('(Ocean message passing)', grain=CLOCK_MODULE) + id_clock_btcalc = cpu_clock_id('(Ocean barotropic mode calc)', grain=CLOCK_MODULE) + id_clock_btstep = cpu_clock_id('(Ocean barotropic mode stepping)', grain=CLOCK_MODULE) + id_clock_btforce = cpu_clock_id('(Ocean barotropic forcing calc)', grain=CLOCK_MODULE) + +end subroutine initialize_dyn_split_RK2b + + +!> Close the dyn_split_RK2b module +subroutine end_dyn_split_RK2b(CS) + type(MOM_dyn_split_RK2b_CS), pointer :: CS !< module control structure + + call barotropic_end(CS%barotropic_CSp) + + call vertvisc_end(CS%vertvisc_CSp) + deallocate(CS%vertvisc_CSp) + + call hor_visc_end(CS%hor_visc) + if (CS%calculate_SAL) call SAL_end(CS%SAL_CSp) + if (CS%use_tides) call tidal_forcing_end(CS%tides_CSp) + call CoriolisAdv_end(CS%CoriolisAdv) + + DEALLOC_(CS%diffu) ; DEALLOC_(CS%diffv) + DEALLOC_(CS%CAu) ; DEALLOC_(CS%CAv) + DEALLOC_(CS%CAu_pred) ; DEALLOC_(CS%CAv_pred) + DEALLOC_(CS%PFu) ; DEALLOC_(CS%PFv) + + if (associated(CS%taux_bot)) deallocate(CS%taux_bot) + if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot) + DEALLOC_(CS%uhbt) ; DEALLOC_(CS%vhbt) + DEALLOC_(CS%u_accel_bt) ; DEALLOC_(CS%v_accel_bt) + DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v) + + DEALLOC_(CS%eta) ; DEALLOC_(CS%eta_PF) ; DEALLOC_(CS%pbce) + DEALLOC_(CS%h_av) ; DEALLOC_(CS%u_av) ; DEALLOC_(CS%v_av) + + call dealloc_BT_cont_type(CS%BT_cont) + deallocate(CS%AD_pred) + + deallocate(CS) +end subroutine end_dyn_split_RK2b + + +!> \namespace mom_dynamics_split_rk2b +!! +!! This file time steps the adiabatic dynamic core by splitting +!! between baroclinic and barotropic modes. It uses a pseudo-second order +!! Runge-Kutta time stepping scheme for the baroclinic momentum +!! equation and a forward-backward coupling between the baroclinic +!! momentum and continuity equations. This split time-stepping +!! scheme is described in detail in Hallberg (JCP, 1997). Additional +!! issues related to exact tracer conservation and how to +!! ensure consistency between the barotropic and layered estimates +!! of the free surface height are described in Hallberg and +!! Adcroft (Ocean Modelling, 2009). This was the time stepping code +!! that is used for most GOLD applications, including GFDL's ESM2G +!! Earth system model, and all of the examples provided with the +!! MOM code (although several of these solutions are routinely +!! verified by comparison with the slower unsplit schemes). +!! +!! The subroutine step_MOM_dyn_split_RK2b actually does the time +!! stepping, while register_restarts_dyn_split_RK2b sets the fields +!! that are found in a full restart file with this scheme, and +!! initialize_dyn_split_RK2b initializes the cpu clocks that are +!! used in this module. For largely historical reasons, this module +!! does not have its own control structure, but shares the same +!! control structure with MOM.F90 and the other MOM_dynamics_... +!! modules. + +end module MOM_dynamics_split_RK2b From 8b98bd04b41be50c86bee3b8b5aee47962056a10 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 12 Dec 2023 06:44:40 -0500 Subject: [PATCH 509/629] *+Revise algorithm in step_MOM_dyn_split_RK2b Revised step_MOM_dyn_split_RK2b to use the time-filtered velocities as arguments and reconstruct the instantaneous velocities with the proper phase from the barotropic solver from the saved increments du_av_inst and dv_av_inst. As a part of this change, the continuity solver is used to find the thickness fluxes used in the predictor step Coriolis terms, and the horizontal viscous accelerations are calculated for both the predictor and corrector steps, thereby avoiding the need to vertically remap any 3-d fields apart from a single pair of velocity components. The run-time option STORE_CORIOLIS_ACCEL is no longer used when SPLIT_RK2B = True. FPMIX was also disabled in this mode due to unresolved dimensional inconsistency errors in that code. Additionally, the time-filtered velocities are now used instead of the instantaneous velocities in the second call to radiation_open_bdry_conds(), which should improve the performance of several of the Orlanski-type open boundary conditions. The 2-d fields du_av_inst and dv_av_inst were added to the restart file, while the 3-d fields u2, v2, diffu and diffv and either CAu and CAv or uh, vh and h2 are all removed from the restart files. Remap_dyn_split_RK2b_aux_vars() now has nothing to do, and it should probably be eliminated altogether in a subsequent commit. All answers are changed when SPLIT_RK2B = True, and there are changes to the contents of the restart files. --- src/core/MOM_dynamics_split_RK2b.F90 | 417 +++++++++++---------------- 1 file changed, 162 insertions(+), 255 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index a289014313..9cd8fbfc09 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -141,6 +141,12 @@ module MOM_dynamics_split_RK2b real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure !! anomaly in each layer due to free surface height !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. + real ALLOCABLE_, dimension(NIMEMB_PTR_,NJMEM_) :: du_av_inst !< The barotropic zonal velocity increment + !! between filtered and instantaneous velocities + !! [L T-1 ~> m s-1] + real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: dv_av_inst !< The barotropic meridional velocity increment + !! between filtered and instantaneous velocities + !! [L T-1 ~> m s-1] type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure @@ -157,12 +163,6 @@ module MOM_dynamics_split_RK2b !! barotropic solver. logical :: calc_dtbt !< If true, calculate the barotropic time-step !! dynamically. - logical :: store_CAu !< If true, store the Coriolis and advective accelerations at the - !! end of the timestep for use in the next predictor step. - logical :: CAu_pred_stored !< If true, the Coriolis and advective accelerations at the - !! end of the timestep have been stored for use in the next - !! predictor step. This is used to accomodate various generations - !! of restart files. logical :: calculate_SAL !< If true, calculate self-attraction and loading. logical :: use_tides !< If true, tidal forcing is enabled. logical :: remap_aux !< If true, apply ALE remapping to all of the auxiliary 3-D @@ -181,7 +181,7 @@ module MOM_dynamics_split_RK2b logical :: module_is_initialized = .false. !< Record whether this module has been initialized. !>@{ Diagnostic IDs - integer :: id_uold = -1, id_vold = -1 + ! integer :: id_uold = -1, id_vold = -1 integer :: id_uh = -1, id_vh = -1 integer :: id_umo = -1, id_vmo = -1 integer :: id_umo_2d = -1, id_vmo_2d = -1 @@ -253,13 +253,14 @@ module MOM_dynamics_split_RK2b !> A pointer to the update_OBC control structure type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() - type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_eta !< Structure for group halo pass type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass - type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass - type(group_pass_type) :: pass_uv !< Structure for group halo pass - type(group_pass_type) :: pass_h !< Structure for group halo pass - type(group_pass_type) :: pass_av_uvh !< Structure for group halo pass + type(group_pass_type) :: pass_h_av !< Structure for group halo pass + type(group_pass_type) :: pass_uv !< Structure for group halo pass + type(group_pass_type) :: pass_h !< Structure for group halo pass + type(group_pass_type) :: pass_av_uvh !< Structure for group halo pass end type MOM_dyn_split_RK2b_CS @@ -275,22 +276,22 @@ module MOM_dynamics_split_RK2b integer :: id_clock_horvisc, id_clock_mom_update integer :: id_clock_continuity, id_clock_thick_diff integer :: id_clock_btstep, id_clock_btcalc, id_clock_btforce -integer :: id_clock_pass, id_clock_pass_init +integer :: id_clock_pass !>@} contains !> RK2 splitting for time stepping MOM adiabatic dynamics -subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, forces, & +subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forces, & p_surf_begin, p_surf_end, uh, vh, uhtr, vhtr, eta_av, & G, GV, US, CS, calc_dtbt, VarMix, MEKE, thickness_diffuse_CSp, pbv, Waves) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & - target, intent(inout) :: u_inst !< Zonal velocity [L T-1 ~> m s-1] + target, intent(inout) :: u_av !< Zonal velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & - target, intent(inout) :: v_inst !< Meridional velocity [L T-1 ~> m s-1] + target, intent(inout) :: v_av !< Meridional velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type @@ -330,6 +331,7 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: up ! Predicted zonal velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vp ! Predicted meridional velocity [L T-1 ~> m s-1]. real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: hp ! Predicted thickness [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: ueffA ! Effective Area of U-Faces [H L ~> m2] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: veffA ! Effective Area of V-Faces [H L ~> m2] @@ -340,6 +342,11 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, ! of each layer calculated by the non-barotropic ! part of the model [L T-2 ~> m s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: u_inst ! Instantaneous zonal velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: v_inst ! Instantaneous meridional velocity [L T-1 ~> m s-1]. + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_av ! The average of the layer thicknesses at the beginning + ! and end of a time step [H ~> m or kg m-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), target :: uh_in ! The zonal mass transports that would be ! obtained using the initial velocities [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), target :: vh_in ! The meridional mass transports that would be @@ -378,11 +385,7 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, u_ptr => NULL(), & ! A pointer to a zonal velocity [L T-1 ~> m s-1] v_ptr => NULL(), & ! A pointer to a meridional velocity [L T-1 ~> m s-1] uh_ptr => NULL(), & ! A pointer to a zonal volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] - vh_ptr => NULL(), & ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] - ! These pointers are just used as shorthand for CS%u_av, CS%v_av, and CS%h_av. - u_av, & ! The zonal velocity time-averaged over a time step [L T-1 ~> m s-1]. - v_av, & ! The meridional velocity time-averaged over a time step [L T-1 ~> m s-1]. - h_av ! The layer thickness time-averaged over a time step [H ~> m or kg m-2]. + vh_ptr => NULL() ! A pointer to a meridional volume or mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJ_(G)) :: hbl ! Boundary layer depth from Cvmix [H ~> m or kg m-2] real :: dt_pred ! The time step for the predictor part of the baroclinic time stepping [T ~> s]. @@ -400,7 +403,8 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, 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 - u_av => CS%u_av ; v_av => CS%v_av ; h_av => CS%h_av ; eta => CS%eta + + eta => CS%eta Idt_bc = 1.0 / dt @@ -409,19 +413,16 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("step_MOM_dyn_split_RK2b(), MOM_dynamics_split_RK2b.F90") - !$OMP parallel do default(shared) - do k=1,nz - do j=G%jsd,G%jed ; do i=G%isdB,G%iedB ; up(i,j,k) = 0.0 ; enddo ; enddo - do j=G%jsdB,G%jedB ; do i=G%isd,G%ied ; vp(i,j,k) = 0.0 ; enddo ; enddo - do j=G%jsd,G%jed ; do i=G%isd,G%ied ; hp(i,j,k) = h(i,j,k) ; enddo ; enddo - enddo + ! Fill in some halo points for arrays that will have halo updates. + hp(:,:,:) = h(:,:,:) + up(:,:,:) = 0.0 ; vp(:,:,:) = 0.0 ; u_inst(:,:,:) = 0.0 ; v_inst(:,:,:) = 0.0 ! Update CFL truncation value as function of time call updateCFLtruncationValue(Time_local, CS%vertvisc_CSp, US) if (CS%debug) then - call MOM_state_chksum("Start predictor ", u_inst, v_inst, h, uh, vh, G, GV, US, symmetric=sym) - call check_redundant("Start predictor u ", u_inst, v_inst, G, unscale=US%L_T_to_m_s) + call MOM_state_chksum("Start predictor ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) + call check_redundant("Start predictor u ", u_av, v_av, G, unscale=US%L_T_to_m_s) call check_redundant("Start predictor uh ", uh, vh, G, unscale=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) endif @@ -476,9 +477,25 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + + call create_group_pass(CS%pass_h_av, hp, G%Domain, halo=2) + call create_group_pass(CS%pass_h_av, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass + if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then + call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) + endif ; endif + + ! This calculates the transports and averaged thicknesses that will be used for the + ! predictor version of the Coriolis scheme. + call cpu_clock_begin(id_clock_continuity) + call continuity(u_av, v_av, h, hp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) + call cpu_clock_end(id_clock_continuity) + + if (G%nonblocking_updates) & + call start_group_pass(CS%pass_h_av, G%Domain, clock=id_clock_pass) ! PFu = d/dx M(h,T,S) ! pbce = dM/deta @@ -500,7 +517,7 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv ! will therefore report the sum total PGF and we avoid other @@ -523,25 +540,37 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)") - if (associated(CS%OBC)) then ; if (CS%OBC%update_OBC) then - call update_OBC_data(CS%OBC, G, GV, US, tv, h, CS%update_OBC_CSp, Time_local) - endif ; endif if (associated(CS%OBC) .and. CS%debug_OBC) & call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) - if (G%nonblocking_updates) & + if (G%nonblocking_updates) then + call complete_group_pass(CS%pass_h_av, G%Domain, clock=id_clock_pass) call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) + else + call do_group_pass(CS%pass_h_av, G%Domain, clock=id_clock_pass) + endif + + !$OMP parallel do default(shared) + do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 + h_av(i,j,k) = 0.5*(hp(i,j,k) + h(i,j,k)) + enddo ; enddo ; enddo + + ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms + ! and horizontal viscous accelerations. ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av - if (.not.CS%CAu_pred_stored) then - ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms, - ! if it was not already stored from the end of the previous time step. - call cpu_clock_begin(id_clock_Cor) - call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & - G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) - call cpu_clock_end(id_clock_Cor) - if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") - endif + call cpu_clock_begin(id_clock_Cor) + call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & + G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) + call cpu_clock_end(id_clock_Cor) + if (showCallTree) call callTree_wayPoint("done with predictor CorAdCalc (step_MOM_dyn_split_RK2b)") + +! diffu = horizontal viscosity terms (u_av) + call cpu_clock_begin(id_clock_horvisc) + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) + call cpu_clock_end(id_clock_horvisc) + if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") ! u_bc_accel = CAu + PFu + diffu(u[n-1]) call cpu_clock_begin(id_clock_btforce) @@ -573,15 +602,15 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, !$OMP parallel do default(shared) do k=1,nz do j=js,je ; do I=Isq,Ieq - up(I,j,k) = G%mask2dCu(I,j) * (u_inst(I,j,k) + dt * u_bc_accel(I,j,k)) + up(I,j,k) = G%mask2dCu(I,j) * (u_av(I,j,k) + dt * u_bc_accel(I,j,k)) enddo ; enddo do J=Jsq,Jeq ; do i=is,ie - vp(i,J,k) = G%mask2dCv(i,J) * (v_inst(i,J,k) + dt * v_bc_accel(i,J,k)) + vp(i,J,k) = G%mask2dCv(i,J) * (v_av(i,J,k) + dt * v_bc_accel(i,J,k)) enddo ; enddo enddo call enable_averages(dt, Time_local, CS%diag) - call set_viscous_ML(u_inst, v_inst, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) + call set_viscous_ML(u_av, v_av, h, tv, forces, visc, dt, G, GV, US, CS%set_visc_CSp) call disable_averaging(CS%diag) if (CS%debug) then @@ -622,6 +651,17 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, if (G%nonblocking_updates) & call complete_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) + ! Reconstruct u_inst and v_inst from u_av and v_av. + call cpu_clock_begin(id_clock_mom_update) + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + u_inst(I,j,k) = u_av(I,j,k) - CS%du_av_inst(I,j) * CS%visc_rem_u(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,j) * CS%visc_rem_v(i,J,k) + enddo ; enddo ; enddo + call cpu_clock_end(id_clock_mom_update) + call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + ! u_accel_bt = layer accelerations due to barotropic solver call cpu_clock_begin(id_clock_continuity) call continuity(u_inst, v_inst, h, hp, uh_in, vh_in, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & @@ -647,10 +687,10 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, if (showCallTree) call callTree_leave("btstep()") call cpu_clock_end(id_clock_btstep) -! up = u + dt_pred*( u_bc_accel + u_accel_bt ) dt_pred = dt * CS%be call cpu_clock_begin(id_clock_mom_update) +! up = u + dt_pred*( u_bc_accel + u_accel_bt ) !$OMP parallel do default(shared) do k=1,nz do J=Jsq,Jeq ; do i=is,ie @@ -685,16 +725,16 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, call uvchksum("0 before vertvisc: [uv]p", up, vp, G%HI,haloshift=0, symmetric=sym, scale=US%L_T_to_m_s) endif - if (CS%fpmix) then - uold(:,:,:) = 0.0 - vold(:,:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - uold(I,j,k) = up(I,j,k) - enddo ; enddo ; enddo - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - vold(i,J,k) = vp(i,J,k) - enddo ; enddo ; enddo - endif + ! if (CS%fpmix) then + ! uold(:,:,:) = 0.0 + ! vold(:,:,:) = 0.0 + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! uold(I,j,k) = up(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! vold(i,J,k) = vp(i,J,k) + ! enddo ; enddo ; enddo + ! endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(up, vp, h, dz, forces, visc, tv, dt_pred, G, GV, US, CS%vertvisc_CSp, & @@ -702,16 +742,16 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%AD_pred, CS%CDp, G, & GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) - if (CS%fpmix) then - hbl(:,:) = 0.0 - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) & - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) - call vertFPmix(up, vp, uold, vold, hbl, h, forces, & - dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & - GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) - endif + ! if (CS%fpmix) then + ! hbl(:,:) = 0.0 + ! if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) + ! if (ASSOCIATED(CS%energetic_PBL_CSp)) & + ! call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + ! call vertFPmix(up, vp, uold, vold, hbl, h, forces, & + ! dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) + ! call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & + ! GV, US, CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + ! endif if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") if (G%nonblocking_updates) then @@ -796,7 +836,7 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF if (Use_Stokes_PGF) then call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call Stokes_PGF(G, GV, US, dz, u_inst, v_inst, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) if (.not.Waves%Passive_Stokes_PGF) then do k=1,nz do j=js,je ; do I=Isq,Ieq @@ -835,10 +875,8 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & - MEKE, Varmix, G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & - ADp=CS%ADp) + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -931,28 +969,28 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, ! u_av <- u_av + dt d/dz visc d/dz u_av call cpu_clock_begin(id_clock_vertvisc) - if (CS%fpmix) then - uold(:,:,:) = 0.0 - vold(:,:,:) = 0.0 - do k=1,nz ; do j=js,je ; do I=Isq,Ieq - uold(I,j,k) = u_inst(I,j,k) - enddo ; enddo ; enddo - do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - vold(i,J,k) = v_inst(i,J,k) - enddo ; enddo ; enddo - endif + ! if (CS%fpmix) then + ! uold(:,:,:) = 0.0 + ! vold(:,:,:) = 0.0 + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! uold(I,j,k) = u_inst(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! vold(i,J,k) = v_inst(i,J,k) + ! enddo ; enddo ; enddo + ! endif call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) call vertvisc_coef(u_inst, v_inst, h, dz, forces, visc, tv, dt, G, GV, US, CS%vertvisc_CSp, CS%OBC, VarMix) call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & - CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot,waves=waves) + CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) - if (CS%fpmix) then - call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & - G, GV, US, CS%vertvisc_CSp, CS%OBC) - call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & - CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) - endif + ! if (CS%fpmix) then + ! call vertFPmix(u_inst, v_inst, uold, vold, hbl, h, forces, dt, & + ! G, GV, US, CS%vertvisc_CSp, CS%OBC) + ! call vertvisc(u_inst, v_inst, h, forces, visc, dt, CS%OBC, CS%ADp, CS%CDp, G, GV, US, & + ! CS%vertvisc_CSp, CS%taux_bot, CS%tauy_bot, waves=waves) + ! endif if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) @@ -980,8 +1018,19 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, ! h = h + dt * div . uh ! u_av and v_av adjusted so their mass transports match uhbt and vhbt. call cpu_clock_begin(id_clock_continuity) + call continuity(u_inst, v_inst, h, h, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv, & - CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av) + CS%uhbt, CS%vhbt, CS%visc_rem_u, CS%visc_rem_v, u_av, v_av, & + du_cor=CS%du_av_inst, dv_cor=CS%dv_av_inst) + + ! This tests the ability to readjust the instantaneous velocity, and here it changes answers only at roundoff. + ! do k=1,nz ; do j=js,je ; do I=Isq,Ieq + ! u_inst(I,j,k) = u_av(I,j,k) - CS%du_av_inst(I,j) * CS%visc_rem_u(I,j,k) + ! enddo ; enddo ; enddo + ! do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + ! v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,J) * CS%visc_rem_v(i,J,k) + ! enddo ; enddo ; enddo + call cpu_clock_end(id_clock_continuity) call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) ! Whenever thickness changes let the diag manager know, target grids @@ -996,10 +1045,10 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, endif if (associated(CS%OBC)) then - call radiation_open_bdry_conds(CS%OBC, u_inst, u_old_rad_OBC, v_inst, v_old_rad_OBC, G, GV, US, dt) + call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt) endif -! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. + ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. !$OMP parallel do default(shared) do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k)) @@ -1018,26 +1067,10 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, enddo ; enddo enddo - if (CS%store_CAu) then - ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms - ! for use in the next time step, possibly after it has been vertically remapped. - call cpu_clock_begin(id_clock_Cor) - call disable_averaging(CS%diag) ! These calculations should not be used for diagnostics. - ! CAu = -(f+zeta_av)/h_av vh + d/dx KE_av - call CorAdCalc(u_av, v_av, h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%AD_pred, & - G, GV, US, CS%CoriolisAdv, pbv, Waves=Waves) - CS%CAu_pred_stored = .true. - call enable_averages(dt, Time_local, CS%diag) ! Reenable the averaging - call cpu_clock_end(id_clock_Cor) - if (showCallTree) call callTree_wayPoint("done with CorAdCalc (step_MOM_dyn_split_RK2b)") - else - CS%CAu_pred_stored = .false. - endif - - if (CS%fpmix) then - if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) - if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) - endif + ! if (CS%fpmix) then + ! if (CS%id_uold > 0) call post_data(CS%id_uold, uold, CS%diag) + ! if (CS%id_vold > 0) call post_data(CS%id_vold, vold, CS%diag) + ! endif ! The time-averaged free surface height has already been set by the last call to btstep. @@ -1063,7 +1096,7 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, if (CS%id_ueffA > 0) then ueffA(:,:,:) = 0 do k=1,nz ; do j=js,je ; do I=Isq,Ieq - if (abs(up(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k) / up(I,j,k) + if (abs(u_av(I,j,k)) > 0.) ueffA(I,j,k) = uh(I,j,k) / u_av(I,j,k) enddo ; enddo ; enddo call post_data(CS%id_ueffA, ueffA, CS%diag) endif @@ -1071,7 +1104,7 @@ subroutine step_MOM_dyn_split_RK2b(u_inst, v_inst, h, tv, visc, Time_local, dt, if (CS%id_veffA > 0) then veffA(:,:,:) = 0 do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie - if (abs(vp(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k) / vp(i,J,k) + if (abs(v_av(i,J,k)) > 0.) veffA(i,J,k) = vh(i,J,k) / v_av(i,J,k) enddo ; enddo ; enddo call post_data(CS%id_veffA, veffA, CS%diag) endif @@ -1186,20 +1219,14 @@ subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_ ALLOC_(CS%CAv_pred(isd:ied,JsdB:JedB,nz)) ; CS%CAv_pred(:,:,:) = 0.0 ALLOC_(CS%PFu(IsdB:IedB,jsd:jed,nz)) ; CS%PFu(:,:,:) = 0.0 ALLOC_(CS%PFv(isd:ied,JsdB:JedB,nz)) ; CS%PFv(:,:,:) = 0.0 + ALLOC_(CS%du_av_inst(IsdB:IedB,jsd:jed)) ; CS%du_av_inst(:,:) = 0.0 + ALLOC_(CS%dv_av_inst(isd:ied,JsdB:JedB)) ; CS%dv_av_inst(:,:) = 0.0 ALLOC_(CS%eta(isd:ied,jsd:jed)) ; CS%eta(:,:) = 0.0 - ALLOC_(CS%u_av(IsdB:IedB,jsd:jed,nz)) ; CS%u_av(:,:,:) = 0.0 - ALLOC_(CS%v_av(isd:ied,JsdB:JedB,nz)) ; CS%v_av(:,:,:) = 0.0 - ALLOC_(CS%h_av(isd:ied,jsd:jed,nz)) ; CS%h_av(:,:,:) = GV%Angstrom_H thickness_units = get_thickness_units(GV) flux_units = get_flux_units(GV) - call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & - "If true, calculate the Coriolis accelerations at the end of each "//& - "timestep for use in the predictor step of the next split RK2 timestep.", & - default=.true., do_not_log=.true.) - if (GV%Boussinesq) then call register_restart_field(CS%eta, "sfc", .false., restart_CS, & longname="Free surface Height", units=thickness_units, conversion=GV%H_to_mks) @@ -1208,33 +1235,14 @@ subroutine register_restarts_dyn_split_RK2b(HI, GV, US, param_file, CS, restart_ longname="Bottom Pressure", units=thickness_units, conversion=GV%H_to_mks) endif - ! These are needed, either to calculate CAu and CAv or to calculate the velocity anomalies in - ! the barotropic solver's Coriolis terms. - vd(1) = var_desc("u2", "m s-1", "Auxiliary Zonal velocity", 'u', 'L') - vd(2) = var_desc("v2", "m s-1", "Auxiliary Meridional velocity", 'v', 'L') - call register_restart_pair(CS%u_av, CS%v_av, vd(1), vd(2), .false., restart_CS, & + ! These are needed to reconstruct the phase in the barotorpic solution. + vd(1) = var_desc("du_avg_inst", "m s-1", & + "Barotropic velocity increment between instantaneous and filtered zonal velocities", 'u', '1') + vd(2) = var_desc("dv_avg_inst", "m s-1", & + "Barotropic velocity increment between instantaneous and filtered meridional velocities", 'v', '1') + call register_restart_pair(CS%du_av_inst, CS%dv_av_inst, vd(1), vd(2), .false., restart_CS, & conversion=US%L_T_to_m_s) - if (CS%store_CAu) then - vd(1) = var_desc("CAu", "m s-2", "Zonal Coriolis and advactive acceleration", 'u', 'L') - vd(2) = var_desc("CAv", "m s-2", "Meridional Coriolis and advactive acceleration", 'v', 'L') - call register_restart_pair(CS%CAu_pred, CS%CAv_pred, vd(1), vd(2), .false., restart_CS, & - conversion=US%L_T2_to_m_s2) - else - call register_restart_field(CS%h_av, "h2", .false., restart_CS, & - longname="Auxiliary Layer Thickness", units=thickness_units, conversion=GV%H_to_mks) - - vd(1) = var_desc("uh", flux_units, "Zonal thickness flux", 'u', 'L') - vd(2) = var_desc("vh", flux_units, "Meridional thickness flux", 'v', 'L') - call register_restart_pair(uh, vh, vd(1), vd(2), .false., restart_CS, & - conversion=GV%H_to_MKS*US%L_to_m**2*US%s_to_T) - endif - - vd(1) = var_desc("diffu", "m s-2", "Zonal horizontal viscous acceleration", 'u', 'L') - vd(2) = var_desc("diffv", "m s-2", "Meridional horizontal viscous acceleration", 'v', 'L') - call register_restart_pair(CS%diffu, CS%diffv, vd(1), vd(2), .false., restart_CS, & - conversion=US%L_T2_to_m_s2) - call register_barotropic_restarts(HI, GV, US, param_file, CS%barotropic_CSp, restart_CS) end subroutine register_restarts_dyn_split_RK2b @@ -1259,16 +1267,7 @@ subroutine remap_dyn_split_RK2b_aux_vars(G, GV, CS, h_old_u, h_old_v, h_new_u, h !! velocity points [H ~> m or kg m-2] type(ALE_CS), pointer :: ALE_CSp !< ALE control structure to use when remapping - if (.not.CS%remap_aux) return - - if (CS%store_CAu) then - call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%u_av, CS%v_av) - call pass_vector(CS%u_av, CS%v_av, G%Domain, complete=.false.) - call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%CAu_pred, CS%CAv_pred) - call pass_vector(CS%CAu_pred, CS%CAv_pred, G%Domain, complete=.true.) - endif - - call ALE_remap_velocities(ALE_CSp, G, GV, h_old_u, h_old_v, h_new_u, h_new_v, CS%diffu, CS%diffv) + return end subroutine remap_dyn_split_RK2b_aux_vars @@ -1328,7 +1327,6 @@ subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, para ! This include declares and sets the variable "version". # include "version_variable.h" character(len=48) :: thickness_units, flux_units, eta_rest_name - type(group_pass_type) :: pass_av_h_uvh logical :: debug_truncations logical :: read_uv, read_h2 @@ -1374,20 +1372,15 @@ subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, para call get_param(param_file, mdl, "SPLIT_BOTTOM_STRESS", CS%split_bottom_stress, & "If true, provide the bottom stress calculated by the "//& "vertical viscosity to the barotropic solver.", default=.false.) - call get_param(param_file, mdl, "STORE_CORIOLIS_ACCEL", CS%store_CAu, & - "If true, calculate the Coriolis accelerations at the end of each "//& - "timestep for use in the predictor step of the next split RK2 timestep.", & - default=.true.) - call get_param(param_file, mdl, "FPMIX", CS%fpmix, & - "If true, apply profiles of momentum flux magnitude and direction.", & - default=.false.) + ! call get_param(param_file, mdl, "FPMIX", CS%fpmix, & + ! "If true, apply profiles of momentum flux magnitude and direction.", & + ! default=.false.) + CS%fpmix = .false. call get_param(param_file, mdl, "REMAP_AUXILIARY_VARS", CS%remap_aux, & "If true, apply ALE remapping to all of the auxiliary 3-dimensional "//& "variables that are needed to reproduce across restarts, similarly to "//& "what is already being done with the primary state variables. "//& "The default should be changed to true.", default=.false., do_not_log=.true.) - if (CS%remap_aux .and. .not.CS%store_CAu) call MOM_error(FATAL, & - "REMAP_AUXILIARY_VARS requires that STORE_CORIOLIS_ACCEL = True.") call get_param(param_file, mdl, "DEBUG", CS%debug, & "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) @@ -1419,8 +1412,6 @@ subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, para MIS%pbce => CS%pbce MIS%u_accel_bt => CS%u_accel_bt MIS%v_accel_bt => CS%v_accel_bt - MIS%u_av => CS%u_av - MIS%v_av => CS%v_av CS%ADp => Accel_diag CS%CDp => Cont_diag @@ -1447,9 +1438,6 @@ subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, para ! Accel_diag%u_accel_bt => CS%u_accel_bt ; Accel_diag%v_accel_bt => CS%v_accel_bt ! Accel_diag%u_av => CS%u_av ; Accel_diag%v_av => CS%v_av - id_clock_pass_init = cpu_clock_id('(Ocean init message passing)', & - grain=CLOCK_ROUTINE) - call continuity_init(Time, G, GV, US, param_file, diag, CS%continuity_CSp) cont_stencil = continuity_stencil(CS%continuity_CSp) call CoriolisAdv_init(Time, G, GV, US, param_file, diag, CS%ADp, CS%CoriolisAdv) @@ -1494,87 +1482,6 @@ subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, para CS%barotropic_CSp, restart_CS, calc_dtbt, CS%BT_cont, & CS%SAL_CSp) - if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & - .not. query_initialized(CS%diffv, "diffv", restart_CS)) then - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & - 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) - endif - - if (.not. query_initialized(CS%u_av, "u2", restart_CS) .or. & - .not. query_initialized(CS%v_av, "v2", restart_CS)) then - do k=1,nz ; do j=jsd,jed ; do I=IsdB,IedB ; CS%u_av(I,j,k) = u(I,j,k) ; enddo ; enddo ; enddo - 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) - endif - - if (CS%store_CAu) then - if (query_initialized(CS%CAu_pred, "CAu", restart_CS) .and. & - query_initialized(CS%CAv_pred, "CAv", restart_CS)) then - CS%CAu_pred_stored = .true. - else - call only_read_from_restarts(uh, vh, 'uh', 'vh', G, restart_CS, stagger=CGRID_NE, & - filename=dirs%input_filename, directory=dirs%restart_input_dir, & - success=read_uv, scale=US%m_to_L**2*US%T_to_s/GV%H_to_mks) - call only_read_from_restarts('h2', CS%h_av, G, restart_CS, & - filename=dirs%input_filename, directory=dirs%restart_input_dir, & - success=read_h2, scale=1.0/GV%H_to_mks) - if (read_uv .and. read_h2) then - call pass_var(CS%h_av, G%Domain, clock=id_clock_pass_init) - else - do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo - call continuity(CS%u_av, CS%v_av, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) - call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) - enddo ; enddo ; enddo - endif - call pass_vector(CS%u_av, CS%v_av, G%Domain, halo=2, clock=id_clock_pass_init, complete=.false.) - call pass_vector(uh, vh, G%Domain, halo=2, clock=id_clock_pass_init, complete=.true.) - call CorAdCalc(CS%u_av, CS%v_av, CS%h_av, uh, vh, CS%CAu_pred, CS%CAv_pred, CS%OBC, CS%ADp, & - G, GV, US, CS%CoriolisAdv, pbv) !, Waves=Waves) - CS%CAu_pred_stored = .true. - endif - else - CS%CAu_pred_stored = .false. - ! This call is just here to initialize uh and vh. - if (.not. query_initialized(uh, "uh", restart_CS) .or. & - .not. query_initialized(vh, "vh", restart_CS)) then - do k=1,nz ; do j=jsd,jed ; do i=isd,ied ; h_tmp(i,j,k) = h(i,j,k) ; enddo ; enddo ; enddo - call continuity(u, v, h, h_tmp, uh, vh, dt, G, GV, US, CS%continuity_CSp, CS%OBC, pbv) - call pass_var(h_tmp, G%Domain, clock=id_clock_pass_init) - do k=1,nz ; do j=jsd,jed ; do i=isd,ied - CS%h_av(i,j,k) = 0.5*(h(i,j,k) + h_tmp(i,j,k)) - enddo ; enddo ; enddo - call set_initialized(uh, "uh", restart_CS) - call set_initialized(vh, "vh", restart_CS) - call set_initialized(CS%h_av, "h2", restart_CS) - ! Try reading the CAu and CAv fields from the restart file, in case this restart file is - ! using a newer format. - call only_read_from_restarts(CS%CAu_pred, CS%CAv_pred, "CAu", "CAv", G, restart_CS, & - stagger=CGRID_NE, filename=dirs%input_filename, directory=dirs%restart_input_dir, & - success=read_uv, scale=US%m_s_to_L_T*US%T_to_s) - CS%CAu_pred_stored = read_uv - else - if (.not. query_initialized(CS%h_av, "h2", restart_CS)) then - CS%h_av(:,:,:) = h(:,:,:) - call set_initialized(CS%h_av, "h2", restart_CS) - endif - endif - endif - call cpu_clock_begin(id_clock_pass_init) - call create_group_pass(pass_av_h_uvh, CS%u_av, CS%v_av, G%Domain, halo=2) - if (CS%CAu_pred_stored) then - call create_group_pass(pass_av_h_uvh, CS%CAu_pred, CS%CAv_pred, G%Domain, halo=2) - else - call create_group_pass(pass_av_h_uvh, CS%h_av, G%Domain, halo=2) - call create_group_pass(pass_av_h_uvh, uh, vh, G%Domain, halo=2) - endif - call do_group_pass(pass_av_h_uvh, G%Domain) - call cpu_clock_end(id_clock_pass_init) - flux_units = get_flux_units(GV) thickness_units = get_thickness_units(GV) CS%id_uh = register_diag_field('ocean_model', 'uh', diag%axesCuL, Time, & @@ -1800,11 +1707,11 @@ subroutine end_dyn_split_RK2b(CS) if (associated(CS%taux_bot)) deallocate(CS%taux_bot) if (associated(CS%tauy_bot)) deallocate(CS%tauy_bot) DEALLOC_(CS%uhbt) ; DEALLOC_(CS%vhbt) + DEALLOC_(CS%du_av_inst) ; DEALLOC_(CS%dv_av_inst) DEALLOC_(CS%u_accel_bt) ; DEALLOC_(CS%v_accel_bt) DEALLOC_(CS%visc_rem_u) ; DEALLOC_(CS%visc_rem_v) DEALLOC_(CS%eta) ; DEALLOC_(CS%eta_PF) ; DEALLOC_(CS%pbce) - DEALLOC_(CS%h_av) ; DEALLOC_(CS%u_av) ; DEALLOC_(CS%v_av) call dealloc_BT_cont_type(CS%BT_cont) deallocate(CS%AD_pred) From 9d57c15f6cada3ac98e0e7dc5c6a1d78b6c69409 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 17 Dec 2023 10:39:30 -0500 Subject: [PATCH 510/629] Regroup MOM_dynamics_split_RK2b halo updates This commit includes further revisions to MOM_dynamics_split_RK2b that avoid some unnecessary calculations and group some of the halo updates into fewer group passes. All answers are bitwise identical. --- src/core/MOM_dynamics_split_RK2b.F90 | 157 +++++++++------------------ 1 file changed, 53 insertions(+), 104 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 9cd8fbfc09..44a0b0bf5c 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -253,14 +253,13 @@ module MOM_dynamics_split_RK2b !> A pointer to the update_OBC control structure type(update_OBC_CS), pointer :: update_OBC_CSp => NULL() - type(group_pass_type) :: pass_eta !< Structure for group halo pass - type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass - type(group_pass_type) :: pass_uvp !< Structure for group halo pass - type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass - type(group_pass_type) :: pass_h_av !< Structure for group halo pass - type(group_pass_type) :: pass_uv !< Structure for group halo pass - type(group_pass_type) :: pass_h !< Structure for group halo pass - type(group_pass_type) :: pass_av_uvh !< Structure for group halo pass + type(group_pass_type) :: pass_eta !< Structure for group halo pass + type(group_pass_type) :: pass_visc_rem !< Structure for group halo pass + type(group_pass_type) :: pass_uvp !< Structure for group halo pass + type(group_pass_type) :: pass_uv_inst !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uv !< Structure for group halo pass + type(group_pass_type) :: pass_hp_uhvh !< Structure for group halo pass + type(group_pass_type) :: pass_h_uv !< Structure for group halo pass end type MOM_dyn_split_RK2b_CS @@ -394,7 +393,6 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc logical :: BT_cont_BT_thick ! If true, use the BT_cont_type to estimate the ! relative weightings of the layers in calculating ! the barotropic accelerations. - logical :: Use_Stokes_PGF ! If true, add Stokes PGF to hydrostatic PGF !---For group halo pass logical :: showCallTree, sym @@ -469,17 +467,18 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call create_group_pass(CS%pass_visc_rem, CS%visc_rem_u, CS%visc_rem_v, G%Domain, & To_All+SCALAR_PAIR, CGRID_NE, halo=max(1,cont_stencil)) call create_group_pass(CS%pass_uvp, up, vp, G%Domain, halo=max(1,cont_stencil)) + call create_group_pass(CS%pass_uv_inst, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_hp_uv, hp, G%Domain, halo=2) call create_group_pass(CS%pass_hp_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) call create_group_pass(CS%pass_hp_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_uv, u_inst, v_inst, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_h, h, G%Domain, halo=max(2,cont_stencil)) - call create_group_pass(CS%pass_av_uvh, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_av_uvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_hp_uhvh, hp, G%Domain, halo=2) + call create_group_pass(CS%pass_hp_uhvh, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) - call create_group_pass(CS%pass_h_av, hp, G%Domain, halo=2) - call create_group_pass(CS%pass_h_av, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_h_uv, h, G%Domain, halo=max(2,cont_stencil)) + call create_group_pass(CS%pass_h_uv, u_av, v_av, G%Domain, halo=max(2,obc_stencil)) + call create_group_pass(CS%pass_h_uv, uh(:,:,:), vh(:,:,:), G%Domain, halo=max(2,obc_stencil)) call cpu_clock_end(id_clock_pass) !--- end set up for group halo pass @@ -495,7 +494,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call cpu_clock_end(id_clock_continuity) if (G%nonblocking_updates) & - call start_group_pass(CS%pass_h_av, G%Domain, clock=id_clock_pass) + call start_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) ! PFu = d/dx M(h,T,S) ! pbce = dM/deta @@ -511,31 +510,22 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc enddo ; enddo endif ! Stokes shear force contribution to pressure gradient - Use_Stokes_PGF = present(Waves) - if (Use_Stokes_PGF) then - Use_Stokes_PGF = associated(Waves) - if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF - if (Use_Stokes_PGF) then - call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) - - ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv - ! will therefore report the sum total PGF and we avoid other - ! modifications in the code. The PFu_Stokes is output within the waves routines. - if (.not.Waves%Passive_Stokes_PGF) then - do k=1,nz - do j=js,je ; do I=Isq,Ieq - CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) - enddo ; enddo - enddo - do k=1,nz - do J=Jsq,Jeq ; do i=is,ie - CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) - enddo ; enddo - enddo - endif + if (present(Waves)) then ; if (associated(Waves)) then ; if (Waves%Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + + ! We are adding Stokes_PGF to hydrostatic PGF here. The diag PFu/PFv + ! will therefore report the sum total PGF and we avoid other + ! modifications in the code. The PFu_Stokes is output within the waves routines. + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo ; enddo endif - endif + endif ; endif ; endif call cpu_clock_end(id_clock_pres) call disable_averaging(CS%diag) if (showCallTree) call callTree_wayPoint("done with PressureForce (step_MOM_dyn_split_RK2b)") @@ -544,15 +534,15 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call open_boundary_zero_normal_flow(CS%OBC, G, GV, CS%PFu, CS%PFv) if (G%nonblocking_updates) then - call complete_group_pass(CS%pass_h_av, G%Domain, clock=id_clock_pass) + call complete_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) call start_group_pass(CS%pass_eta, G%Domain, clock=id_clock_pass) else - call do_group_pass(CS%pass_h_av, G%Domain, clock=id_clock_pass) + call do_group_pass(CS%pass_hp_uhvh, G%Domain, clock=id_clock_pass) endif !$OMP parallel do default(shared) do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 - h_av(i,j,k) = 0.5*(hp(i,j,k) + h(i,j,k)) + h_av(i,j,k) = 0.5*(h(i,j,k) + hp(i,j,k)) enddo ; enddo ; enddo ! Calculate a predictor-step estimate of the Coriolis and momentum advection terms @@ -660,7 +650,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc v_inst(i,J,k) = v_av(i,J,k) - CS%dv_av_inst(i,j) * CS%visc_rem_v(i,J,k) enddo ; enddo ; enddo call cpu_clock_end(id_clock_mom_update) - call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) ! u_accel_bt = layer accelerations due to barotropic solver call cpu_clock_begin(id_clock_continuity) @@ -781,7 +771,6 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) if (associated(CS%OBC)) then - if (CS%debug) & call uvchksum("Pre OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) @@ -789,13 +778,6 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (CS%debug) & call uvchksum("Post OBC avg [uv]", u_av, v_av, G%HI, haloshift=1, symmetric=sym, scale=US%L_T_to_m_s) - - ! These should be done with a pass that excludes uh & vh. -! call do_group_pass(CS%pass_hp_uv, G%Domain, clock=id_clock_pass) - endif - - if (G%nonblocking_updates) then - call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) endif ! h_av = (h + hp)/2 @@ -830,34 +812,22 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc call PressureForce(hp, tv, CS%PFu, CS%PFv, G, GV, US, CS%PressureForce_CSp, & CS%ALE_CSp, p_surf, CS%pbce, CS%eta_PF) ! Stokes shear force contribution to pressure gradient - Use_Stokes_PGF = present(Waves) - if (Use_Stokes_PGF) then - Use_Stokes_PGF = associated(Waves) - if (Use_Stokes_PGF) Use_Stokes_PGF = Waves%Stokes_PGF - if (Use_Stokes_PGF) then - call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) - call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) - if (.not.Waves%Passive_Stokes_PGF) then - do k=1,nz - do j=js,je ; do I=Isq,Ieq - CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) - enddo ; enddo - enddo - do k=1,nz - do J=Jsq,Jeq ; do i=is,ie - CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) - enddo ; enddo - enddo - endif + if (present(Waves)) then ; if (associated(Waves)) then ; if (Waves%Stokes_PGF) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=1) + call Stokes_PGF(G, GV, US, dz, u_av, v_av, CS%PFu_Stokes, CS%PFv_Stokes, Waves) + if (.not.Waves%Passive_Stokes_PGF) then + do k=1,nz ; do j=js,je ; do I=Isq,Ieq + CS%PFu(I,j,k) = CS%PFu(I,j,k) + CS%PFu_Stokes(I,j,k) + enddo ; enddo ; enddo + do k=1,nz ; do J=Jsq,Jeq ; do i=is,ie + CS%PFv(i,J,k) = CS%PFv(i,J,k) + CS%PFv_Stokes(i,J,k) + enddo ; enddo ; enddo endif - endif + endif ; endif ; endif call cpu_clock_end(id_clock_pres) if (showCallTree) call callTree_wayPoint("done with PressureForce[hp=(1-b).h+b.h] (step_MOM_dyn_split_RK2b)") endif - if (G%nonblocking_updates) & - call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) - if (BT_cont_BT_thick) then call btcalc(h, G, GV, CS%barotropic_CSp, CS%BT_cont%h_u, CS%BT_cont%h_v, & OBC=CS%OBC) @@ -994,24 +964,18 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (G%nonblocking_updates) then call cpu_clock_end(id_clock_vertvisc) - call start_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + call start_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) call cpu_clock_begin(id_clock_vertvisc) endif call vertvisc_remnant(visc, CS%visc_rem_u, CS%visc_rem_v, dt, G, GV, US, CS%vertvisc_CSp) call cpu_clock_end(id_clock_vertvisc) if (showCallTree) call callTree_wayPoint("done with vertvisc (step_MOM_dyn_split_RK2b)") -! Later, h_av = (h_in + h_out)/2, but for now use h_av to store h_in. - !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 - h_av(i,j,k) = h(i,j,k) - enddo ; enddo ; enddo - call do_group_pass(CS%pass_visc_rem, G%Domain, clock=id_clock_pass) if (G%nonblocking_updates) then - call complete_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + call complete_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) else - call do_group_pass(CS%pass_uv, G%Domain, clock=id_clock_pass) + call do_group_pass(CS%pass_uv_inst, G%Domain, clock=id_clock_pass) endif ! uh = u_av * h @@ -1032,31 +996,18 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! enddo ; enddo ; enddo call cpu_clock_end(id_clock_continuity) - call do_group_pass(CS%pass_h, G%Domain, clock=id_clock_pass) + + call do_group_pass(CS%pass_h_uv, G%Domain, clock=id_clock_pass) + ! 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) if (showCallTree) call callTree_wayPoint("done with continuity (step_MOM_dyn_split_RK2b)") - if (G%nonblocking_updates) then - call start_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) - else - call do_group_pass(CS%pass_av_uvh, G%domain, clock=id_clock_pass) - endif - if (associated(CS%OBC)) then call radiation_open_bdry_conds(CS%OBC, u_av, u_old_rad_OBC, v_av, v_old_rad_OBC, G, GV, US, dt) endif - ! h_av = (h_in + h_out)/2 . Going in to this line, h_av = h_in. - !$OMP parallel do default(shared) - do k=1,nz ; do j=js-2,je+2 ; do i=is-2,ie+2 - h_av(i,j,k) = 0.5*(h_av(i,j,k) + h(i,j,k)) - enddo ; enddo ; enddo - - if (G%nonblocking_updates) & - call complete_group_pass(CS%pass_av_uvh, G%Domain, clock=id_clock_pass) - !$OMP parallel do default(shared) do k=1,nz do j=js-2,je+2 ; do I=Isq-2,Ieq+2 @@ -1169,10 +1120,8 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc if (CS%id_deta_dt > 0) call post_data(CS%id_deta_dt, deta_dt, CS%diag) if (CS%debug) then - call MOM_state_chksum("Corrector ", u_inst, v_inst, 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_MKS) - ! call MOM_state_chksum("Corrector avg ", u_av, v_av, h_av, uh, vh, G, GV, US) + call MOM_state_chksum("Corrector ", u_av, v_av, h, uh, vh, G, GV, US, symmetric=sym) + ! call uvchksum("Corrector inst [uv]", u_inst, v_inst, G%HI, symmetric=sym, scale=US%L_T_to_m_s) endif if (showCallTree) call callTree_leave("step_MOM_dyn_split_RK2b()") From 5137442fc91aced5162e00f5b8d2a1b5906b8e32 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 Dec 2023 16:44:53 -0500 Subject: [PATCH 511/629] +Correct description of SPLIT_RK2B Corrected the description of the runtime parameter SPLIT_RK2B that will appear in the MOM_parameter_doc files and in the doxygen descriptions of the MOM module to better reflect what was ultimately being done with this new scheme. All answers are bitwise identical, but there are changes to the (newly added) contents of some MOM_parameter_doc files. --- src/core/MOM.F90 | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e1f31b7558..2800011ccf 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -288,8 +288,9 @@ module MOM !! undocumented run-time flag that is fragile. logical :: split !< If true, use the split time stepping scheme. logical :: use_alt_split !< If true, use a version of the split explicit time stepping - !! with a heavier emphasis on consistent tranports between the - !! layered and barotroic variables. + !! scheme that exchanges velocities with step_MOM that have the + !! average barotropic phase over a baroclinic timestep rather + !! than the instantaneous barotropic phase. logical :: use_RK2 !< If true, use RK2 instead of RK3 in unsplit mode !! (i.e., no split between barotropic and baroclinic). logical :: interface_filter !< If true, apply an interface height filter immediately @@ -2174,8 +2175,9 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call get_param(param_file, "MOM", "SPLIT", CS%split, & "Use the split time stepping if true.", default=.true.) call get_param(param_file, "MOM", "SPLIT_RK2B", CS%use_alt_split, & - "If true, use a version of the split explicit time stepping with a heavier "//& - "emphasis on consistent tranports between the layered and barotroic variables.", & + "If true, use a version of the split explicit time stepping scheme that "//& + "exchanges velocities with step_MOM that have the average barotropic phase over "//& + "a baroclinic timestep rather than the instantaneous barotropic phase.", & default=.false., do_not_log=.not.CS%split) if (CS%split) then CS%use_RK2 = .false. From a03bb957c035c68ee600cacef8c8f8315c18f87a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 Dec 2023 17:02:40 -0500 Subject: [PATCH 512/629] +Add cuberoot function Added the new functions cuberoot and intrinsic_functions_unit_tests to the MOM_intrinsic_functions module, and call intrinsic_functions_unit_tests from unit_tests to confirm that this new function works as intended. Separately, cuberoot was tested by replacing expressions like A**(1./3.) with cuberoot(A) in MOM_energetic_PBL and verifying that the answers only change at roundoff, but that it can give bitwise identical results when the argument is scaled by an integer power of 8 and then unscaled by the corresponding integer power of 2, but that change will occur in a subsequent commit as it can change answers depending on an ANSWER_DATE flag. With this commit, cuberoot is not yet being used so all answers are bitwise identical, although there are new publicly visible routines. --- src/core/MOM_unit_tests.F90 | 13 ++- src/framework/MOM_intrinsic_functions.F90 | 132 +++++++++++++++++++++- 2 files changed, 139 insertions(+), 6 deletions(-) diff --git a/src/core/MOM_unit_tests.F90 b/src/core/MOM_unit_tests.F90 index 89383c4936..bd449d0b39 100644 --- a/src/core/MOM_unit_tests.F90 +++ b/src/core/MOM_unit_tests.F90 @@ -4,15 +4,16 @@ module MOM_unit_tests ! This file is part of MOM6. See LICENSE.md for the license. use MOM_error_handler, only : MOM_error, FATAL, is_root_pe - -use MOM_string_functions, only : string_functions_unit_tests -use MOM_remapping, only : remapping_unit_tests +use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests +use MOM_intrinsic_functions, only : intrinsic_functions_unit_tests +use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests use MOM_neutral_diffusion, only : neutral_diffusion_unit_tests use MOM_random, only : random_unit_tests -use MOM_hor_bnd_diffusion, only : near_boundary_unit_tests +use MOM_remapping, only : remapping_unit_tests +use MOM_string_functions, only : string_functions_unit_tests use MOM_CFC_cap, only : CFC_cap_unit_tests use MOM_EOS, only : EOS_unit_tests -use MOM_mixed_layer_restrat, only : mixedlayer_restrat_unit_tests + implicit none ; private public unit_tests @@ -36,6 +37,8 @@ subroutine unit_tests(verbosity) "MOM_unit_tests: EOS_unit_tests FAILED") if (remapping_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: remapping_unit_tests FAILED") + if (intrinsic_functions_unit_tests(verbose)) call MOM_error(FATAL, & + "MOM_unit_tests: intrinsic_functions_unit_tests FAILED") if (neutral_diffusion_unit_tests(verbose)) call MOM_error(FATAL, & "MOM_unit_tests: neutralDiffusionUnitTests FAILED") if (random_unit_tests(verbose)) call MOM_error(FATAL, & diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 2439c628fc..808bc408a8 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -4,9 +4,12 @@ module MOM_intrinsic_functions ! This file is part of MOM6. See LICENSE.md for the license. +use iso_fortran_env, only : stdout => output_unit, stderr => error_unit + implicit none ; private -public :: invcosh +public :: invcosh, cuberoot +public :: intrinsic_functions_unit_tests contains @@ -25,4 +28,131 @@ function invcosh(x) end function invcosh +!> Returns the cube root of a real argument at roundoff accuracy, in a form that works properly with +!! rescaling of the argument by integer powers of 8. If the argument is a NaN, a NaN is returned. +elemental function cuberoot(x) result(root) + real, intent(in) :: x !< The argument of cuberoot in arbitrary units cubed [A3] + real :: root !< The real cube root of x in arbitrary units [A] + + real :: asx ! The absolute value of x rescaled by an integer power of 8 to put it into + ! the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] + real :: root_asx ! The cube root of asx [B] + real :: num ! The numerator of an expression for the evolving estimate of the cube root of asx + ! in arbitrary units that can grow or shrink with each iteration [B C] + real :: den ! The denominator of an expression for the evolving estimate of the cube root of asx + ! in arbitrary units that can grow or shrink with each iteration [C] + real :: num_prev ! The numerator of an expression for the previous iteration of the evolving estimate + ! of the cube root of asx in arbitrary units that can grow or shrink with each iteration [B D] + real :: den_prev ! The denominator of an expression for the previous iteration of the evolving estimate of + ! the cube root of asx in arbitrary units that can grow or shrink with each iteration [D] + real, parameter :: den_min = 2.**(minexponent(1.) / 4 + 4) ! A value of den that triggers rescaling [C] + real, parameter :: den_max = 2.**(maxexponent(1.) / 4 - 2) ! A value of den that triggers rescaling [C] + integer :: ex_3 ! One third of the exponent part of x, used to rescale x to get a. + integer :: itt + + if ((x >= 0.0) .eqv. (x <= 0.0)) then + ! Return 0 for an input of 0, or NaN for a NaN input. + root = x + else + ex_3 = ceiling(exponent(x) / 3.) + ! Here asx is in the range of 0.125 <= asx < 1.0 + asx = scale(abs(x), -3*ex_3) + + ! This first estimate is one iteration of Newton's method with a starting guess of 1. It is + ! always an over-estimate of the true solution, but it is a good approximation for asx near 1. + num = 2.0 + asx + den = 3.0 + ! Iteratively determine Root = asx**1/3 using Newton's method, noting that in this case Newton's + ! method converges monotonically from above and needs no bounding. For the range of asx from + ! 0.125 to 1.0 with the first guess used above, 6 iterations suffice to converge to roundoff. + do itt=1,9 + ! Newton's method iterates estimates as Root = Root - (Root**3 - asx) / (3.0 * Root**2), or + ! equivalently as Root = (2.0*Root**2 + asx) / (3.0 * Root**2). + ! Keeping the estimates in a fractional form Root = num / den allows this calculation with + ! fewer (or no) real divisions during the iterations before doing a single real division + ! at the end, and it is therefore more computationally efficient. + + num_prev = num ; den_prev = den + num = 2.0 * num_prev**3 + asx * den_prev**3 + den = 3.0 * (den_prev * num_prev**2) + + if ((num * den_prev == num_prev * den) .or. (itt == 9)) then + ! If successive estimates of root are identical, this is a converged solution. + root_asx = num / den + exit + elseif (num * den_prev > num_prev * den) then + ! If the estimates are increasing, this also indicates convergence, but for a more subtle + ! reason. Because Newton's method converges monotonically from above (at least for infinite + ! precision math), the only reason why this estimate could increase is if the iterations + ! have converged to a roundoff-level limit cycle around an irrational or otherwise + ! unrepresentable solution, with values only changing in the last bit or two. If so, we + ! should stop iterating and accept the one of the current or previous solutions, both of + ! which will be within numerical roundoff of the true solution. + root_asx = num / den + ! Pick the more accurate of the last two iterations. + ! Given that both of the two previous iterations are within roundoff of the true + ! solution, this next step might be overkill. + if ( abs(den_prev**3*root_asx**3 - den_prev**3*asx) > abs(num_prev**3 - den_prev**3*asx) ) then + ! The previous iteration was slightly more accurate, so use that for root_asx. + root_asx = num_prev / den_prev + endif + exit + endif + + ! Because successive estimates of the numerator and denominator tend to be the cube of their + ! predecessors, the numerator and denominator need to be rescaled by division when they get + ! too large or small to avoid overflow or underflow in the convergence test below. + if ((den > den_max) .or. (den < den_min)) then + num = scale(num, -exponent(den)) + den = scale(den, -exponent(den)) + endif + + enddo + + root = sign(scale(root_asx, ex_3), x) + endif + +end function cuberoot + +!> Returns true if any unit test of intrinsic_functions fails, or false if they all pass. +logical function intrinsic_functions_unit_tests(verbose) + logical, intent(in) :: verbose !< If true, write results to stdout + + ! Local variables + real :: testval ! A test value for self-consistency testing [nondim] + logical :: fail, v + + fail = .false. + v = verbose + write(stdout,*) '==== MOM_intrinsic_functions: intrinsic_functions_unit_tests ===' + + fail = fail .or. Test_cuberoot(v, 1.2345678901234e9) + fail = fail .or. Test_cuberoot(v, -9.8765432109876e-21) + fail = fail .or. Test_cuberoot(v, 64.0) + fail = fail .or. Test_cuberoot(v, -0.5000000000001) + fail = fail .or. Test_cuberoot(v, 0.0) + fail = fail .or. Test_cuberoot(v, 1.0) + fail = fail .or. Test_cuberoot(v, 0.125) + fail = fail .or. Test_cuberoot(v, 0.965) + +end function intrinsic_functions_unit_tests + +!> True if the cube of cuberoot(val) does not closely match val. False otherwise. +logical function Test_cuberoot(verbose, val) + logical, intent(in) :: verbose !< If true, write results to stdout + real, intent(in) :: val !< The real value to test, in arbitrary units [A] + ! Local variables + real :: diff ! The difference between val and the cube root of its cube. + + diff = val - cuberoot(val**3) + Test_cuberoot = (abs(diff) > 2.0e-15*abs(val)) + + if (Test_cuberoot) then + write(stdout, '("For val = ",ES22.15,", (val - cuberoot(val**3))) = ",ES9.2," <-- FAIL")') val, diff + elseif (verbose) then + write(stdout, '("For val = ",ES22.15,", (val - cuberoot(val**3))) = ",ES9.2)') val, diff + + endif +end function Test_cuberoot + end module MOM_intrinsic_functions From a728ceaa5b1bc27524eb9b04dc0955cc01c4e89f Mon Sep 17 00:00:00 2001 From: "denise.worthen" Date: Fri, 12 Jan 2024 09:19:34 -0600 Subject: [PATCH 513/629] allow restarts to be set on non-interval hours - add restart_fh config variable and define restartfhtimes to enable restarts on non-interval hours - write info to stdout for documenting when additional restarts will or will not be written --- config_src/drivers/nuopc_cap/mom_cap.F90 | 77 ++++++++++++++++++++++-- 1 file changed, 71 insertions(+), 6 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 2fdd6f59f9..778a3486b9 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -153,6 +153,8 @@ module MOM_cap_mod character(len=16) :: inst_suffix = '' real(8) :: timere +type(ESMF_Time), allocatable :: restartFhTimes(:) + contains !> NUOPC SetService method is the only public entry point. @@ -378,6 +380,7 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) geomtype = ESMF_GEOMTYPE_GRID endif + end subroutine !> Called by NUOPC to advertise import and export fields. "Advertise" @@ -613,7 +616,7 @@ subroutine InitializeAdvertise(gcomp, importState, exportState, clock, rc) open(newunit=readunit, file=rpointer_filename, form='formatted', status='old', iostat=iostat) if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_FILE_OPEN, msg=subname//' ERROR opening '//rpointer_filename, & - line=__LINE__, file=u_FILE_u, rcToReturn=rc) + line=__LINE__, file=u_FILE_u, rcToReturn=rc) return endif do @@ -1534,6 +1537,8 @@ subroutine ModelAdvance(gcomp, rc) character(len=:), allocatable :: rpointer_filename integer :: num_rest_files real(8) :: MPI_Wtime, timers + logical :: write_restart + logical :: write_restartfh rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1685,13 +1690,26 @@ subroutine ModelAdvance(gcomp, rc) call ESMF_ClockGetAlarm(clock, alarmname='restart_alarm', alarm=restart_alarm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restartfh = .false. + ! check if next time is == to any restartfhtime + if (allocated(RestartFhTimes)) then + do n = 1,size(RestartFhTimes) + call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (MyTime == RestartFhTimes(n)) write_restartfh = .true. + end do + end if + + write_restart = .false. if (ESMF_AlarmIsRinging(restart_alarm, rc=rc)) then if (ChkErr(rc,__LINE__,u_FILE_u)) return - + write_restart = .true. ! turn off the alarm call ESMF_AlarmRingerOff(restart_alarm, rc=rc ) if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + if (write_restart .or. write_restartfh) then ! determine restart filename call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1714,7 +1732,7 @@ subroutine ModelAdvance(gcomp, rc) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) if (localPet == 0) then - ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean + ! Write name of restart file in the rpointer file - this is currently hard-coded for the ocean open(newunit=writeunit, file=rpointer_filename, form='formatted', status='unknown', iostat=iostat) if (iostat /= 0) then call ESMF_LogSetError(ESMF_RC_FILE_OPEN, & @@ -1791,25 +1809,34 @@ end subroutine ModelAdvance subroutine ModelSetRunClock(gcomp, rc) + + use ESMF, only : ESMF_TimeIntervalSet + type(ESMF_GridComp) :: gcomp integer, intent(out) :: rc ! local variables + type(ESMF_VM) :: vm type(ESMF_Clock) :: mclock, dclock type(ESMF_Time) :: mcurrtime, dcurrtime type(ESMF_Time) :: mstoptime, dstoptime type(ESMF_TimeInterval) :: mtimestep, dtimestep + type(ESMF_TimeInterval) :: fhInterval character(len=128) :: mtimestring, dtimestring + character(len=256) :: timestr character(len=256) :: cvalue character(len=256) :: restart_option ! Restart option units integer :: restart_n ! Number until restart interval integer :: restart_ymd ! Restart date (YYYYMMDD) + integer :: dt_cpl ! coupling timestep type(ESMF_Alarm) :: restart_alarm type(ESMF_Alarm) :: stop_alarm logical :: isPresent, isSet logical :: first_time = .true. - character(len=*),parameter :: subname='MOM_cap:(ModelSetRunClock) ' - character(len=256) :: timestr + integer :: localPet + integer :: n, nfh + integer, allocatable :: restart_fh(:) + character(len=*),parameter :: subname='(MOM_cap:ModelSetRunClock) ' !-------------------------------- rc = ESMF_SUCCESS @@ -1825,6 +1852,11 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_ClockGet(mclock, currTime=mcurrtime, timeStep=mtimestep, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_GridCompGet(gcomp, vm=vm, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call ESMF_VMGet(vm, localPet=localPet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + !-------------------------------- ! check that the current time in the model and driver are the same !-------------------------------- @@ -1948,8 +1980,41 @@ subroutine ModelSetRunClock(gcomp, rc) call ESMF_TimeGet(dstoptime, timestring=timestr, rc=rc) call ESMF_LogWrite("Stop Alarm will ring at : "//trim(timestr), ESMF_LOGMSG_INFO) - first_time = .false. + ! set up Times to write non-interval restarts + call NUOPC_CompAttributeGet(gcomp, name='restart_fh', isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + call ESMF_TimeIntervalGet(dtimestep, s=dt_cpl, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + call NUOPC_CompAttributeGet(gcomp, name='restart_fh', value=cvalue, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + + ! convert string to a list of integer restart_fh values + nfh = 1 + count(transfer(trim(cvalue), 'a', len(cvalue)) == ",") + allocate(restart_fh(1:nfh)) + allocate(restartFhTimes(1:nfh)) + read(cvalue,*)restart_fh(1:nfh) + + ! create a list of times at each restart_fh + do n = 1,nfh + call ESMF_TimeIntervalSet(fhInterval, h=restart_fh(n), rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + restartFhTimes(n) = mcurrtime + fhInterval + call ESMF_TimePrint(restartFhTimes(n), options="string", preString="Restart_Fh at ", unit=timestr, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (localPet == 0) then + if (mod(3600*restart_fh(n),dt_cpl) /= 0) then + write(stdout,'(A)')trim(subname)//trim(timestr)//' will not be written' + else + write(stdout,'(A)')trim(subname)//trim(timestr)//' will be written' + end if + end if + end do + deallocate(restart_fh) + end if + + first_time = .false. endif !-------------------------------- From 8f73fb2c11fd66ea4edc0adac25cc4408bbe3269 Mon Sep 17 00:00:00 2001 From: Alper Altuntas Date: Sun, 14 Jan 2024 11:30:41 -0700 Subject: [PATCH 514/629] fix intraday CESM restart file names (#267) --- config_src/drivers/nuopc_cap/mom_cap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 843e8c2ef1..f4e510f3e5 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -1779,7 +1779,7 @@ subroutine ModelAdvance(gcomp, rc) rpointer_filename = 'rpointer.ocn'//trim(inst_suffix) write(restartname,'(A,".mom6.r.",I4.4,"-",I2.2,"-",I2.2,"-",I5.5)') & - trim(casename), year, month, day, seconds + trim(casename), year, month, day, hour * 3600 + minute * 60 + seconds call ESMF_LogWrite("MOM_cap: Writing restart : "//trim(restartname), ESMF_LOGMSG_INFO) ! write restart file(s) call ocean_model_restart(ocean_state, restartname=restartname, num_rest_files=num_rest_files) From d7d126a7fc9111c4035441f6402553efc0c64596 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 18 Jan 2024 14:36:02 -0500 Subject: [PATCH 515/629] Update Gaea F5 datasets path JOB_DIR in the Gaea-specific .gitlab-ci.yml configuration file is updated to use its F5 filesystem. --- .gitlab-ci.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5bc90daca4..2c4d92c424 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -9,7 +9,7 @@ stages: # that is unique to this pipeline. # We use the "fetch" strategy to speed up the startup of stages variables: - JOB_DIR: "/lustre/f2/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" + JOB_DIR: "/gpfs/f5/gfdl_o/scratch/oar.gfdl.ogrp-account/runner/builds/$CI_PIPELINE_ID" GIT_STRATEGY: fetch # Always eport value of $JOB_DIR From 4813b17c27b736103df03ff5e67e46363e528d81 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2024 16:35:43 -0500 Subject: [PATCH 516/629] *Use Halley method iterations in cuberoot function Modified the cuberoot function to do 3 iterations with Halley's method starting with a first guess that balances the errors at the two ends of the range of the iterations, before a final iteration with Newton's method that polishes the root and gives a solution that is accurate to machine precision. Following on performance testing of the previous version, all convergence testing has been removed and the same number of iterations are applied regardless of the input value. This changes answers at roundoff for code that uses the cuberoot function, so ideally this PR would be dealt with before the cuberoot becomes widely used. --- src/framework/MOM_intrinsic_functions.F90 | 70 +++++++---------------- 1 file changed, 20 insertions(+), 50 deletions(-) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 808bc408a8..8d8cdde39f 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -45,8 +45,6 @@ elemental function cuberoot(x) result(root) ! of the cube root of asx in arbitrary units that can grow or shrink with each iteration [B D] real :: den_prev ! The denominator of an expression for the previous iteration of the evolving estimate of ! the cube root of asx in arbitrary units that can grow or shrink with each iteration [D] - real, parameter :: den_min = 2.**(minexponent(1.) / 4 + 4) ! A value of den that triggers rescaling [C] - real, parameter :: den_max = 2.**(maxexponent(1.) / 4 - 2) ! A value of den that triggers rescaling [C] integer :: ex_3 ! One third of the exponent part of x, used to rescale x to get a. integer :: itt @@ -58,56 +56,28 @@ elemental function cuberoot(x) result(root) ! Here asx is in the range of 0.125 <= asx < 1.0 asx = scale(abs(x), -3*ex_3) - ! This first estimate is one iteration of Newton's method with a starting guess of 1. It is - ! always an over-estimate of the true solution, but it is a good approximation for asx near 1. - num = 2.0 + asx - den = 3.0 - ! Iteratively determine Root = asx**1/3 using Newton's method, noting that in this case Newton's - ! method converges monotonically from above and needs no bounding. For the range of asx from - ! 0.125 to 1.0 with the first guess used above, 6 iterations suffice to converge to roundoff. - do itt=1,9 - ! Newton's method iterates estimates as Root = Root - (Root**3 - asx) / (3.0 * Root**2), or - ! equivalently as Root = (2.0*Root**2 + asx) / (3.0 * Root**2). - ! Keeping the estimates in a fractional form Root = num / den allows this calculation with - ! fewer (or no) real divisions during the iterations before doing a single real division - ! at the end, and it is therefore more computationally efficient. - + ! Iteratively determine root_asx = asx**1/3 using Halley's method and then Newton's method, + ! noting that Halley's method onverges monotonically and needs no bounding. Halley's method is + ! slightly more complicated that Newton's method, but converges in a third fewer iterations. + ! Keeping the estimates in a fractional form Root = num / den allows this calculation with + ! no real divisions during the iterations before doing a single real division at the end, + ! and it is therefore more computationally efficient. + + ! This first estimate gives the same magnitude of errors for 0.125 and 1.0 after two iterations. + num = 0.707106 ; den = 1.0 + do itt=1,3 + ! Halley's method iterates estimates as Root = Root * (Root**3 + 2.*asx) / (2.*Root**3 + asx). num_prev = num ; den_prev = den - num = 2.0 * num_prev**3 + asx * den_prev**3 - den = 3.0 * (den_prev * num_prev**2) - - if ((num * den_prev == num_prev * den) .or. (itt == 9)) then - ! If successive estimates of root are identical, this is a converged solution. - root_asx = num / den - exit - elseif (num * den_prev > num_prev * den) then - ! If the estimates are increasing, this also indicates convergence, but for a more subtle - ! reason. Because Newton's method converges monotonically from above (at least for infinite - ! precision math), the only reason why this estimate could increase is if the iterations - ! have converged to a roundoff-level limit cycle around an irrational or otherwise - ! unrepresentable solution, with values only changing in the last bit or two. If so, we - ! should stop iterating and accept the one of the current or previous solutions, both of - ! which will be within numerical roundoff of the true solution. - root_asx = num / den - ! Pick the more accurate of the last two iterations. - ! Given that both of the two previous iterations are within roundoff of the true - ! solution, this next step might be overkill. - if ( abs(den_prev**3*root_asx**3 - den_prev**3*asx) > abs(num_prev**3 - den_prev**3*asx) ) then - ! The previous iteration was slightly more accurate, so use that for root_asx. - root_asx = num_prev / den_prev - endif - exit - endif - - ! Because successive estimates of the numerator and denominator tend to be the cube of their - ! predecessors, the numerator and denominator need to be rescaled by division when they get - ! too large or small to avoid overflow or underflow in the convergence test below. - if ((den > den_max) .or. (den < den_min)) then - num = scale(num, -exponent(den)) - den = scale(den, -exponent(den)) - endif - + num = num_prev * (num_prev**3 + 2.0 * asx * (den_prev**3)) + den = den_prev * (2.0 * num_prev**3 + asx * (den_prev**3)) + ! Equivalent to: root_asx = root_asx * (root_asx**3 + 2.*asx) / (2.*root_asx**3 + asx) enddo + ! At this point the error in root_asx is better than 1 part in 3e14. + root_asx = num / den + + ! One final iteration with Newton's method polishes up the root and gives a solution + ! that is within the last bit of the true solution. + root_asx = root_asx - (root_asx**3 - asx) / (3.0 * (root_asx**2)) root = sign(scale(root_asx, ex_3), x) endif From 17f1c40dfa881a4a834cbca61dc2ee9a41f6d6aa Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 26 Jan 2024 10:39:54 -0500 Subject: [PATCH 517/629] Cuberoot: Apply first iteration explicitly (#11) Applying the first iteration explicitly appears to speed up the cuberoot function by a bit over 20%: Before: Halley Final: 0.14174999999999999 After: Halley Final: 0.11080000000000001 There is an assumption that compilers will precompute the constants like `0.7 * (0.7)**3`, and that all will do so in the same manner. --- src/framework/MOM_intrinsic_functions.F90 | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 8d8cdde39f..4327cfa5a6 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -64,8 +64,11 @@ elemental function cuberoot(x) result(root) ! and it is therefore more computationally efficient. ! This first estimate gives the same magnitude of errors for 0.125 and 1.0 after two iterations. - num = 0.707106 ; den = 1.0 - do itt=1,3 + ! The first iteration is applied explicitly. + num = 0.707106 * (0.707106**3 + 2.0 * asx) + den = 2.0 * (0.707106**3) + asx + + do itt=1,2 ! Halley's method iterates estimates as Root = Root * (Root**3 + 2.*asx) / (2.*Root**3 + asx). num_prev = num ; den_prev = den num = num_prev * (num_prev**3 + 2.0 * asx * (den_prev**3)) From 435ccaae4e60ca8fd8b836d4b8239dc3fdcbc79b Mon Sep 17 00:00:00 2001 From: Ashley Barnes <53282288+ashjbarnes@users.noreply.github.com> Date: Tue, 30 Jan 2024 03:18:12 +1100 Subject: [PATCH 518/629] Data table documentation (#551) * Update forcing.rst * add more detail to forcing.rst removing ambiguity about yaml format. --- docs/forcing.rst | 28 ++++++++++++++++++++++++++++ 1 file changed, 28 insertions(+) diff --git a/docs/forcing.rst b/docs/forcing.rst index 911f708b68..8496317608 100644 --- a/docs/forcing.rst +++ b/docs/forcing.rst @@ -1,5 +1,33 @@ Forcing ======= +Data Override +------- +When running MOM6 with the Flexible Modelling System (FMS) coupler, forcing can be specified by a `data_table` file. This is particularly useful when running MOM6 with a data atmosphere, as paths to the relevent atmospheric forcing products (eg. JRA55-do or ERA5) can be provided here. Each item in the data table must be separated by a new line, and contains the following information: + +| ``gridname``: The component of the model this data applies to. eg. `atm` `ocn` `lnd` `ice`. +| ``fieldname_code``: The field name according to the model component. eg. `salt` +| ``fieldname_file``: The name of the field within the source file. +| ``file_name``: Path to the source file. +| ``interpol_method``: Interpolation method eg. `bilinear` +| ``factor``: A scalar by which to multiply the field ahead of passing it onto the model. This is a quick way to do unit conversions for example. + +| +The data table is commonly formatted by specifying each of the fields in the order listed above, with a new line for each entry. + +Example Format: + "ATM", "t_bot", "t2m", "./INPUT/2t_ERA5.nc", "bilinear", 1.0 + +A `yaml` format is also possible if you prefer. This is outlined in the `FMS data override `_ github page, along with other details. + +Speficying a constant value: + Rather than overriding with data from a file, one can also set a field to constant. To do this, pass empty strings to `fieldname_file` and `file_name`. The `factor` now corresponds to the override value. For example, the following sets the temperature at the bottom of the atmosphere to 290 Kelvin. + + + "ATM", "t_bot", "", "", "bilinear", 290.0 + +Which units do I need? + For configurations using SIS2 and MOM, a list of available surface flux variables along with the expected units can be found in the `flux_exchange `_ file. + .. toctree:: :maxdepth: 2 From f1e0f01a8efb63fd360ad6e4f9afc84ac6ea4af1 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sun, 28 Jan 2024 13:20:28 -0500 Subject: [PATCH 519/629] Params: Add do_not_log to param block open/close This patch adds `do_not_log` to `openParameterBlock`, to prevent logging of `BLOCK%` `%BLOCK` entry and exit calls. The argument was not added to `closeParameterBlock`, since this state can be tracked inside the `block` with a new `log_access` field in `parameter_block`. This flag does not extend to parameters within the block, since (as far as I know) there is no way for a `get_param` to know if it is within a block or not. Even if it could know this, there would need to be some careful handling of nested blocks. The potential block/parameter inconsistency should be supported at some point, but for now it is the user's responsibility to consistently apply `do_not_log` to blocks and its contents. --- src/framework/MOM_file_parser.F90 | 20 +++++++++++++++++--- 1 file changed, 17 insertions(+), 3 deletions(-) diff --git a/src/framework/MOM_file_parser.F90 b/src/framework/MOM_file_parser.F90 index 944ccfdf07..22d3789ea5 100644 --- a/src/framework/MOM_file_parser.F90 +++ b/src/framework/MOM_file_parser.F90 @@ -56,6 +56,8 @@ module MOM_file_parser !> Specify the active parameter block type, private :: parameter_block ; private character(len=240) :: name = '' !< The active parameter block name + logical :: log_access = .true. + !< Log the entry and exit of the block (but not its contents) end type parameter_block !> A structure that can be parsed to read and document run-time parameters. @@ -2082,17 +2084,29 @@ subroutine clearParameterBlock(CS) end subroutine clearParameterBlock !> Tags blockName onto the end of the active parameter block name -subroutine openParameterBlock(CS,blockName,desc) +subroutine openParameterBlock(CS, blockName, desc, do_not_log) type(param_file_type), intent(in) :: CS !< The control structure for the file_parser module, !! it is also a structure to parse for run-time parameters character(len=*), intent(in) :: blockName !< The name of a parameter block being added character(len=*), optional, intent(in) :: desc !< A description of the parameter block being added + logical, optional, intent(in) :: do_not_log + !< Log block entry if true. This only prevents logging of entry to the block, and not the contents. type(parameter_block), pointer :: block => NULL() + logical :: do_log + + do_log = .true. + if (present(do_not_log)) do_log = .not. do_not_log + if (associated(CS%blockName)) then block => CS%blockName block%name = pushBlockLevel(block%name,blockName) - call doc_openBlock(CS%doc,block%name,desc) + if (do_log) then + call doc_openBlock(CS%doc, block%name, desc) + block%log_access = .true. + else + block%log_access = .false. + endif else if (is_root_pe()) call MOM_error(FATAL, & 'openParameterBlock: A push was attempted before allocation.') @@ -2111,7 +2125,7 @@ subroutine closeParameterBlock(CS) if (is_root_pe().and.len_trim(block%name)==0) call MOM_error(FATAL, & 'closeParameterBlock: A pop was attempted on an empty stack. ("'//& trim(block%name)//'")') - call doc_closeBlock(CS%doc,block%name) + if (block%log_access) call doc_closeBlock(CS%doc, block%name) else if (is_root_pe()) call MOM_error(FATAL, & 'closeParameterBlock: A pop was attempted before allocation.') From 5ca70bac6dd4306a0e1d3b5c653aa679ac4e4fa4 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Tue, 9 Jan 2024 09:12:50 -0900 Subject: [PATCH 520/629] Open parameter block before querying BODNER23 Fix the error caused by readinging `MLE%BODNER23`, and instead explicitly opening and closing the parameter blocks. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index e21c33beaf..36a83cd43a 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1767,8 +1767,10 @@ 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.) - call get_param(param_file, mdl, "MLE%USE_BODNER23", use_Bodner, & + call openParameterBlock(param_file, 'MLE', do_not_log=.true.) + call get_param(param_file, mdl, "USE_BODNER23", use_Bodner, & default=.false., do_not_log=.true.) + call closeParameterBlock(param_file) 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.) From 541c2f47970adb809b24d9838d25ac2a716db980 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2024 16:55:18 -0500 Subject: [PATCH 521/629] (*)Oil_tracer_column_physics unit conversion fix Added a missing unit conversion factor to a hard-coded 10 m distance in oil_tracer_column_physics. This will not change answers in Boussinesq cases without any dimensional rescaling, but it will correct answers in a hypothetical non-Boussinesq case. Also made some white space in expressions near this fix more closely match the MOM6 style guide. No answers are affected in any known existing regression test cases or other runs. --- src/tracer/oil_tracer.F90 | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index fc8f82f0df..40d6f27b44 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -373,21 +373,21 @@ subroutine oil_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Add oil at the source location if (year>=CS%oil_start_year .and. year<=CS%oil_end_year .and. & CS%oil_source_i>-999 .and. CS%oil_source_j>-999) then - i=CS%oil_source_i ; j=CS%oil_source_j - k_max=nz ; h_total=0. + i = CS%oil_source_i ; j = CS%oil_source_j + k_max = nz ; h_total = 0. vol_scale = GV%H_to_m * US%L_to_m**2 do k=nz, 2, -1 h_total = h_total + h_new(i,j,k) - if (h_total<10.) k_max=k-1 ! Find bottom most interface that is 10 m above bottom + if (h_total < 10.*GV%m_to_H) k_max=k-1 ! Find bottom most interface that is 10 m above bottom enddo do m=1,CS%ntr - k=CS%oil_source_k(m) + k = CS%oil_source_k(m) if (k>0) then - k=min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom + k = min(k,k_max) ! Only insert k or first layer with interface 10 m above bottom CS%tr(i,j,k,m) = CS%tr(i,j,k,m) + CS%oil_source_rate*dt / & (vol_scale * (h_new(i,j,k)+GV%H_subroundoff) * G%areaT(i,j) ) elseif (k<0) then - h_total=GV%H_subroundoff + h_total = GV%H_subroundoff do k=1, nz h_total = h_total + h_new(i,j,k) enddo From 76f0668146d5f709f093774033927f68bf7514f3 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 20 Jan 2024 06:06:38 -0500 Subject: [PATCH 522/629] (*)Avoid using RHO_0 in non-Boussinesq averaging Use GV%H_to_MKS instead of GV%H_to_m when undoing the dimensional rescaling of thicknesses when taking weighted averages in horizontally_average_diag_field, global_layer_mean and global_volume_mean. In Boussinesq mode, these are identical, but in non-Boussinesq mode using GV%H_to_m introduced a multiplication and then division by the Boussinesq reference density, whereas GV%H_to_MKS avoids this by rescaling to a volume or mass-based coordinate depending on the mode. Several comments were also updated to reflect these conditional changes in the units of some internal variables. All expressions are mathematically equivalent, and this does not impact any solutions, but there can be changes in the last bits in some non-Boussinesq averaged diagnostics. --- src/diagnostics/MOM_spatial_means.F90 | 20 +++++++++++--------- src/framework/MOM_diag_remap.F90 | 17 ++++++++++++----- 2 files changed, 23 insertions(+), 14 deletions(-) diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index ab1210c0f5..60ad8dfba5 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -211,11 +211,13 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) ! Local variables ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums - real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: tmpForSumming ! An unscaled cell integral [a m3] - real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: weight ! The volume of each cell, used as a weight [m3] + real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: tmpForSumming ! An unscaled cell integral [a m3] or [a kg] + real, dimension(G%isc:G%iec,G%jsc:G%jec,SZK_(GV)) :: weight ! The volume or mass of each cell, depending on + ! whether the model is Boussinesq, used as a weight [m3] or [kg] type(EFP_type), dimension(2*SZK_(GV)) :: laysums - real, dimension(SZK_(GV)) :: global_temp_scalar ! The global integral of the tracer in each layer [a m3] - real, dimension(SZK_(GV)) :: global_weight_scalar ! The global integral of the volume of each layer [m3] + real, dimension(SZK_(GV)) :: global_temp_scalar ! The global integral of the tracer in each layer [a m3] or [a kg] + real, dimension(SZK_(GV)) :: global_weight_scalar ! The global integral of the volume or mass of each + ! layer [m3] or [kg] real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] integer :: i, j, k, is, ie, js, je, nz @@ -226,7 +228,7 @@ function global_layer_mean(var, h, G, GV, scale, tmp_scale) tmpForSumming(:,:,:) = 0. ; weight(:,:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight(i,j,k) = (GV%H_to_m * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) + weight(i,j,k) = (GV%H_to_MKS * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j,k) = scalefac * var(i,j,k) * weight(i,j,k) enddo ; enddo ; enddo @@ -262,9 +264,9 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] real :: scalefac ! A scaling factor for the variable [a A-1 ~> 1] - real :: weight_here ! The volume of a grid cell [m3] - real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The volume integral of the variable in a column [a m3] - real, dimension(SZI_(G),SZJ_(G)) :: sum_weight ! The volume of each column of water [m3] + real :: weight_here ! The volume or mass of a grid cell [m3] or [kg] + real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! The volume integral of the variable in a column [a m3] or [a kg] + real, dimension(SZI_(G),SZJ_(G)) :: sum_weight ! The volume or mass of each column of water [m3] or [kg] integer :: i, j, k, is, ie, js, je, nz is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -273,7 +275,7 @@ function global_volume_mean(var, h, G, GV, scale, tmp_scale) tmpForSumming(:,:) = 0. ; sum_weight(:,:) = 0. do k=1,nz ; do j=js,je ; do i=is,ie - weight_here = (GV%H_to_m * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) + weight_here = (GV%H_to_MKS * h(i,j,k)) * (G%US%L_to_m**2*G%areaT(i,j) * G%mask2dT(i,j)) tmpForSumming(i,j) = tmpForSumming(i,j) + scalefac * var(i,j,k) * weight_here sum_weight(i,j) = sum_weight(i,j) + weight_here enddo ; enddo ; enddo diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index ff0eda6325..a2ecc197bc 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -658,8 +658,15 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field [nondim] ! Local variables - real, dimension(G%isc:G%iec, G%jsc:G%jec, size(field,3)) :: volume, stuff - real, dimension(size(field, 3)) :: vol_sum, stuff_sum ! nz+1 is needed for interface averages + real :: volume(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area [m2], volume [m3] or mass [kg] of each cell. + real :: stuff(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area, volume or mass-weighted integral of the + ! field being averaged in each cell, in [m2 A], [m3 A] or [kg A], + ! depending on the weighting for the averages and whether the + ! model makes the Boussinesq approximation. + real, dimension(size(field, 3)) :: vol_sum ! The global sum of the areas [m2], volumes [m3] or mass [kg] + ! in the cells that used in the weighted averages. + real, dimension(size(field, 3)) :: stuff_sum ! The global sum of the weighted field in all cells, in + ! [A m2], [A m3] or [A kg] type(EFP_type), dimension(2*size(field,3)) :: sums_EFP ! Sums of volume or stuff by layer real :: height ! An average thickness attributed to an velocity point [H ~> m or kg m-2] integer :: i, j, k, nz @@ -688,7 +695,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i I1 = i - G%isdB + 1 height = 0.5 * (h(i,j,k) + h(i+1,j,k)) volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) & - * (GV%H_to_m * height) * G%mask2dCu(I,j) + * (GV%H_to_MKS * height) * G%mask2dCu(I,j) stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) enddo ; enddo endif @@ -717,7 +724,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i J1 = J - G%jsdB + 1 height = 0.5 * (h(i,j,k) + h(i,j+1,k)) volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) & - * (GV%H_to_m * height) * G%mask2dCv(i,J) + * (GV%H_to_MKS * height) * G%mask2dCv(i,J) stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) enddo ; enddo endif @@ -748,7 +755,7 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i else ! Intensive do j=G%jsc, G%jec ; do i=G%isc, G%iec volume(i,j,k) = (G%US%L_to_m**2 * G%areaT(i,j)) & - * (GV%H_to_m * h(i,j,k)) * G%mask2dT(i,j) + * (GV%H_to_MKS * h(i,j,k)) * G%mask2dT(i,j) stuff(i,j,k) = volume(i,j,k) * field(i,j,k) enddo ; enddo endif From 60cb551a3a6c04ba33e5d5f3ce7e4d25d3f7be53 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sun, 28 Jan 2024 13:53:55 -0500 Subject: [PATCH 523/629] Intrinsics: Faster cuberoot scaling functions This patch replaces the intrinsic-based exponent rescaling with explicit bit manipulation of the floating point number. This appears to produce a ~2.5x speedup of the solver, reducing its time from embarassingly slow to disappointingly slow. It is slightly faster than the GNU cbrt function, but still about 3x slower than the Intel SVML cbrt function. Timings (s) (16M array, -O3 -mavx -mfma) | Solver | -O2 | -O3 | |---------------------|-------|-------| | GNU x**1/3 | 0.225 | 0.198 | | GNU cuberoot before | 0.418 | 0.412 | | GNU cuberoot after | 0.208 | 0.187 | | Intel x**1/3 | 0.068 | 0.067 | | Intel before | 0.514 | 0.507 | | Intel after | 0.213 | 0.189 | At least one issue here is that Intel SVML is using fast vectorized logic operators whereas the Fortran intrinsics are replaced with slower legacy scalar versions. Not sure there is much we could even do about that without complaining to vendors. Also, I'm sure there's magic in their solvers which we are not capturing. Regardless, I think this is a major improvement. I do not believe it will change answers, but probably a good idea to verify this and get it in before committing any solutions using cuberoot(). --- src/framework/MOM_intrinsic_functions.F90 | 104 ++++++++++++++++++++-- 1 file changed, 98 insertions(+), 6 deletions(-) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 4327cfa5a6..5d420057d4 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -5,6 +5,7 @@ module MOM_intrinsic_functions ! This file is part of MOM6. See LICENSE.md for the license. use iso_fortran_env, only : stdout => output_unit, stderr => error_unit +use iso_fortran_env, only : int64, real64 implicit none ; private @@ -28,6 +29,7 @@ function invcosh(x) end function invcosh + !> Returns the cube root of a real argument at roundoff accuracy, in a form that works properly with !! rescaling of the argument by integer powers of 8. If the argument is a NaN, a NaN is returned. elemental function cuberoot(x) result(root) @@ -45,16 +47,15 @@ elemental function cuberoot(x) result(root) ! of the cube root of asx in arbitrary units that can grow or shrink with each iteration [B D] real :: den_prev ! The denominator of an expression for the previous iteration of the evolving estimate of ! the cube root of asx in arbitrary units that can grow or shrink with each iteration [D] - integer :: ex_3 ! One third of the exponent part of x, used to rescale x to get a. integer :: itt + integer(kind=int64) :: e_x, s_x + if ((x >= 0.0) .eqv. (x <= 0.0)) then ! Return 0 for an input of 0, or NaN for a NaN input. root = x else - ex_3 = ceiling(exponent(x) / 3.) - ! Here asx is in the range of 0.125 <= asx < 1.0 - asx = scale(abs(x), -3*ex_3) + call rescale_exp(x, asx, e_x, s_x) ! Iteratively determine root_asx = asx**1/3 using Halley's method and then Newton's method, ! noting that Halley's method onverges monotonically and needs no bounding. Halley's method is @@ -82,11 +83,102 @@ elemental function cuberoot(x) result(root) ! that is within the last bit of the true solution. root_asx = root_asx - (root_asx**3 - asx) / (3.0 * (root_asx**2)) - root = sign(scale(root_asx, ex_3), x) + root = descale_cbrt(root_asx, e_x, s_x) endif - end function cuberoot + +!> Rescale `a` to the range [0.125, 1) while preserving its fractional term. +pure subroutine rescale_exp(a, x, e_a, s_a) + real, intent(in) :: a + !< The value to be rescaled + real, intent(out) :: x + !< The rescaled value of `a` + integer(kind=int64), intent(out) :: e_a + !< The biased exponent of `a` + integer(kind=int64), intent(out) :: s_a + !< The sign bit of `a` + + ! Floating point model, if format is (sign, exp, frac) + integer, parameter :: bias = maxexponent(1.) - 1 + !< The double precision exponent offset (assuming a balanced range) + integer, parameter :: signbit = storage_size(1.) - 1 + !< Position of sign bit + integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) + !< Bit size of exponent + integer, parameter :: expbit = signbit - explen + !< Position of lowest exponent bit + integer, parameter :: fraclen = expbit + !< Length of fractional part + + integer(kind=int64) :: xb + !< A floating point number, bit-packed as an integer + integer(kind=int64) :: e_scaled + !< The new rescaled exponent of `a` (i.e. the exponent of `x`) + + ! Pack bits of `a` into `xb` and extract its exponent and sign + xb = transfer(a, 1_int64) + s_a = ibits(xb, signbit, 1) + e_a = ibits(xb, expbit, explen) + + ! Decompose the exponent as `e = modulo(e,3) + 3*(e/3)` and extract the + ! rescaled exponent, now in {-3,-2,-1} + e_scaled = modulo(e_a, 3) - 3 + bias + + ! Insert the new 11-bit exponent into `xb`, while also setting the sign bit + ! to zero, ensuring that `xb` is always positive. + call mvbits(e_scaled, 0, explen + 1, xb, fraclen) + + ! Transfer the final modified value to `x` + x = transfer(xb, 1.) +end subroutine rescale_exp + + +!> Descale a real number to its original base, and apply the cube root to the +!! remaining exponent. +pure function descale_cbrt(x, e_a, s_a) result(r) + real, intent(in) :: x + !< Cube root of the rescaled value, which was rescaled to [0.125, 1.0) + integer(kind=int64), intent(in) :: e_a + !< Exponent of the original value to be cube rooted + integer(kind=int64), intent(in) :: s_a + !< Sign bit of the original value to be cube rooted + real :: r + !< Restored value with the cube root applied to its exponent + + ! Floating point model, if format is (sign, exp, frac) + integer, parameter :: bias = maxexponent(1.) - 1 + !< The double precision exponent offset (assuming a balanced range) + integer, parameter :: signbit = storage_size(1.) - 1 + !< Position of sign bit + integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) + !< Bit size of exponent + integer, parameter :: expbit = signbit - explen + !< Position of lowest exponent bit + integer, parameter :: fraclen = expbit + !< Length of fractional part + + integer(kind=int64) :: xb + ! Bit-packed real number into integer form + integer(kind=int64) :: e_r + ! Exponent of the descaled value + + ! Extract the exponent of the rescaled value, in {-3, -2, -1} + xb = transfer(x, 1_8) + e_r = ibits(xb, expbit, explen) + + ! Apply the cube root to the old exponent (after removing its bias) and add + ! to the rescaled exponent. Correct the previous -3 with a +1. + e_r = e_r + (e_a/3 - bias/3 + 1) + + ! Apply the corrected exponent and sign and convert back to real + call mvbits(e_r, 0, explen, xb, expbit) + call mvbits(s_a, 0, 1, xb, signbit) + r = transfer(xb, 1.) +end function descale_cbrt + + + !> Returns true if any unit test of intrinsic_functions fails, or false if they all pass. logical function intrinsic_functions_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout From 5edba9b4d28892225423f872a9a83b1c22dda0a9 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 30 Jan 2024 15:28:29 -0500 Subject: [PATCH 524/629] Cuberoot: Refactor (re|de)scale functions Some modifications were made to the cuberoot rescale and descale functions: * The machine parameters were moved from function to module parameters. This could dangerously expose them to other functions, but it prevents multiple definitions of the same numbers. * The exponent is now cube-rooted in rescale rather than descale. * The exponent expressions are broken into more explicit steps, rather than combining multiple steps and assumptions into a single expression. * The bias is no longer assumed to be a multiple of three. This is true for double precision but not single precision. A new test of quasi-random number was also added to the cuberoot test suite. These numbers were able to detect the differences in GNU and Intel compiler output. A potential error in the return value of the test was also fixed. The volatile test of 1 - 0.5*ULP has been added. The cube root of this value rounds to 1, and needs to be handled carefully. The unit test function `cuberoot(v**3)` was reversed to `cuberoot(v)**`, to include testing of this value. (Cubing would wipe out the anomaly.) --- src/framework/MOM_intrinsic_functions.F90 | 148 +++++++++++----------- 1 file changed, 75 insertions(+), 73 deletions(-) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 5d420057d4..07c6abe3ad 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -12,6 +12,19 @@ module MOM_intrinsic_functions public :: invcosh, cuberoot public :: intrinsic_functions_unit_tests +! Floating point model, if bit layout from high to low is (sign, exp, frac) + +integer, parameter :: bias = maxexponent(1.) - 1 + !< The double precision exponent offset +integer, parameter :: signbit = storage_size(1.) - 1 + !< Position of sign bit +integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) + !< Bit size of exponent +integer, parameter :: expbit = signbit - explen + !< Position of lowest exponent bit +integer, parameter :: fraclen = expbit + !< Length of fractional part + contains !> Evaluate the inverse cosh, either using a math library or an @@ -55,7 +68,7 @@ elemental function cuberoot(x) result(root) ! Return 0 for an input of 0, or NaN for a NaN input. root = x else - call rescale_exp(x, asx, e_x, s_x) + call rescale_cbrt(x, asx, e_x, s_x) ! Iteratively determine root_asx = asx**1/3 using Halley's method and then Newton's method, ! noting that Halley's method onverges monotonically and needs no bounding. Halley's method is @@ -83,109 +96,90 @@ elemental function cuberoot(x) result(root) ! that is within the last bit of the true solution. root_asx = root_asx - (root_asx**3 - asx) / (3.0 * (root_asx**2)) - root = descale_cbrt(root_asx, e_x, s_x) + root = descale(root_asx, e_x, s_x) endif end function cuberoot -!> Rescale `a` to the range [0.125, 1) while preserving its fractional term. -pure subroutine rescale_exp(a, x, e_a, s_a) +!> Rescale `a` to the range [0.125, 1) and compute its cube-root exponent. +pure subroutine rescale_cbrt(a, x, e_r, s_a) real, intent(in) :: a - !< The value to be rescaled + !< The real parameter to be rescaled for cube root real, intent(out) :: x - !< The rescaled value of `a` - integer(kind=int64), intent(out) :: e_a - !< The biased exponent of `a` + !< The rescaled value of a + integer(kind=int64), intent(out) :: e_r + !< Cube root of the exponent of the rescaling of `a` integer(kind=int64), intent(out) :: s_a - !< The sign bit of `a` - - ! Floating point model, if format is (sign, exp, frac) - integer, parameter :: bias = maxexponent(1.) - 1 - !< The double precision exponent offset (assuming a balanced range) - integer, parameter :: signbit = storage_size(1.) - 1 - !< Position of sign bit - integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) - !< Bit size of exponent - integer, parameter :: expbit = signbit - explen - !< Position of lowest exponent bit - integer, parameter :: fraclen = expbit - !< Length of fractional part + !< The sign bit of a integer(kind=int64) :: xb - !< A floating point number, bit-packed as an integer - integer(kind=int64) :: e_scaled - !< The new rescaled exponent of `a` (i.e. the exponent of `x`) - - ! Pack bits of `a` into `xb` and extract its exponent and sign + ! Floating point value of a, bit-packed as an integer + integer(kind=int64) :: e_a + ! Unscaled exponent of a + integer(kind=int64) :: e_x + ! Exponent of x + integer(kind=int64) :: e_div, e_mod + ! Quotient and remainder of e in e = 3*(e/3) + modulo(e,3). + + ! Pack bits of a into xb and extract its exponent and sign. xb = transfer(a, 1_int64) s_a = ibits(xb, signbit, 1) - e_a = ibits(xb, expbit, explen) + e_a = ibits(xb, expbit, explen) - bias + + ! Compute terms of exponent decomposition e = 3*(e/3) + modulo(e,3). + ! (Fortran division is round-to-zero, so we must emulate floor division.) + e_mod = modulo(e_a, 3_int64) + e_div = (e_a - e_mod)/3 + + ! Our scaling decomposes e_a into e = {3*(e/3) + 3} + {modulo(e,3) - 3}. - ! Decompose the exponent as `e = modulo(e,3) + 3*(e/3)` and extract the - ! rescaled exponent, now in {-3,-2,-1} - e_scaled = modulo(e_a, 3) - 3 + bias + ! The first term is a perfect cube, whose cube root is computed below. + e_r = e_div + 1 - ! Insert the new 11-bit exponent into `xb`, while also setting the sign bit - ! to zero, ensuring that `xb` is always positive. - call mvbits(e_scaled, 0, explen + 1, xb, fraclen) + ! The second term ensures that x is shifted to [0.125, 1). + e_x = e_mod - 3 - ! Transfer the final modified value to `x` + ! Insert the new 11-bit exponent into xb and write to x and extend the + ! bitcount to 12, so that the sign bit is zero and x is always positive. + call mvbits(e_x + bias, 0, explen + 1, xb, fraclen) x = transfer(xb, 1.) -end subroutine rescale_exp +end subroutine rescale_cbrt -!> Descale a real number to its original base, and apply the cube root to the -!! remaining exponent. -pure function descale_cbrt(x, e_a, s_a) result(r) +!> Undo the rescaling of a real number back to its original base. +pure function descale(x, e_a, s_a) result(a) real, intent(in) :: x - !< Cube root of the rescaled value, which was rescaled to [0.125, 1.0) + !< The rescaled value which is to be restored. integer(kind=int64), intent(in) :: e_a - !< Exponent of the original value to be cube rooted + !< Exponent of the unscaled value integer(kind=int64), intent(in) :: s_a - !< Sign bit of the original value to be cube rooted - real :: r - !< Restored value with the cube root applied to its exponent - - ! Floating point model, if format is (sign, exp, frac) - integer, parameter :: bias = maxexponent(1.) - 1 - !< The double precision exponent offset (assuming a balanced range) - integer, parameter :: signbit = storage_size(1.) - 1 - !< Position of sign bit - integer, parameter :: explen = 1 + ceiling(log(real(bias))/log(2.)) - !< Bit size of exponent - integer, parameter :: expbit = signbit - explen - !< Position of lowest exponent bit - integer, parameter :: fraclen = expbit - !< Length of fractional part + !< Sign bit of the unscaled value + real :: a + !< Restored value with the corrected exponent and sign integer(kind=int64) :: xb ! Bit-packed real number into integer form - integer(kind=int64) :: e_r - ! Exponent of the descaled value + integer(kind=int64) :: e_x + ! Biased exponent of x - ! Extract the exponent of the rescaled value, in {-3, -2, -1} + ! Apply the corrected exponent and sign to x. xb = transfer(x, 1_8) - e_r = ibits(xb, expbit, explen) - - ! Apply the cube root to the old exponent (after removing its bias) and add - ! to the rescaled exponent. Correct the previous -3 with a +1. - e_r = e_r + (e_a/3 - bias/3 + 1) - - ! Apply the corrected exponent and sign and convert back to real - call mvbits(e_r, 0, explen, xb, expbit) + e_x = ibits(xb, expbit, explen) + call mvbits(e_a + e_x, 0, explen, xb, expbit) call mvbits(s_a, 0, 1, xb, signbit) - r = transfer(xb, 1.) -end function descale_cbrt - + a = transfer(xb, 1.) +end function descale !> Returns true if any unit test of intrinsic_functions fails, or false if they all pass. -logical function intrinsic_functions_unit_tests(verbose) +function intrinsic_functions_unit_tests(verbose) result(fail) logical, intent(in) :: verbose !< If true, write results to stdout + logical :: fail !< True if any of the unit tests fail ! Local variables real :: testval ! A test value for self-consistency testing [nondim] - logical :: fail, v + logical :: v + integer :: n fail = .false. v = verbose @@ -199,7 +193,15 @@ logical function intrinsic_functions_unit_tests(verbose) fail = fail .or. Test_cuberoot(v, 1.0) fail = fail .or. Test_cuberoot(v, 0.125) fail = fail .or. Test_cuberoot(v, 0.965) - + fail = fail .or. Test_cuberoot(v, 1.0 - epsilon(1.0)) + fail = fail .or. Test_cuberoot(v, 1.0 - 0.5*epsilon(1.0)) + + testval = 1.0e-99 + v = .false. + do n=-160,160 + fail = fail .or. Test_cuberoot(v, testval) + testval = (-2.908 * (1.414213562373 + 1.2345678901234e-5*n)) * testval + enddo end function intrinsic_functions_unit_tests !> True if the cube of cuberoot(val) does not closely match val. False otherwise. @@ -209,7 +211,7 @@ logical function Test_cuberoot(verbose, val) ! Local variables real :: diff ! The difference between val and the cube root of its cube. - diff = val - cuberoot(val**3) + diff = val - cuberoot(val)**3 Test_cuberoot = (abs(diff) > 2.0e-15*abs(val)) if (Test_cuberoot) then From 736ef16a4016b538f946df4be9f30cdc532d03e4 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 30 Jan 2024 15:56:41 -0500 Subject: [PATCH 525/629] Cuberoot: Break **3 into explicit integer cubes In separate testing, we observed that Intel would use the `pow()` function to evaluate the cubes of some numbers, causing different answers with GNU. In this patch, I replace the cubic x**3 operations with explicit x*x*x multiplication, which appears to avoid this substitution. Well, for the moment, at least. --- src/framework/MOM_intrinsic_functions.F90 | 23 ++++++++++++++++++----- 1 file changed, 18 insertions(+), 5 deletions(-) diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index 07c6abe3ad..fbb1c28096 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -52,14 +52,19 @@ elemental function cuberoot(x) result(root) real :: asx ! The absolute value of x rescaled by an integer power of 8 to put it into ! the range from 0.125 < asx <= 1.0, in ambiguous units cubed [B3] real :: root_asx ! The cube root of asx [B] + real :: ra_3 ! root_asx cubed [B3] real :: num ! The numerator of an expression for the evolving estimate of the cube root of asx ! in arbitrary units that can grow or shrink with each iteration [B C] real :: den ! The denominator of an expression for the evolving estimate of the cube root of asx ! in arbitrary units that can grow or shrink with each iteration [C] real :: num_prev ! The numerator of an expression for the previous iteration of the evolving estimate ! of the cube root of asx in arbitrary units that can grow or shrink with each iteration [B D] + real :: np_3 ! num_prev cubed [B3 D3] real :: den_prev ! The denominator of an expression for the previous iteration of the evolving estimate of ! the cube root of asx in arbitrary units that can grow or shrink with each iteration [D] + real :: dp_3 ! den_prev cubed [C3] + real :: r0 ! Initial value of the iterative solver. [B C] + real :: r0_3 ! r0 cubed [B3 C3] integer :: itt integer(kind=int64) :: e_x, s_x @@ -79,14 +84,21 @@ elemental function cuberoot(x) result(root) ! This first estimate gives the same magnitude of errors for 0.125 and 1.0 after two iterations. ! The first iteration is applied explicitly. - num = 0.707106 * (0.707106**3 + 2.0 * asx) - den = 2.0 * (0.707106**3) + asx + r0 = 0.707106 + r0_3 = r0 * r0 * r0 + num = r0 * (r0_3 + 2.0 * asx) + den = 2.0 * r0_3 + asx do itt=1,2 ! Halley's method iterates estimates as Root = Root * (Root**3 + 2.*asx) / (2.*Root**3 + asx). num_prev = num ; den_prev = den - num = num_prev * (num_prev**3 + 2.0 * asx * (den_prev**3)) - den = den_prev * (2.0 * num_prev**3 + asx * (den_prev**3)) + + ! Pre-compute these as integer powers, to avoid `pow()`-like intrinsics. + np_3 = num_prev * num_prev * num_prev + dp_3 = den_prev * den_prev * den_prev + + num = num_prev * (np_3 + 2.0 * asx * dp_3) + den = den_prev * (2.0 * np_3 + asx * dp_3) ! Equivalent to: root_asx = root_asx * (root_asx**3 + 2.*asx) / (2.*root_asx**3 + asx) enddo ! At this point the error in root_asx is better than 1 part in 3e14. @@ -94,7 +106,8 @@ elemental function cuberoot(x) result(root) ! One final iteration with Newton's method polishes up the root and gives a solution ! that is within the last bit of the true solution. - root_asx = root_asx - (root_asx**3 - asx) / (3.0 * (root_asx**2)) + ra_3 = root_asx * root_asx * root_asx + root_asx = root_asx - (ra_3 - asx) / (3.0 * (root_asx * root_asx)) root = descale(root_asx, e_x, s_x) endif From 671c85d32864d89bce6cfe270a2c556c54b03ba4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 10 Jan 2024 13:14:10 -0500 Subject: [PATCH 526/629] (*)Use cuberoot in ePBL_column Use the new cuberoot() function in place of **(1./3.) to calculate the turbulent velocity vstar in ePBL_column when EPBL_ANSWER_DATE is 20240101 or higher. This is mathematically equivalent to the previous version, but it does change and answers at roundoff and it allows several dimensional scaling factors that had previously been required to be eliminated. All answers are mathematically equivalant, but answers do change if EPBL_ANSWER_DATE is 20240101 or higher and the description of EPBL_ANSWER_DATE changes in some MOM_parameter_doc files. --- .../vertical/MOM_energetic_PBL.F90 | 105 +++++++++++++----- 1 file changed, 77 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/vertical/MOM_energetic_PBL.F90 b/src/parameterizations/vertical/MOM_energetic_PBL.F90 index 1a59b177bd..10907c04ed 100644 --- a/src/parameterizations/vertical/MOM_energetic_PBL.F90 +++ b/src/parameterizations/vertical/MOM_energetic_PBL.F90 @@ -13,6 +13,7 @@ module MOM_energetic_PBL use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type use MOM_interface_heights, only : thickness_to_dz +use MOM_intrinsic_functions, only : cuberoot use MOM_string_functions, only : uppercase use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs @@ -161,7 +162,10 @@ module MOM_energetic_PBL integer :: answer_date !< The vintage of the order of arithmetic and expressions in the ePBL !! calculations. Values below 20190101 recover the answers from the !! end of 2018, while higher values use updated and more robust forms - !! of the same expressions. + !! of the same expressions. Values below 20240101 use A**(1./3.) to + !! estimate the cube root of A in several expressions, while higher + !! values use the integer root function cuberoot(A) and therefore + !! can work with scaled variables. logical :: orig_PE_calc !< If true, the ePBL code uses the original form of the !! potential energy change code. Otherwise, it uses a newer version !! that can work with successive increments to the diffusivity in @@ -335,8 +339,10 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS mixvel, & ! A turbulent mixing velocity [Z T-1 ~> m s-1]. mixlen, & ! A turbulent mixing length [Z ~> m]. SpV_dt ! Specific volume interpolated to interfaces divided by dt or 1.0 / (dt * Rho0) - ! times conversion factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1], - ! used to convert local TKE into a turbulence velocity cubed. + ! times conversion factors for answer dates before 20240101 in + ! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without the convsersion factors for + ! answer dates of 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], used to + ! convert local TKE into a turbulence velocity cubed. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. @@ -348,6 +354,8 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS real :: I_rho ! The inverse of the Boussinesq reference density times a ratio of scaling ! factors [Z L-1 R-1 ~> m3 kg-1] real :: I_dt ! The Adcroft reciprocal of the timestep [T-1 ~> s-1] + real :: I_rho0dt ! The inverse of the Boussinesq reference density times the time + ! step [R-1 T-1 ~> m3 kg-1 s-1] real :: B_Flux ! The surface buoyancy flux [Z2 T-3 ~> m2 s-3] real :: MLD_io ! The mixed layer depth found by ePBL_column [Z ~> m] @@ -374,6 +382,7 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS h_neglect = GV%H_subroundoff I_rho = US%L_to_Z * GV%H_to_Z * GV%RZ_to_H ! == US%L_to_Z / GV%Rho0 ! This is not used when fully non-Boussinesq. I_dt = 0.0 ; if (dt > 0.0) I_dt = 1.0 / dt + I_rho0dt = 1.0 / (GV%Rho0 * dt) ! This is not used when fully non-Boussinesq. ! Zero out diagnostics before accumulation. if (CS%TKE_diagnostics) then @@ -403,9 +412,15 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS ! Set the inverse density used to translating local TKE into a turbulence velocity SpV_dt(:) = 0.0 if ((dt > 0.0) .and. GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then - do K=1,nz+1 - SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) - enddo + if (CS%answer_date < 20240101) then + do K=1,nz+1 + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) / (dt*GV%Rho0) + enddo + else + do K=1,nz+1 + SpV_dt(K) = I_rho0dt + enddo + endif endif ! Determine the initial mech_TKE and conv_PErel, including the energy required @@ -442,11 +457,19 @@ subroutine energetic_PBL(h_3d, u_3d, v_3d, tv, fluxes, dt, Kd_int, G, GV, US, CS endif if (allocated(tv%SpV_avg) .and. .not.GV%Boussinesq) then - SpV_dt(1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,1) * I_dt - do K=2,nz - SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) * 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt - enddo - SpV_dt(nz+1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,nz) * I_dt + if (CS%answer_date < 20240101) then + SpV_dt(1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = (US%Z_to_m**3*US%s_to_T**3) * 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = (US%Z_to_m**3*US%s_to_T**3) * tv%SpV_avg(i,j,nz) * I_dt + else + SpV_dt(1) = tv%SpV_avg(i,j,1) * I_dt + do K=2,nz + SpV_dt(K) = 0.5*(tv%SpV_avg(i,j,k-1) + tv%SpV_avg(i,j,k)) * I_dt + enddo + SpV_dt(nz+1) = tv%SpV_avg(i,j,nz) * I_dt + endif endif B_flux = buoy_flux(i,j) @@ -565,9 +588,13 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, real, dimension(SZK_(GV)), intent(in) :: dSV_dS !< The partial derivative of in-situ specific !! volume with salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZK_(GV)+1), intent(in) :: SpV_dt !< Specific volume interpolated to interfaces - !! divided by dt or 1.0 / (dt * Rho0) times conversion - !! factors in [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1], - !! used to convert local TKE into a turbulence velocity. + !! divided by dt or 1.0 / (dt * Rho0), times conversion + !! factors for answer dates before 20240101 in + !! [m3 Z-3 R-1 T2 s-3 ~> m3 kg-1 s-1] or without + !! the convsersion factors for answer dates of + !! 20240101 and later in [R-1 T-1 ~> m3 kg-1 s-1], + !! used to convert local TKE into a turbulence + !! velocity cubed. real, dimension(SZK_(GV)), intent(in) :: TKE_forcing !< The forcing requirements to homogenize the !! forcing that has been applied to each layer !! [R Z3 T-2 ~> J m-2]. @@ -819,7 +846,7 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, max_itt = 20 dz_tt_min = 0.0 - vstar_unit_scale = US%m_to_Z * US%T_to_s + if (CS%answer_date < 20240101) vstar_unit_scale = US%m_to_Z * US%T_to_s MLD_guess = MLD_io @@ -1160,12 +1187,22 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, dz_tt = dztot + dz_tt_min TKE_here = mech_TKE + CS%wstar_ustar_coef*conv_PErel if (TKE_here > 0.0) then - if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 - elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) - vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + if (CS%answer_date < 20240101) then + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) + vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + endif + else + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * cuberoot(SpV_dt(K)*TKE_here) + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1.0 - dztot / MLD_guess) + vstar = (CS%vstar_scale_fac * Surface_Scale) * ( CS%vstar_surf_fac*u_star + & + cuberoot((CS%wstar_ustar_coef*conv_PErel) * SpV_dt(K)) ) + endif endif hbs_here = min(hb_hs(K), MixLen_shape(K)) mixlen(K) = MAX(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & @@ -1209,12 +1246,22 @@ subroutine ePBL_column(h, dz, u, v, T0, S0, dSV_dT, dSV_dS, SpV_dt, TKE_forcing, ! Does MKE_src need to be included in the calculation of vstar here? TKE_here = mech_TKE + CS%wstar_ustar_coef*(conv_PErel-PE_chg_max) if (TKE_here > 0.0) then - if (CS%wT_scheme==wT_from_cRoot_TKE) then - vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 - elseif (CS%wT_scheme==wT_from_RH18) then - Surface_Scale = max(0.05, 1. - dztot / MLD_guess) - vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & - vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + if (CS%answer_date < 20240101) then + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * vstar_unit_scale * (SpV_dt(K)*TKE_here)**C1_3 + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) + vstar = CS%vstar_scale_fac * Surface_Scale * (CS%vstar_surf_fac*u_star + & + vstar_unit_scale * (CS%wstar_ustar_coef*conv_PErel*SpV_dt(K))**C1_3) + endif + else + if (CS%wT_scheme==wT_from_cRoot_TKE) then + vstar = CS%vstar_scale_fac * cuberoot(SpV_dt(K)*TKE_here) + elseif (CS%wT_scheme==wT_from_RH18) then + Surface_Scale = max(0.05, 1. - dztot / MLD_guess) + vstar = (CS%vstar_scale_fac * Surface_Scale) * ( CS%vstar_surf_fac*u_star + & + cuberoot((CS%wstar_ustar_coef*conv_PErel) * SpV_dt(K)) ) + endif endif hbs_here = min(hb_hs(K), MixLen_shape(K)) mixlen(K) = max(CS%min_mix_len, ((dz_tt*hbs_here)*vstar) / & @@ -2076,7 +2123,9 @@ subroutine energetic_PBL_init(Time, G, GV, US, param_file, diag, CS) "The vintage of the order of arithmetic and expressions in the energetic "//& "PBL calculations. Values below 20190101 recover the answers from the "//& "end of 2018, while higher values use updated and more robust forms of the "//& - "same expressions.", & + "same expressions. Values below 20240101 use A**(1./3.) to estimate the cube "//& + "root of A in several expressions, while higher values use the integer root "//& + "function cuberoot(A) and therefore can work with scaled variables.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) From 07bace68cfc6e498f39c5731b563601d6afec389 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 30 Jan 2024 17:59:28 -0500 Subject: [PATCH 527/629] *Fix two bugs in convert_temp_salt_for_TEOS10 Fixed two bugs on a single line of convert_temp_salt_for_TEOS10. The first bug was a reversal in the order of the temperature and salinity arguments to poTemp_to_consTemp, resulting in temperatures that closely approximate the salinities. The second bug that was fixed on this line was temperatures being rescaled with a factor that is appropriate for salinities. This bug-fix will change answers dramatically for any cases that use the ROQUET_RHO, ROQUET_SPV and TEOS10 equations of state and initialize the model with INIT_LAYERS_FROM_Z_FILE = True. --- src/equation_of_state/MOM_EOS.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index d5c7abc977..7a9de49573 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1703,7 +1703,7 @@ subroutine convert_temp_salt_for_TEOS10(T, S, HI, kd, mask_z, EOS) 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)) + T(i,j,k) = EOS%degC_to_C*poTemp_to_consTemp(EOS%C_to_degC*T(i,j,k), EOS%S_to_ppt*S(i,j,k)) endif enddo ; enddo ; enddo end subroutine convert_temp_salt_for_TEOS10 From 915cfe225e5e3c42103f20501c60e6aa90cd613c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 26 Jan 2024 18:10:41 -0500 Subject: [PATCH 528/629] +ALE_remap_scalar with arbitrary thickness units This commit add the new optional arguments h_neglect and h_neglect_edge to ALE_remap_scalar to allow for the thicknesses used in this routine to be provided in any self-consistent units, including [Z ~> m], instead of just [H ~> m or kg m-2]. To help make use of this new capability, this commit also adds the new functions set_h_neglect and set_dz_neglect to the MOM_regridding module. build_grid_rho and build_grid_HyCOM1 have been refactored to use set_h_neglect in place of the corresponding duplicated code blocks. This commit also adds the new optional argument h_in_Z_units to MOM_initialize_tracer_from_Z, which in turn uses this new capability for ALE_remap_scalar to use vertical layer extents (in Z units) rather than thicknesses (in H units). Although there are new optional arguments to public interfaces, they are not yet being exercised with this commit so no answers are changed. Moreover, even if they were being exercised, all Boussinesq solutions would give identical answers. --- src/ALE/MOM_ALE.F90 | 36 +++++++---- src/ALE/MOM_regridding.F90 | 60 ++++++++++++++----- .../MOM_tracer_initialization_from_Z.F90 | 56 +++++++++++------ 3 files changed, 108 insertions(+), 44 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 77ee1192a2..543d77a0f3 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -1260,16 +1260,17 @@ end subroutine mask_near_bottom_vel !! h_dst must be dimensioned as a model array with GV%ke layers while h_src can !! have an arbitrary number of layers specified by nk_src. subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_cells, old_remap, & - answers_2018, answer_date ) + answers_2018, answer_date, h_neglect, h_neglect_edge) type(remapping_CS), intent(in) :: CS !< Remapping control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure integer, intent(in) :: nk_src !< Number of levels on source grid real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: h_src !< Level thickness of source grid - !! [H ~> m or kg m-2] + !! [H ~> m or kg m-2] or other units + !! if H_neglect is provided real, dimension(SZI_(G),SZJ_(G),nk_src), intent(in) :: s_src !< Scalar on source grid, in arbitrary units [A] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid - !! [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(in) :: h_dst !< Level thickness of destination grid in the + !! same units as h_src, often [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)),intent(inout) :: s_dst !< Scalar on destination grid, in the same !! arbitrary units as s_src [A] logical, optional, intent(in) :: all_cells !< If false, only reconstruct for @@ -1283,10 +1284,16 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c !! use more robust forms of the same expressions. integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use !! for remapping + real, optional, intent(in) :: h_neglect !< A negligibly small thickness used in + !! remapping cell reconstructions, in the same + !! units as h_src, often [H ~> m or kg m-2] + real, optional, intent(in) :: h_neglect_edge !< A negligibly small thickness used in + !! remapping edge value calculations, in the same + !! units as h_src, often [H ~> m or kg m-2] ! Local variables integer :: i, j, k, n_points real :: dx(GV%ke+1) ! Change in interface position [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] + real :: h_neg, h_neg_edge ! Tiny thicknesses used in remapping [H ~> m or kg m-2] logical :: ignore_vanished_layers, use_remapping_core_w, use_2018_remap ignore_vanished_layers = .false. @@ -1297,12 +1304,17 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c use_2018_remap = .true. ; if (present(answers_2018)) use_2018_remap = answers_2018 if (present(answer_date)) use_2018_remap = (answer_date < 20190101) - if (.not.use_2018_remap) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + if (present(h_neglect)) then + h_neg = h_neglect + h_neg_edge = h_neg ; if (present(h_neglect_edge)) h_neg_edge = h_neglect_edge else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + if (.not.use_2018_remap) then + h_neg = GV%H_subroundoff ; h_neg_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neg = GV%m_to_H*1.0e-30 ; h_neg_edge = GV%m_to_H*1.0e-10 + else + h_neg = GV%kg_m2_to_H*1.0e-30 ; h_neg_edge = GV%kg_m2_to_H*1.0e-10 + endif endif !$OMP parallel do default(shared) firstprivate(n_points,dx) @@ -1318,10 +1330,10 @@ subroutine ALE_remap_scalar(CS, G, GV, nk_src, h_src, s_src, h_dst, s_dst, all_c if (use_remapping_core_w) then call dzFromH1H2( n_points, h_src(i,j,1:n_points), GV%ke, h_dst(i,j,:), dx ) call remapping_core_w(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & - GV%ke, dx, s_dst(i,j,:), h_neglect, h_neglect_edge) + GV%ke, dx, s_dst(i,j,:), h_neg, h_neg_edge) else call remapping_core_h(CS, n_points, h_src(i,j,1:n_points), s_src(i,j,1:n_points), & - GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neglect, h_neglect_edge) + GV%ke, h_dst(i,j,:), s_dst(i,j,:), h_neg, h_neg_edge) endif else s_dst(i,j,:) = 0. diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 8ef0679358..904164c8e7 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -144,6 +144,7 @@ module MOM_regridding public getCoordinateResolution, getCoordinateInterfaces public getCoordinateUnits, getCoordinateShortName, getStaticThickness public DEFAULT_COORDINATE_MODE +public set_h_neglect, set_dz_neglect public get_zlike_CS, get_sigma_CS, get_rho_CS !> Documentation for coordinate options @@ -1416,13 +1417,7 @@ subroutine build_rho_grid( G, GV, US, h, nom_depth_H, tv, dzInterface, remapCS, #endif logical :: ice_shelf - if (CS%remap_answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif + h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) nz = GV%ke ice_shelf = present(frac_shelf_h) @@ -1575,13 +1570,7 @@ subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, real :: z_top_col, totalThickness logical :: ice_shelf - if (CS%remap_answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 - else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 - endif + h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) if (.not.CS%target_density_set) call MOM_error(FATAL, "build_grid_HyCOM1 : "//& "Target densities must be set before build_grid_HyCOM1 is called.") @@ -2095,6 +2084,49 @@ subroutine write_regrid_file( CS, GV, filepath ) end subroutine write_regrid_file +!> Set appropriate values for the negligible thicknesses used for remapping based on an answer date. +function set_h_neglect(GV, remap_answer_date, h_neglect_edge) result(h_neglect) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + integer, intent(in) :: remap_answer_date !< The vintage of the expressions to use + !! for remapping. Values below 20190101 recover the + !! remapping answers from 2018. Higher values use more + !! robust forms of the same remapping algorithms. + real, intent(out) :: h_neglect_edge !< A negligibly small thickness used in + !! remapping edge value calculations [H ~> m or kg m-2] + real :: h_neglect !< A negligibly small thickness used in + !! remapping cell reconstructions [H ~> m or kg m-2] + + if (remap_answer_date >= 20190101) then + h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + elseif (GV%Boussinesq) then + h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + else + h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + endif +end function set_h_neglect + +!> Set appropriate values for the negligible vertical layer extents used for remapping based on an answer date. +function set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) result(dz_neglect) + type(verticalGrid_type), intent(in) :: GV !< Ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: remap_answer_date !< The vintage of the expressions to use + !! for remapping. Values below 20190101 recover the + !! remapping answers from 2018. Higher values use more + !! robust forms of the same remapping algorithms. + real, intent(out) :: dz_neglect_edge !< A negligibly small vertical layer extent + !! used in remapping edge value calculations [Z ~> m] + real :: dz_neglect !< A negligibly small vertical layer extent + !! used in remapping cell reconstructions [Z ~> m] + + if (remap_answer_date >= 20190101) then + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff + elseif (GV%Boussinesq) then + dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 + else + dz_neglect = GV%kg_m2_to_H * (GV%H_to_m*US%m_to_Z) * 1.0e-30 + dz_neglect_edge = GV%kg_m2_to_H * (GV%H_to_m*US%m_to_Z) * 1.0e-10 + endif +end function set_dz_neglect !------------------------------------------------------------------------------ !> Query the fixed resolution data diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 808430df2c..5a172b5d97 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -3,20 +3,21 @@ module MOM_tracer_initialization_from_Z ! This file is part of MOM6. See LICENSE.md for the license. -use MOM_debugging, only : hchksum -use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end -use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP -use MOM_domains, only : pass_var +use MOM_debugging, only : hchksum +use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end +use MOM_cpu_clock, only : CLOCK_ROUTINE, CLOCK_LOOP +use MOM_domains, only : pass_var use MOM_error_handler, only : MOM_mesg, MOM_error, FATAL, WARNING use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint -use MOM_file_parser, only : get_param, param_file_type, log_version -use MOM_grid, only : ocean_grid_type +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 -use MOM_ALE, only : ALE_remap_scalar +use MOM_regridding, only : set_dz_neglect +use MOM_remapping, only : remapping_CS, initialize_remapping +use MOM_unit_scaling, only : unit_scale_type +use MOM_verticalGrid, only : verticalGrid_type +use MOM_ALE, only : ALE_remap_scalar implicit none ; private @@ -36,12 +37,13 @@ module MOM_tracer_initialization_from_Z !> Initializes a tracer from a z-space data file, including any lateral regridding that is needed. subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_nam, & src_var_unit_conversion, src_var_record, homogenize, & - useALEremapping, remappingScheme, src_var_gridspec ) + useALEremapping, remappingScheme, src_var_gridspec, h_in_Z_units ) 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(in) :: h !< Layer thickness [H ~> m or kg m-2]. + intent(in) :: h !< Layer thicknesses, in [H ~> m or kg m-2] or + !! [Z ~> m] depending on the value of h_in_Z_units. real, dimension(:,:,:), pointer :: tr !< Pointer to array to be initialized [CU ~> conc] type(param_file_type), intent(in) :: PF !< parameter file character(len=*), intent(in) :: src_file !< source filename @@ -54,12 +56,18 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ character(len=*), optional, intent(in) :: remappingScheme !< remapping scheme to use. character(len=*), optional, intent(in) :: src_var_gridspec !< Source variable name in a gridspec file. !! This is not implemented yet. + logical, optional, intent(in) :: h_in_Z_units !< If present and true, the input grid + !! thicknesses are in the units of height + !! ([Z ~> m]) instead of the usual units of + !! thicknesses ([H ~> m or kg m-2]) + ! Local variables real :: land_fill = 0.0 ! A value to use to replace missing values [CU ~> conc] real :: convert ! A conversion factor into the model's internal units [CU conc-1 ~> 1] integer :: recnum character(len=64) :: remapScheme logical :: homog, useALE + logical :: h_is_in_Z_units ! This include declares and sets the variable "version". # include "version_variable.h" @@ -84,6 +92,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ 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] + real :: dz_neglect ! A negligibly small vertical layer extent used in + ! remapping cell reconstructions [Z ~> m] + real :: dz_neglect_edge ! A negligibly small vertical layer extent used in + ! remapping edge value calculations [Z ~> m] integer :: nPoints ! The number of valid input data points in a column integer :: id_clock_routine, id_clock_ALE integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. @@ -143,6 +155,8 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ convert = 1.0 if (PRESENT(src_var_unit_conversion)) convert = src_var_unit_conversion + h_is_in_Z_units = .false. ; if (present(h_in_Z_units)) h_is_in_Z_units = h_in_Z_units + call horiz_interp_and_extrap_tracer(src_file, src_var_nam, recnum, & G, tr_z, mask_z, z_in, z_edges_in, missing_value, & scale=convert, homogenize=homog, m_to_Z=US%m_to_Z, answer_date=hor_regrid_answer_date) @@ -185,12 +199,18 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ 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 ) + if (h_is_in_Z_units) then + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + else + ! 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 ) + endif deallocate( hSrc ) deallocate( dzSrc ) From e7a7a82ab33a339b124c0435a8005769417c321b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 27 Jan 2024 13:10:18 -0500 Subject: [PATCH 529/629] (*)MOM_temp_salt_init_from_Z Z-unit tracer remap Revise MOM_temp_salt_initialize_from_Z in cases when Z_INIT_REMAP_GENERAL is False to call ALE_remap_scalar with vertical layer extents (in Z units) rather than layer thicknesses (in H units). When in fully non-Boussinesq mode, this same routine uses dz_to_thickness (using the full equation of state) rather than dz_to_thickness_simple to initialize the layer thicknesses. Boussinesq answers are bitwise identical, but answers can change in some fully non-Boussinesq cases. --- .../MOM_state_initialization.F90 | 36 ++++++++++++++----- 1 file changed, 27 insertions(+), 9 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 7dfced262b..855a6f2aa0 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -92,6 +92,7 @@ module MOM_state_initialization use MOM_ALE, only : ALE_remap_scalar, ALE_regrid_accelerated, TS_PLM_edge_values use MOM_regridding, only : regridding_CS, set_regrid_params, getCoordinateResolution use MOM_regridding, only : regridding_main, regridding_preadjust_reqs, convective_adjustment +use MOM_regridding, only : set_dz_neglect use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_horizontal_regridding, only : horiz_interp_and_extrap_tracer, homogenize_field use MOM_oda_incupd, only: oda_incupd_CS, initialize_oda_incupd_fixed, initialize_oda_incupd @@ -2483,6 +2484,10 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just 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 :: dz_neglect ! A negligibly small vertical layer extent used in + ! remapping cell reconstructions [Z ~> m] + real :: dz_neglect_edge ! A negligibly small vertical layer extent used in + ! remapping edge value calculations [Z ~> m] real :: zTopOfCell, zBottomOfCell ! Heights in Z units [Z ~> m]. type(regridding_CS) :: regridCS ! Regridding parameters and work arrays type(remapping_CS) :: remapCS ! Remapping parameters and work arrays @@ -2768,6 +2773,11 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just frac_shelf_h=frac_shelf_h ) deallocate( dz_interface ) + + 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, & + old_remap=remap_old_alg, answer_date=remap_answer_date ) else ! This is the old way of initializing to z* coordinates only allocate( hTarget(nz) ) @@ -2788,16 +2798,24 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just enddo ; enddo deallocate( hTarget ) - ! 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) + dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) + call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpT1dIn, dz, tv%T, all_cells=remap_full_column, & + old_remap=remap_old_alg, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + call ALE_remap_scalar(remapCS, G, GV, nkd, dz1, tmpS1dIn, dz, tv%S, all_cells=remap_full_column, & + old_remap=remap_old_alg, answer_date=remap_answer_date, & + H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) + + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + ! This is a simple conversion of the target grid to thickness units that is not + ! appropriate in non-Boussinesq mode. + call dz_to_thickness_simple(dz, h, G, GV, US) + else + ! Convert dz into thicknesses in units of H using the equation of state as appropriate. + call dz_to_thickness(dz, tv, h, G, GV, US) + endif 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, & - old_remap=remap_old_alg, answer_date=remap_answer_date ) - deallocate( dz1 ) deallocate( h1 ) deallocate( tmpT1dIn ) @@ -2879,7 +2897,7 @@ subroutine MOM_temp_salt_initialize_from_Z(h, tv, depth_tot, G, GV, US, PF, just ks, G, GV, US, PF, just_read) endif - ! Now convert thicknesses to units of H. + ! Now convert dz into thicknesses in units of H. call dz_to_thickness(dz, tv, h, G, GV, US) endif ! useALEremapping From 9a6ddee4787192b41da90ff803ae29d54e577d54 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Jan 2024 10:16:54 -0500 Subject: [PATCH 530/629] *+non-Boussinesq revisions to MOM_generic_tracer Revised initialize_MOM_generic_tracer to use thickness_to_dz to get the layer vertical extents and then provide these to MOM_initialize_tracer_from_Z to read in initial generic tracer concentrations from Z-space files. The previous approach inappropriately used an simple multiplicative rescaling (via a call to dz_to_thickness_simple in MOM_initialize_tracer_from_Z) by a factor that includes the Boussinesq reference density when in non-Boussinesq mode. A new thermo_vars_type arguments was added to initialize_MOM_generic_tracer to allow for this change. Also revised MOM_generic_tracer_column_physics to use thickness_to_dz instead of a simple multiplicative rescaling to get the layer vertical extents (in m) that are used in calls to generic_tracer_source. The multiplicative factor that was used previously (GV%H_to_m) includes the Boussinesq reference density and hence is inappropriate in non-Boussinesq mode; using thickness_to_dz avoids this. Also added comments documenting the meaning and units of about 30 real variables in the MOM_generic_tracer routines. There is a new mandatory argument to initialize_MOM_generic_tracer. All Boussinseq mode answers are bitwise identical, but in non-Boussinesq mode mode generic tracer answers are changed by avoiding the use of the Boussinesq reference density in several places. --- src/tracer/MOM_generic_tracer.F90 | 144 ++++++++++++++----------- src/tracer/MOM_tracer_flow_control.F90 | 2 +- 2 files changed, 84 insertions(+), 62 deletions(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 131110e6b2..7f550d8de5 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -38,6 +38,7 @@ module MOM_generic_tracer use MOM_forcing_type, only : forcing, optics_type use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type + use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : file_exists, MOM_read_data, slasher use MOM_open_boundary, only : ocean_OBC_type use MOM_open_boundary, only : register_obgc_segments, fill_obgc_segments @@ -75,8 +76,10 @@ module MOM_generic_tracer character(len = 200) :: IC_file !< The file in which the generic tracer initial values can !! be found, or an empty string for internal initialization. logical :: Z_IC_file !< If true, the generic_tracer IC_file is in Z-space. The default is false. - real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers. - real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out. + real :: tracer_IC_val = 0.0 !< The initial value assigned to tracers, in + !! concentration units [conc] + real :: tracer_land_val = -1.0 !< The values of tracers used where land is masked out, in + !! concentration units [conc] logical :: tracers_may_reinit !< If true, tracers may go through the !! initialization code if they are not found in the restart files. @@ -102,6 +105,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer !! advection and diffusion module. type(MOM_restart_CS), target, intent(inout) :: restart_CS !< MOM restart control struct + ! Local variables logical :: register_MOM_generic_tracer logical :: obc_has @@ -113,14 +117,17 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! These can be overridden later in via the field manager? integer :: ntau, axes(3) - type(g_tracer_type), pointer :: g_tracer,g_tracer_next - character(len=fm_string_len) :: g_tracer_name,longname,units - character(len=fm_string_len) :: obc_src_file_name,obc_src_field_name - real :: lfac_in,lfac_out - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr - real, dimension(HI%isd:HI%ied, HI%jsd:HI%jed,GV%ke) :: grid_tmask - integer, dimension(HI%isd:HI%ied, HI%jsd:HI%jed) :: grid_kmt + type(g_tracer_type), pointer :: g_tracer, g_tracer_next + character(len=fm_string_len) :: g_tracer_name, longname,units + character(len=fm_string_len) :: obc_src_file_name, obc_src_field_name + real :: lfac_in ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with inflowing tracer reservoirs at OBCs [nondim] + real :: lfac_out ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with outflowing tracer reservoirs at OBCs [nondim] + real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(SZI_(HI),SZJ_(HI),SZK_(GV)) :: grid_tmask ! A 3-d copy of G%mask2dT [nondim] + integer, dimension(SZI_(HI),SZJ_(HI)) :: grid_kmt ! A 2-d array of nk register_MOM_generic_tracer = .false. if (associated(CS)) then @@ -141,7 +148,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) ! Read all relevant parameters and write them to the model log. call log_version(param_file, sub_name, version, "") call get_param(param_file, sub_name, "GENERIC_TRACER_IC_FILE", CS%IC_file, & - "The file in which the generic trcer initial values can "//& + "The file in which the generic tracer initial values can "//& "be found, or an empty string for internal initialization.", & default=" ") if ((len_trim(CS%IC_file) > 0) .and. (scan(CS%IC_file,'/') == 0)) then @@ -169,7 +176,7 @@ function register_MOM_generic_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) !Fields cannot be diag registered as they are allocated and have to registered later. grid_tmask(:,:,:) = 0.0 - grid_kmt(:,:) = 0.0 + grid_kmt(:,:) = 0 axes(:) = -1 ! @@ -222,23 +229,26 @@ end function register_MOM_generic_tracer !> Register OBC segments for generic tracers subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, - !! where, and what open boundary conditions are used. - type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer - !! advection and diffusion module. - type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, + !! where, and what open boundary conditions are used. + type(tracer_registry_type), pointer :: tr_Reg !< Pointer to the control structure for the tracer + !! advection and diffusion module. + type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters + ! Local variables logical :: obc_has ! This include declares and sets the variable "version". # include "version_variable.h" - character(len=128), parameter :: sub_name = 'register_MOM_generic_tracer_segments' type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name - character(len=fm_string_len) :: obc_src_file_name,obc_src_field_name - real :: lfac_in,lfac_out + character(len=fm_string_len) :: obc_src_file_name, obc_src_field_name + real :: lfac_in ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with inflowing tracer reservoirs at OBCs [nondim] + real :: lfac_out ! Multiplicative factor used in setting the tracer-specific inverse length + ! scales associated with outflowing tracer reservoirs at OBCs [nondim] if (.NOT. associated(OBC)) return !Get the tracer list @@ -266,6 +276,7 @@ subroutine register_MOM_generic_tracer_segments(CS, GV, OBC, tr_Reg, param_file) enddo end subroutine register_MOM_generic_tracer_segments + !> Initialize phase II: Initialize required variables for generic tracers !! There are some steps of initialization that cannot be done in register_MOM_generic_tracer !! This is the place and time to do them: @@ -275,15 +286,17 @@ end subroutine register_MOM_generic_tracer_segments !! !! This subroutine initializes the NTR tracer fields in tr(:,:,:,:) !! and it sets up the tracer output. - subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, CS, & - sponge_CSp, ALE_sponge_CSp) + subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & + CS, sponge_CSp, ALE_sponge_CSp) logical, intent(in) :: restart !< .true. if the fields have already been !! read from a restart file. type(time_type), target, intent(in) :: day !< Time of the start of the run. type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(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 [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic + !! variables type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters type(diag_ctrl), target, intent(in) :: diag !< Regulates diagnostic output. type(ocean_OBC_type), pointer :: OBC !< This open boundary condition type specifies whether, @@ -298,10 +311,11 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, integer :: i, j, k, isc, iec, jsc, jec, nk type(g_tracer_type), pointer :: g_tracer,g_tracer_next character(len=fm_string_len) :: g_tracer_name - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr - real, dimension(G%isd:G%ied, G%jsd:G%jed, 1:GV%ke) :: grid_tmask - integer, dimension(G%isd:G%ied, G%jsd:G%jed) :: grid_kmt + real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Layer vertical extent [Z ~> m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: grid_tmask ! A 3-d copy of G%mask2dT [nondim] + integer, dimension(SZI_(G),SZJ_(G)) :: grid_kmt ! A 2-d array of nk !! 2010/02/04 Add code to re-initialize Generic Tracers if needed during a model simulation !! By default, restart cpio should not contain a Generic Tracer IC file and step below will be skipped. @@ -316,6 +330,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, !For each tracer name get its fields g_tracer=>CS%g_tracer_list + call thickness_to_dz(h, tv, dz, G, GV, US) + do if (INDEX(CS%IC_file, '_NULL_') /= 0) then call MOM_error(WARNING, "The name of the IC_file "//trim(CS%IC_file)//& @@ -335,12 +351,11 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, "initializing generic tracer "//trim(g_tracer_name)//& " using MOM_initialize_tracer_from_Z ") - call MOM_initialize_tracer_from_Z(h, tr_ptr, G, GV, US, param_file, & - src_file = g_tracer%src_file, & - src_var_nam = g_tracer%src_var_name, & - src_var_unit_conversion = g_tracer%src_var_unit_conversion,& - src_var_record = g_tracer%src_var_record, & - src_var_gridspec = g_tracer%src_var_gridspec ) + call MOM_initialize_tracer_from_Z(dz, tr_ptr, G, GV, US, param_file, & + src_file=g_tracer%src_file, src_var_nam=g_tracer%src_var_name, & + src_var_unit_conversion=g_tracer%src_var_unit_conversion, & + src_var_record=g_tracer%src_var_record, src_var_gridspec=g_tracer%src_var_gridspec, & + h_in_Z_units=.true.) !Check/apply the bounds for each g_tracer do k=1,nk ; do j=jsc,jec ; do i=isc,iec @@ -466,8 +481,9 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(optics_type), intent(in) :: optics !< The structure containing optical properties. - real, optional, intent(in) :: evap_CFL_limit !< Limits how much water can be fluxed out of - !! the top layer Stored previously in diabatic CS. + real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can + !! be fluxed out of the top layer in a timestep [nondim] + ! Stored previously in diabatic CS. real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which fluxes !! can be applied [H ~> m or kg m-2] ! Stored previously in diabatic CS. @@ -479,14 +495,17 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, type(g_tracer_type), pointer :: g_tracer, g_tracer_next character(len=fm_string_len) :: g_tracer_name - real, dimension(:,:), pointer :: stf_array,trunoff_array,runoff_tracer_flux_array + real, dimension(:,:), pointer :: stf_array ! The surface flux of the tracer [conc kg m-2 s-1] + real, dimension(:,:), pointer :: trunoff_array ! The tracer concentration in the river runoff [conc] + real, dimension(:,:), pointer :: runoff_tracer_flux_array ! The runoff tracer flux [conc kg m-2 s-1] - real :: surface_field(SZI_(G),SZJ_(G)) + real :: surface_field(SZI_(G),SZJ_(G)) ! The surface value of some field, here only used for salinity [S ~> ppt] real :: dz_ml(SZI_(G),SZJ_(G)) ! The mixed layer depth in the MKS units used for generic tracers [m] - real :: sosga + real :: sosga ! The global mean surface salinity [ppt] - real, dimension(G%isd:G%ied,G%jsd:G%jed,GV%ke) :: rho_dzt, dzt - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: rho_dzt ! Layer mass per unit area [kg m-2] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dzt ! Layer vertical extents [m] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! A work array of thicknesses [H ~> m or kg m-2] integer :: i, j, k, isc, iec, jsc, jec, nk isc = G%isc ; iec = G%iec ; jsc = G%jsc ; jec = G%jec ; nk = GV%ke @@ -536,14 +555,15 @@ subroutine MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, ! rho_dzt(:,:,:) = GV%H_to_kg_m2 * GV%Angstrom_H - do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ + do k=1,nk ; do j=jsc,jec ; do i=isc,iec rho_dzt(i,j,k) = GV%H_to_kg_m2 * h_old(i,j,k) - enddo ; enddo ; enddo !} + enddo ; enddo ; enddo dzt(:,:,:) = 1.0 - do k = 1, nk ; do j = jsc, jec ; do i = isc, iec !{ - dzt(i,j,k) = GV%H_to_m * h_old(i,j,k) - enddo ; enddo ; enddo !} + call thickness_to_dz(h_old, tv, dzt, G, GV, US) + do k=1,nk ; do j=jsc,jec ; do i=isc,iec + dzt(i,j,k) = US%Z_to_m * dzt(i,j,k) + enddo ; enddo ; enddo dz_ml(:,:) = 0.0 do j=jsc,jec ; do i=isc,iec surface_field(i,j) = tv%S(i,j,1) @@ -639,8 +659,8 @@ function MOM_generic_tracer_stock(h, stocks, G, GV, CS, names, units, stock_inde ! Local variables type(g_tracer_type), pointer :: g_tracer, g_tracer_next - real, dimension(:,:,:,:), pointer :: tr_field - real, dimension(:,:,:), pointer :: tr_ptr + real, dimension(:,:,:,:), pointer :: tr_field ! A pointer to a generic tracer field, in concentration units [conc] + real, dimension(:,:,:), pointer :: tr_ptr ! A pointer to a generic tracer field, in concentration units [conc] character(len=128), parameter :: sub_name = 'MOM_generic_tracer_stock' integer :: m @@ -802,7 +822,7 @@ subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, n real :: tmax, tmin ! Maximum and minimum tracer values, in the same units as tr_array real :: tmax0, tmin0 ! First-guest values of tmax and tmin. integer :: itmax, jtmax, ktmax, itmin, jtmin, ktmin - real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema. + real :: fudge ! A factor that is close to 1 that is used to find the location of the extrema [nondim]. ! arrays to enable vectorization integer :: iminarr(3), imaxarr(3) @@ -853,7 +873,7 @@ subroutine array_global_min_max(tr_array, tmask, isd, jsd, isc, iec, jsc, jec, n ! Now find the location of the global extrema. ! - ! Note that the fudge factor above guarantees that the location of max (min) is uinque, + ! Note that the fudge factor above guarantees that the location of max (min) is unique, ! since tmax0 (tmin0) has slightly different values on each processor. ! Otherwise, the function tr_array(i,j,k) could be equal to global max (min) at more ! than one point in space and this would be a much more difficult problem to solve. @@ -899,16 +919,16 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. -! Local variables - real :: sosga + ! Local variables + real :: sosga ! The global mean surface salinity [ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV),1) :: rho0 ! An unused array of densities [kg m-3] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dzt ! Layer vertical extents [m] character(len=128), parameter :: sub_name = 'MOM_generic_tracer_surface_state' - real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke,1) :: rho0 - real, dimension(G%isd:G%ied,G%jsd:G%jed,1:GV%ke) :: dzt !Set coupler values !nnz: fake rho0 - rho0=1.0 + rho0(:,:,:,:) = 1.0 dzt(:,:,:) = GV%H_to_m * h(:,:,:) @@ -937,7 +957,7 @@ subroutine MOM_generic_tracer_surface_state(sfc_state, h, G, GV, CS) !Niki: The problem with calling diagnostic outputs here is that this subroutine is called every dt_cpld ! hence if dt_therm > dt_cpld we get output (and contribution to the mean) at times that tracers ! had not been updated. - ! Moving this to the end of column physics subrotuine fixes this issue. + ! Moving this to the end of column physics subroutine fixes this issue. end subroutine MOM_generic_tracer_surface_state @@ -976,7 +996,7 @@ end subroutine MOM_generic_flux_init subroutine MOM_generic_tracer_fluxes_accumulate(flux_tmp, weight) type(forcing), intent(in) :: flux_tmp !< A structure containing pointers to !! thermodynamic and tracer forcing fields. - real, intent(in) :: weight !< A weight for accumulating this flux + real, intent(in) :: weight !< A weight for accumulating this flux [nondim] call generic_tracer_coupler_accumulate(flux_tmp%tr_fluxes, weight) @@ -986,10 +1006,12 @@ end subroutine MOM_generic_tracer_fluxes_accumulate subroutine MOM_generic_tracer_get(name,member,array, CS) character(len=*), intent(in) :: name !< Name of requested tracer. character(len=*), intent(in) :: member !< The tracer element to return. - real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine. - type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. + real, dimension(:,:,:), intent(out) :: array !< Array filled by this routine, in arbitrary units [A] + type(MOM_generic_tracer_CS), pointer :: CS !< Pointer to the control structure for this module. - real, dimension(:,:,:), pointer :: array_ptr + ! Local variables + real, dimension(:,:,:), pointer :: array_ptr ! The tracer in the generic tracer structures, in + ! arbitrary units [A] character(len=128), parameter :: sub_name = 'MOM_generic_tracer_get' call g_tracer_get_pointer(CS%g_tracer_list,name,member,array_ptr) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index c8ce2f5f75..6d035e1d27 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -340,7 +340,7 @@ subroutine tracer_flow_control_init(restart, day, G, GV, US, h, param_file, diag call initialize_CFC_cap(restart, day, G, GV, US, h, diag, OBC, CS%CFC_cap_CSp) if (CS%use_MOM_generic_tracer) & - call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, param_file, diag, OBC, & + call initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_file, diag, OBC, & CS%MOM_generic_tracer_CSp, sponge_CSp, ALE_sponge_CSp) if (CS%use_pseudo_salt_tracer) & call initialize_pseudo_salt_tracer(restart, day, G, GV, US, h, diag, OBC, CS%pseudo_salt_tracer_CSp, & From ea12532d8ef9fb41a0f663c3b84e49eedcf95c21 Mon Sep 17 00:00:00 2001 From: William Cooke Date: Thu, 1 Feb 2024 13:59:24 -0500 Subject: [PATCH 531/629] Fix issue with restart filenames when using ensembles. Moved call for filename_appendix outside of loop. Fixes issue where restart filename was ./MOM.res.ens_01.nc ./MOM.res.ens_01.ens_01_1.nc ./MOM.res.ens_01.ens_01.ens_01_2.nc ./MOM.res.ens_01.ens_01.ens_01.ens_01_3.nc instead of ./MOM.res.ens_01.nc ./MOM.res.ens_01_1.nc ./MOM.res.ens_01_2.nc ./MOM.res.ens_01_3.nc --- src/framework/MOM_restart.F90 | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/src/framework/MOM_restart.F90 b/src/framework/MOM_restart.F90 index 188cfbb2ec..06f4abc065 100644 --- a/src/framework/MOM_restart.F90 +++ b/src/framework/MOM_restart.F90 @@ -1406,6 +1406,17 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ restartname = trim(CS%restartfile)//trim(restartname) endif ; endif + ! Determine if there is a filename_appendix (used for ensemble runs). + call get_filename_appendix(filename_appendix) + if (len_trim(filename_appendix) > 0) then + length = len_trim(restartname) + if (restartname(length-2:length) == '.nc') then + restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' + else + restartname = restartname(1:length) //'.'//trim(filename_appendix) + endif + endif + next_var = 1 do while (next_var <= CS%novars ) start_var = next_var @@ -1430,17 +1441,6 @@ subroutine save_restart(directory, time, G, CS, time_stamped, filename, GV, num_ enddo next_var = m - ! Determine if there is a filename_appendix (used for ensemble runs). - call get_filename_appendix(filename_appendix) - if (len_trim(filename_appendix) > 0) then - length = len_trim(restartname) - if (restartname(length-2:length) == '.nc') then - restartname = restartname(1:length-3)//'.'//trim(filename_appendix)//'.nc' - else - restartname = restartname(1:length) //'.'//trim(filename_appendix) - endif - endif - restartpath = trim(directory) // trim(restartname) if (num_files < 10) then From 9282cd100b293e5140ef557597d23d192f910dde Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jan 2024 14:51:45 -0500 Subject: [PATCH 532/629] +(*)Bodner param with cuberoot and non-Boussinesq Use the new cuberoot function in the Bodner estimate of u'w' when the new runtime parameter ML_RESTRAT_ANSWER_DATE is 20240201 or higher, which avoids the need to undo and redo the dimensional scaling in this calculation. In addition, the refactoring associated with this change explicitly revealed that as it was implemented it introduced an undesirable dependency on the value of the Boussinesq reference density, RHO_0, when in non-Boussinesq mode. To avoid this, a new version of the Bodner u'w' calculation was introduced in fully non-Boussinesq mode, which does change answers with this combination; because there is not yet a known case that used this combination, we have chosen not to add a runtime parameter to preserve the old answers when the Bodner parameterization is used in fully-Boussinesq mode. This change will modify the contents of some MOM_parameter_doc files with USE_BODNER=True, and it changes answers in cases that are also fully non-Boussinesq. The new runtime parameter ML_RESTRAT_ANSWER_DATE might need to be set below 20240201 to retain some existing Boussinesq answers. --- .../lateral/MOM_mixed_layer_restrat.F90 | 99 ++++++++++++++----- 1 file changed, 74 insertions(+), 25 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 36a83cd43a..c10a55309b 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -14,6 +14,7 @@ module MOM_mixed_layer_restrat use MOM_forcing_type, only : mech_forcing, find_ustar use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_intrinsic_functions, only : cuberoot use MOM_lateral_mixing_coeffs, only : VarMix_CS use MOM_restart, only : register_restart_field, query_initialized, MOM_restart_CS use MOM_unit_scaling, only : unit_scale_type @@ -67,7 +68,7 @@ module MOM_mixed_layer_restrat 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 - !! [m2 s-2]. This avoids a division-by-zero in the limit when u* + !! [Z2 T-2 ~> 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 [T ~> s]. @@ -81,6 +82,11 @@ module MOM_mixed_layer_restrat real :: MLD_growing_Tfilt !< The time-scale for a running-mean filter applied to the time-filtered !! 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. + integer :: answer_date !< The vintage of the order of arithmetic and expressions in the + !! mixed layer restrat calculations. Values below 20240201 recover + !! the answers from the end of 2023, while higher values use the new + !! cuberoot function in the Bodner code to avoid needing to undo + !! dimensional rescaling. logical :: debug = .false. !< If true, calculate checksums of fields for debugging. @@ -279,7 +285,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, !! TODO: use derivatives and mid-MLD pressure. Currently this is sigma-0. -AJA pRef_MLD(:) = 0. EOSdom(:) = EOS_domain(G%HI, halo=1) - do j = js-1, je+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 call calculate_density(tv%T(:,j,1), tv%S(:,j,1), pRef_MLD, tv%varT(:,j,1), covTS, varS, & @@ -289,7 +295,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, endif deltaRhoAtK(:) = 0. MLD_fast(:,j) = 0. - do k = 2, nz + do k=2,nz dKm1(:) = dK(:) ! Depth of center of layer K-1 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) @@ -300,10 +306,10 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, else call calculate_density(tv%T(:,j,k), tv%S(:,j,k), pRef_MLD, deltaRhoAtK, tv%eqn_of_state, EOSdom) endif - do i = is-1,ie+1 + do i=is-1,ie+1 deltaRhoAtK(i) = deltaRhoAtK(i) - rhoSurf(i) ! Density difference between layer K and surface enddo - do i = is-1, ie+1 + do i=is-1,ie+1 ddRho = deltaRhoAtK(i) - deltaRhoAtKm1(i) if ((MLD_fast(i,j)==0.) .and. (ddRho>0.) .and. & (deltaRhoAtKm1(i)=CS%MLE_density_diff)) then @@ -312,7 +318,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, endif enddo ! i-loop enddo ! k-loop - do i = is-1, ie+1 + do i=is-1,ie+1 MLD_fast(i,j) = CS%MLE_MLD_stretch * MLD_fast(i,j) if ((MLD_fast(i,j)==0.) .and. (deltaRhoAtK(i) m4 s-2 kg-1 or m7 s-2 kg-2] 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 :: w_star3 ! Cube of turbulent convective velocity [Z3 T-3 ~> m3 s-3] + real :: u_star3 ! Cube of surface friction velocity [Z3 T-3 ~> m3 s-3] real :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] real :: grid_dsd ! combination of grid scales [L2 ~> m2] @@ -837,6 +843,10 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 :: Z3_T3_to_m3_s3 ! Conversion factors to undo scaling and permit terms to be raised to a + ! fractional power [T3 m3 Z-3 s-3 ~> 1] + real :: m2_s2_to_Z2_T2 ! Conversion factors to restore scaling after a term is raised to a + ! fractional power [Z2 s2 T-2 m-2 ~> 1] real, parameter :: two_thirds = 2./3. ! [nondim] logical :: line_is_empty, keep_going integer, dimension(2) :: EOSdom ! The i-computational domain for the equation of state @@ -881,7 +891,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! 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). if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then - do j = js-1, je+1 ; do i = is-1, ie+1 + do j=js-1,je+1 ; do i=is-1,ie+1 little_h(i,j) = rmean2ts(GV%Z_to_H*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) @@ -912,21 +922,49 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d endif ! 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 + 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 T3 Z-3 s-3 ~> 1] - u_star3 = ( US%Z_to_m * US%s_to_T * U_star_2d(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_L * GV%m_to_H * US%T_to_s**2 ) ! [L H s2 m-2 T-2 ~> 1 or kg m-3] - ! We filter w'u' with the same time scales used for "little h" + ! Estimate w'u' at h-points, with a floor to avoid division by zero later. + if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + do j=js-1,je+1 ; do i=is-1,ie+1 + ! This expression differs by a factor of 1. / (Rho_0 * SpV_avg) compared with the other + ! expressions below, and it is invariant to the value of Rho_0 in non-Boussinesq mode. + wpup(i,j) = max((cuberoot( CS%mstar * U_star_2d(i,j)**3 + & + CS%nstar * max(0., -bflux(i,j)) * BLD(i,j) ))**2, CS%min_wstar2) * & + ( US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + ! The final line above converts from [Z2 T-2 ~> m2 s-2] to [L H T-2 ~> m2 s-2 or Pa]. + ! Some rescaling factors and the division by specific volume compensating for other + ! factors that are in find_ustar_mech, and others effectively converting the wind + ! stresses from [R L Z T-2 ~> Pa] to [L H T-2 ~> m2 s-2 or Pa]. The rescaling factors + ! and density being applied to the buoyancy flux are not so neatly explained because + ! fractional powers cancel out or combine with terms in the definitions of BLD and + ! bflux (such as SpV_avg**-2/3 combining with other terms in bflux to give the thermal + ! expansion coefficient) and because the specific volume does vary within the mixed layer. + enddo ; enddo + elseif (CS%answer_date < 20240201) then + Z3_T3_to_m3_s3 = (US%Z_to_m * US%s_to_T)**3 + m2_s2_to_Z2_T2 = (US%m_to_Z * US%T_to_s)**2 + do j=js-1,je+1 ; do i=is-1,ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] + u_star3 = U_star_2d(i,j)**3 ! In [Z3 T-3 ~> m3 s-3] + wpup(i,j) = max(m2_s2_to_Z2_T2 * (Z3_T3_to_m3_s3 * ( CS%mstar * u_star3 + CS%nstar * w_star3 ) )**two_thirds, & + CS%min_wstar2) * & + ( US%Z_to_L * US%Z_to_m * GV%m_to_H ) ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] + wpup(i,j) = max( (cuberoot(CS%mstar * U_star_2d(i,j)**3 + CS%nstar * w_star3))**2, CS%min_wstar2 ) * & + ( US%Z_to_L * US%Z_to_m * GV%m_to_H ) ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + enddo ; enddo + endif + + ! We filter w'u' with the same time scales used for "little h" + do j=js-1,je+1 ; do i=is-1,ie+1 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) @@ -1459,7 +1497,7 @@ end subroutine mixedlayer_restrat_BML !> Return the growth timescale for the submesoscale mixed layer eddies in [T ~> s] real function growth_time(u_star, hBL, absf, h_neg, vonKar, Kv_rest, restrat_coef) real, intent(in) :: u_star !< Surface friction velocity in thickness-based units [H T-1 ~> m s-1 or kg m-2 s-1] - real, intent(in) :: hBL !< Boundary layer thickness including at least a neglible + real, intent(in) :: hBL !< Boundary layer thickness including at least a negligible !! value to keep it positive definite [H ~> m or kg m-2] real, intent(in) :: absf !< Absolute value of the Coriolis parameter [T-1 ~> s-1] real, intent(in) :: h_neg !< A tiny thickness that is usually lost in roundoff so can be @@ -1513,6 +1551,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] + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags ! This include declares and sets the variable "version". # include "version_variable.h" integer :: i, j @@ -1581,13 +1620,23 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "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, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "ML_RESTRAT_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic and expressions in the mixed layer "//& + "restrat calculations. Values below 20240201 recover the answers from the end "//& + "of 2023, while higher values use the new cuberoot function in the Bodner code "//& + "to avoid needing to undo dimensional rescaling.", & + default=default_answer_date, & + do_not_log=.not.(CS%use_Bodner.and.(GV%Boussinesq.or.GV%semi_Boussinesq))) 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. "//& "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) ! This parameter stays in MKS units. + units="m2 s-2", default=1.0e-24, scale=US%m_to_Z**2*US%T_to_s**2) 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 4757bcb52dec41a0a2aa0facac1de6fd88ccc905 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 21 Jan 2024 18:05:31 -0500 Subject: [PATCH 533/629] Remove some unused calculations if non-Boussinesq Eliminated some unused calculations in wave_speed and thickness_diffuse_full that would use the Boussinesq reference density when in non-Boussinesq mode, either by adding logical flags around the calculations so that they only occur in Boussinesq mode. All answers are bitwise identical. --- src/diagnostics/MOM_wave_speed.F90 | 9 ++++----- src/parameterizations/lateral/MOM_thickness_diffuse.F90 | 3 +-- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/src/diagnostics/MOM_wave_speed.F90 b/src/diagnostics/MOM_wave_speed.F90 index 59dbfc184e..5caf47a51c 100644 --- a/src/diagnostics/MOM_wave_speed.F90 +++ b/src/diagnostics/MOM_wave_speed.F90 @@ -197,10 +197,10 @@ subroutine wave_speed(h, tv, G, GV, US, cg1, CS, halo_size, use_ebt_mode, mono_N enddo ; enddo ; enddo endif - g_Rho0 = GV%g_Earth*GV%H_to_Z / GV%Rho0 + nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) H_to_pres = GV%H_to_RZ * GV%g_Earth ! Note that g_Rho0 = H_to_pres / GV%Rho0**2 - nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + if (.not.nonBous) g_Rho0 = GV%g_Earth*GV%H_to_Z / GV%Rho0 use_EOS = associated(tv%eqn_of_state) better_est = CS%better_cg1_est @@ -900,9 +900,9 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s is = G%isc - halo ; ie = G%iec + halo ; js = G%jsc - halo ; je = G%jec + halo endif - g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 - H_to_pres = GV%H_to_RZ * GV%g_Earth nonBous = .not.(GV%Boussinesq .or. GV%semi_Boussinesq) + H_to_pres = GV%H_to_RZ * GV%g_Earth + if (.not.nonBous) g_Rho0 = GV%g_Earth * GV%H_to_Z / GV%Rho0 use_EOS = associated(tv%eqn_of_state) if (CS%c1_thresh < 0.0) & @@ -1057,7 +1057,6 @@ subroutine wave_speeds(h, tv, G, GV, US, nmodes, cn, CS, w_struct, u_struct, u_s enddo endif endif - cg1_est = g_Rho0 * drxh_sum else ! Not use_EOS drxh_sum = 0.0 ; dSpVxh_sum = 0.0 if (better_est) then diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index 2638ca71e1..c510acdf0d 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -773,11 +773,10 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV I4dt = 0.25 / dt I_slope_max2 = 1.0 / (CS%slope_max**2) - G_scale = GV%g_Earth * GV%H_to_Z h_neglect = GV%H_subroundoff ; h_neglect2 = h_neglect**2 ; hn_2 = 0.5*h_neglect dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect**2 - G_rho0 = GV%g_Earth / GV%Rho0 + if (GV%Boussinesq) G_rho0 = GV%g_Earth / GV%Rho0 N2_floor = CS%N2_floor * US%Z_to_L**2 use_EOS = associated(tv%eqn_of_state) From de7e5b79f4d485d95393113b80a75881d4c6c72c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 1 Feb 2024 09:05:40 -0500 Subject: [PATCH 534/629] Document MOM_regridding and coord variable units Added or amended comments describing about 90 variables in the MOM_regridding, coord_adapt, coord_rho, and coord_sigma modules to document the purpose and units of real variables using the MOM6 standard syntax. A missing doxygen comment was also added to describe inflate_vanished_layers_old(). A few unused internal variables were also eliminated, including the max_depth_index_scale element of the regridding_CS type. All answers are bitwise identical and only comments are changed. --- src/ALE/MOM_regridding.F90 | 160 ++++++++++++++++++++++++------------- src/ALE/coord_adapt.F90 | 32 +++++--- src/ALE/coord_rho.F90 | 23 +++--- src/ALE/coord_sigma.F90 | 4 +- 4 files changed, 138 insertions(+), 81 deletions(-) diff --git a/src/ALE/MOM_regridding.F90 b/src/ALE/MOM_regridding.F90 index 904164c8e7..8faec6c495 100644 --- a/src/ALE/MOM_regridding.F90 +++ b/src/ALE/MOM_regridding.F90 @@ -49,11 +49,11 @@ module MOM_regridding !> This array is set by function setCoordinateResolution() !! It contains the "resolution" or delta coordinate of the target !! coordinate. It has the units of the target coordinate, e.g. - !! [Z ~> m] for z*, non-dimensional for sigma, etc. + !! [Z ~> m] for z*, [nondim] for sigma, etc. real, dimension(:), allocatable :: coordinateResolution !> This is a scaling factor that restores coordinateResolution to values in - !! the natural units for output. + !! the natural units for output, perhaps [nondim] real :: coord_scale = 1.0 !> This array is set by function set_target_densities() @@ -102,17 +102,13 @@ module MOM_regridding real :: depth_of_time_filter_deep = 0. !> Fraction (between 0 and 1) of compressibility to add to potential density - !! profiles when interpolating for target grid positions. [nondim] + !! profiles when interpolating for target grid positions [nondim] real :: compressibility_fraction = 0. !> If true, each interface is given a maximum depth based on a rescaling of !! the indexing of coordinateResolution. logical :: set_maximum_depths = .false. - !> A scaling factor (> 1) of the rate at which the coordinateResolution list - !! is traversed to set the minimum depth of interfaces. - real :: max_depth_index_scale = 2.0 - !> If true, integrate for interface positions from the top downward. !! If false, integrate from the bottom upward, as does the rest of the model. logical :: integrate_downward_for_e = .true. @@ -215,7 +211,9 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real :: tmpReal ! A temporary variable used in setting other variables [various] real :: P_Ref ! The coordinate variable reference pression [R L2 T-2 ~> Pa] real :: maximum_depth ! The maximum depth of the ocean [m] (not in Z). - real :: adaptTimeRatio, adaptZoom, adaptZoomCoeff, adaptBuoyCoeff, adaptAlpha + real :: adaptTimeRatio, adaptZoomCoeff ! Temporary variables for input parameters [nondim] + real :: adaptBuoyCoeff, adaptAlpha ! Temporary variables for input parameters [nondim] + real :: adaptZoom ! The thickness of the near-surface zooming region with the adaptive coordinate [H ~> m or kg m-2] real :: adaptDrho0 ! Reference density difference for stratification-dependent diffusion. [R ~> kg m-3] integer :: k, nzf(4) real, dimension(:), allocatable :: dz ! Resolution (thickness) in units of coordinate, which may be [m] @@ -226,7 +224,7 @@ subroutine initialize_regridding(CS, GV, US, max_depth, param_file, mdl, coord_m real, dimension(:), allocatable :: dz_max ! Thicknesses used to find maximum interface depths ! [H ~> m or kg m-2] or other units real, dimension(:), allocatable :: rho_target ! Target density used in HYBRID mode [kg m-3] - ! Thicknesses [m] that give level centers corresponding to table 2 of WOA09 + !> Thicknesses [m] that give level centers corresponding to table 2 of WOA09 real, dimension(40) :: woa09_dz = (/ 5., 10., 10., 15., 22.5, 25., 25., 25., & 37.5, 50., 50., 75., 100., 100., 100., 100., & 100., 100., 100., 100., 100., 100., 100., 175., & @@ -804,7 +802,6 @@ subroutine regridding_main( remapCS, CS, G, GV, US, h, tv, h_new, dzInterface, & real :: tot_dz(SZI_(G),SZJ_(G)) !< The total distance between the top and bottom of the water column [Z ~> m] real :: Z_to_H ! A conversion factor used by some routines to convert coordinate ! parameters to depth units [H Z-1 ~> nondim or kg m-3] - real :: trickGnuCompiler character(len=128) :: mesg ! A string for error messages integer :: i, j, k @@ -967,11 +964,14 @@ end subroutine calc_h_new_by_dz subroutine check_grid_column( nk, h, dzInterface, msg ) integer, intent(in) :: nk !< Number of cells real, dimension(nk), intent(in) :: h !< Cell thicknesses [Z ~> m] or arbitrary units - real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (same units as h) + real, dimension(nk+1), intent(in) :: dzInterface !< Change in interface positions (same units as h), often [Z ~> m] character(len=*), intent(in) :: msg !< Message to append to errors ! Local variables integer :: k - real :: eps, total_h_old, total_h_new, h_new + real :: eps ! A tiny relative thickness [nondim] + real :: total_h_old ! The total thickness in the old column, in [Z ~> m] or arbitrary units + real :: total_h_new ! The total thickness in the updated column, in [Z ~> m] or arbitrary units + real :: h_new ! A thickness in the updated column, in [Z ~> m] or arbitrary units eps =1. ; eps = epsilon(eps) @@ -1023,17 +1023,31 @@ subroutine filtered_grid_motion( CS, nk, z_old, z_new, dz_g ) type(regridding_CS), intent(in) :: CS !< Regridding control structure integer, intent(in) :: nk !< Number of cells in source grid real, dimension(nk+1), intent(in) :: z_old !< Old grid position [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(in) :: z_new !< New grid position before filtering [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_g !< Change in interface positions including + !! the effects of filtering [H ~> m or kg m-2] ! Local variables - real :: sgn ! The sign convention for downward. - real :: dz_tgt, zr1, z_old_k - real :: Aq, Bq, dz0, z0, F0 - real :: zs, zd, dzwt, Idzwt - real :: wtd, Iwtd - real :: Int_zs, Int_zd, dInt_zs_zd + real :: sgn ! The sign convention for downward [nondim]. + real :: dz_tgt ! The target grid movement of the unfiltered grid [H ~> m or kg m-2] + real :: zr1 ! The old grid position of an interface relative to the surface [H ~> m or kg m-2] + real :: z_old_k ! The corrected position of the old grid [H ~> m or kg m-2] + real :: Aq ! A temporary variable related to the grid weights [nondim] + real :: Bq ! A temporary variable used in the linear term in the quadratic expression for the + ! filtered grid movement [H ~> m or kg m-2] + real :: z0, dz0 ! Together these give the position of an interface relative to a reference hieght + ! that may be adjusted for numerical accuracy in a solver [H ~> m or kg m-2] + real :: F0 ! An estimated grid movement [H ~> m or kg m-2] + real :: zs ! The depth at which the shallow filtering timescale applies [H ~> m or kg m-2] + real :: zd ! The depth at which the deep filtering timescale applies [H ~> m or kg m-2] + real :: dzwt ! The depth range over which the transition in the filtering timescale occurs [H ~> m or kg m-2] + real :: Idzwt ! The Adcroft reciprocal of dzwt [H-1 ~> m-1 or m2 kg-1] + real :: wtd ! The weight given to the new grid when time filtering [nondim] + real :: Iwtd ! The inverse of wtd [nondim] + real :: Int_zs ! A depth integral of the weights in [H ~> m or kg m-2] + real :: Int_zd ! A depth integral of the weights in [H ~> m or kg m-2] + real :: dInt_zs_zd ! The depth integral of the weights between the deep and shallow depths in [H ~> m or kg m-2] ! For debugging: - real, dimension(nk+1) :: z_act + real, dimension(nk+1) :: z_act ! The final grid positions after the filtered movement [H ~> m or kg m-2] ! real, dimension(nk+1) :: ddz_g_s, ddz_g_d logical :: debug = .false. integer :: k @@ -1552,8 +1566,9 @@ subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, type(regridding_CS), intent(in) :: CS !< Regridding control structure real, dimension(SZI_(G),SZJ_(G),CS%nk), intent(inout) :: h_new !< New layer thicknesses [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),CS%nk+1), intent(inout) :: dzInterface !< Changes in interface position + !! in thickness units [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: frac_shelf_h !< Fractional ice shelf - !! coverage [nondim] + !! coverage [nondim] real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate !! resolution in Z to desired units for zInterface, !! usually Z_to_H in which case it is in @@ -1564,11 +1579,13 @@ subroutine build_grid_HyCOM1( G, GV, US, h, nom_depth_H, tv, h_new, dzInterface, real, dimension(SZK_(GV)) :: p_col ! Layer center pressure in the input column [R L2 T-2 ~> Pa] real, dimension(CS%nk+1) :: z_col_new ! New interface positions relative to the surface [H ~> m or kg m-2] real, dimension(CS%nk+1) :: dz_col ! The realized change in z_col [H ~> m or kg m-2] - integer :: i, j, k, nki - real :: nominalDepth - real :: h_neglect, h_neglect_edge - real :: z_top_col, totalThickness + real :: nominalDepth ! The nominal depth of the seafloor in thickness units [H ~> m or kg m-2] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses used for remapping [H ~> m or kg m-2] + real :: z_top_col ! The nominal height of the sea surface or ice-ocean interface + ! in thickness units [H ~> m or kg m-2] + real :: totalThickness ! The total thickness of the water column [H ~> m or kg m-2] logical :: ice_shelf + integer :: i, j, k, nki h_neglect = set_h_neglect(GV, CS%remap_answer_date, h_neglect_edge) @@ -1696,11 +1713,16 @@ end subroutine build_grid_adaptive subroutine adjust_interface_motion( CS, nk, h_old, dz_int ) type(regridding_CS), intent(in) :: CS !< Regridding control structure integer, intent(in) :: nk !< Number of layers in h_old - real, dimension(nk), intent(in) :: h_old !< Minimum allowed thickness of h [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(inout) :: dz_int !< Minimum allowed thickness of h [H ~> m or kg m-2] + real, dimension(nk), intent(in) :: h_old !< Layer thicknesses on the old grid [H ~> m or kg m-2] + real, dimension(CS%nk+1), intent(inout) :: dz_int !< Interface movements, adjusted to keep the thicknesses + !! thicker than their minimum value [H ~> m or kg m-2] ! Local variables + real :: h_new ! A layer thickness on the new grid [H ~> m or kg m-2] + real :: eps ! A tiny relative thickness [nondim] + real :: h_total ! The total thickness of the old grid [H ~> m or kg m-2] + real :: h_err ! An error tolerance that use used to flag unacceptably large negative layer thicknesses + ! that can not be explained by roundoff errors [H ~> m or kg m-2] integer :: k - real :: h_new, eps, h_total, h_err eps = 1. ; eps = epsilon(eps) @@ -1753,8 +1775,9 @@ end subroutine adjust_interface_motion !------------------------------------------------------------------------------ -! Check grid integrity -!------------------------------------------------------------------------------ +!> make sure all layers are at least as thick as the minimum thickness allowed +!! for regridding purposes by inflating thin layers. This breaks mass conservation +!! and adds mass to the model when there are excessively thin layers. subroutine inflate_vanished_layers_old( CS, G, GV, h ) !------------------------------------------------------------------------------ ! This routine is called when initializing the regridding options. The @@ -1765,14 +1788,14 @@ subroutine inflate_vanished_layers_old( CS, G, GV, h ) !------------------------------------------------------------------------------ ! Arguments - type(regridding_CS), intent(in) :: CS !< Regridding 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 - real, dimension(SZI_(G),SZJ_(G), SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + type(regridding_CS), intent(in) :: CS !< Regridding 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 + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variables integer :: i, j, k - real :: hTmp(GV%ke) + real :: hTmp(GV%ke) ! A copy of a 1-d column of h [H ~> m or kg m-2] do i = G%isc-1,G%iec+1 do j = G%jsc-1,G%jec+1 @@ -1872,11 +1895,15 @@ function uniformResolution(nk,coordMode,maxDepth,rhoLight,rhoHeavy) character(len=*), intent(in) :: coordMode !< A string indicating the coordinate mode. !! See the documentation for regrid_consts !! for the recognized values. - real, intent(in) :: maxDepth !< The range of the grid values in some modes - real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode - real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode + real, intent(in) :: maxDepth !< The range of the grid values in some modes, in coordinate + !! dependent units that might be [m] or [kg m-3] or [nondim] + !! or something else. + real, intent(in) :: rhoLight !< The minimum value of the grid in RHO mode [kg m-3] + real, intent(in) :: rhoHeavy !< The maximum value of the grid in RHO mode [kg m-3] - real :: uniformResolution(nk) !< The returned uniform resolution grid. + real :: uniformResolution(nk) !< The returned uniform resolution grid, in + !! coordinate dependent units that might be [m] or + !! [kg m-3] or [nondim] or something else. ! Local variables integer :: scheme @@ -1935,9 +1962,14 @@ end subroutine initCoord !------------------------------------------------------------------------------ !> Set the fixed resolution data subroutine setCoordinateResolution( dz, CS, scale ) - real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings + real, dimension(:), intent(in) :: dz !< A vector of vertical grid spacings, in arbitrary coordinate + !! dependent units, such as [m] for a z-coordinate or [kg m-3] + !! for a density coordinate. type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, optional, intent(in) :: scale !< A scaling factor converting dz to coordRes + real, optional, intent(in) :: scale !< A scaling factor converting dz to the internal represetation + !! of coordRes, in various units that depend on the coordinate, + !! such as [Z m-1 ~> 1 for a z-coordinate or [R m3 kg-1 ~> 1] for + !! a density coordinate. if (size(dz)/=CS%nk) call MOM_error( FATAL, & 'setCoordinateResolution: inconsistent number of levels' ) @@ -1990,10 +2022,12 @@ end subroutine set_target_densities !> Set maximum interface depths based on a vector of input values. subroutine set_regrid_max_depths( CS, max_depths, units_to_H ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, dimension(CS%nk+1), intent(in) :: max_depths !< Maximum interface depths, in arbitrary units - real, optional, intent(in) :: units_to_H !< A conversion factor for max_depths into H units + real, dimension(CS%nk+1), intent(in) :: max_depths !< Maximum interface depths, in arbitrary units, often [m] + real, optional, intent(in) :: units_to_H !< A conversion factor for max_depths into H units, + !! often in [H m-1 ~> 1 or kg m-3] ! Local variables - real :: val_to_H + real :: val_to_H ! A conversion factor from the units for max_depths into H units, often [H m-1 ~> 1 or kg m-3] + ! if units_to_H is present, or [nondim] if it is absent. integer :: K if (.not.allocated(CS%max_interface_depths)) allocate(CS%max_interface_depths(1:CS%nk+1)) @@ -2026,11 +2060,13 @@ end subroutine set_regrid_max_depths !> Set maximum layer thicknesses based on a vector of input values. subroutine set_regrid_max_thickness( CS, max_h, units_to_H ) type(regridding_CS), intent(inout) :: CS !< Regridding control structure - real, dimension(CS%nk+1), intent(in) :: max_h !< Maximum interface depths, in arbitrary units - real, optional, intent(in) :: units_to_H !< A conversion factor for max_h into H units + real, dimension(CS%nk+1), intent(in) :: max_h !< Maximum layer thicknesses, in arbitrary units, often [m] + real, optional, intent(in) :: units_to_H !< A conversion factor for max_h into H units, + !! often [H m-1 ~> 1 or kg m-3] ! Local variables - real :: val_to_H - integer :: K + real :: val_to_H ! A conversion factor from the units for max_h into H units, often [H m-1 ~> 1 or kg m-3] + ! if units_to_H is present, or [nondim] if it is absent. + integer :: k if (.not.allocated(CS%max_layer_thickness)) allocate(CS%max_layer_thickness(1:CS%nk)) @@ -2059,7 +2095,9 @@ subroutine write_regrid_file( CS, GV, filepath ) type(vardesc) :: vars(2) type(MOM_field) :: fields(2) type(MOM_netCDF_file) :: IO_handle ! The I/O handle of the fileset - real :: ds(GV%ke), dsi(GV%ke+1) + real :: ds(GV%ke), dsi(GV%ke+1) ! The labeling layer and interface coordinates for output + ! in axes in files, in coordinate-dependent units that can + ! be obtained from getCoordinateUnits [various] if (CS%regridding_scheme == REGRIDDING_HYBGEN) then call write_Hybgen_coord_file(GV, CS%hybgen_CS, filepath) @@ -2134,7 +2172,8 @@ function getCoordinateResolution( CS, undo_scaling ) type(regridding_CS), intent(in) :: CS !< Regridding control structure logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal !! rescaling of the resolution data. - real, dimension(CS%nk) :: getCoordinateResolution + real, dimension(CS%nk) :: getCoordinateResolution !< The resolution or delta of the target coordinate, + !! in units that depend on the coordinate [various] logical :: unscale unscale = .false. ; if (present(undo_scaling)) unscale = undo_scaling @@ -2152,7 +2191,8 @@ function getCoordinateInterfaces( CS, undo_scaling ) type(regridding_CS), intent(in) :: CS !< Regridding control structure logical, optional, intent(in) :: undo_scaling !< If present and true, undo any internal !! rescaling of the resolution data. - real, dimension(CS%nk+1) :: getCoordinateInterfaces !< Interface positions in target coordinate + real, dimension(CS%nk+1) :: getCoordinateInterfaces !< Interface positions in target coordinate, + !! in units that depend on the coordinate [various] integer :: k logical :: unscale @@ -2258,7 +2298,7 @@ subroutine set_regrid_params( CS, boundary_extrapolation, min_thickness, old_gri logical, optional, intent(in) :: boundary_extrapolation !< Extrapolate in boundary cells real, optional, intent(in) :: min_thickness !< Minimum thickness allowed when building the !! new grid [H ~> m or kg m-2] - real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid + real, optional, intent(in) :: old_grid_weight !< Weight given to old coordinate when time-filtering grid [nondim] character(len=*), optional, intent(in) :: interp_scheme !< Interpolation method for state-dependent coordinates real, optional, intent(in) :: depth_of_time_filter_shallow !< Depth to start cubic [H ~> m or kg m-2] real, optional, intent(in) :: depth_of_time_filter_deep !< Depth to end cubic [H ~> m or kg m-2] @@ -2379,9 +2419,10 @@ end function get_rho_CS !> Return coordinate-derived thicknesses for fixed coordinate systems function getStaticThickness( CS, SSH, depth ) type(regridding_CS), intent(in) :: CS !< Regridding control structure - real, intent(in) :: SSH !< The sea surface height, in the same units as depth + real, intent(in) :: SSH !< The sea surface height, in the same units as depth, often [Z ~> m] real, intent(in) :: depth !< The maximum depth of the grid, often [Z ~> m] - real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of depth + real, dimension(CS%nk) :: getStaticThickness !< The returned thicknesses in the units of + !! depth, often [Z ~> m] ! Local integer :: k real :: z, dz ! Vertical positions and grid spacing [Z ~> m] @@ -2476,7 +2517,14 @@ integer function rho_function1( string, rho_target ) real, dimension(:), allocatable, intent(inout) :: rho_target !< Profile of interface densities [kg m-3] ! Local variables integer :: nki, k, nk - real :: ddx, dx, rho_1, rho_2, rho_3, drho, rho_4, drho_min + real :: dx ! Fractional distance from interface nki [nondim] + real :: ddx ! Change in dx between interfaces [nondim] + real :: rho_1, rho_2 ! Density of the top two layers in a profile [kg m-3] + real :: rho_3 ! Density in the third layer, below which the density increase linearly + ! in subsequent layers [kg m-3] + real :: drho ! Change in density over the linear region [kg m-3] + real :: rho_4 ! The densest density in this profile [kg m-3], which might be very large. + real :: drho_min ! A minimal fractional density difference [nondim]? read( string, *) nk, rho_1, rho_2, rho_3, drho, rho_4, drho_min allocate(rho_target(nk+1)) diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index ee612788c9..32513c8ad3 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -22,19 +22,19 @@ module coord_adapt !> Nominal near-surface resolution [H ~> m or kg m-2] real, allocatable, dimension(:) :: coordinateResolution - !> Ratio of optimisation and diffusion timescales + !> Ratio of optimisation and diffusion timescales [nondim] real :: adaptTimeRatio - !> Nondimensional coefficient determining how much optimisation to apply + !> Nondimensional coefficient determining how much optimisation to apply [nondim] real :: adaptAlpha !> Near-surface zooming depth [H ~> m or kg m-2] real :: adaptZoom - !> Near-surface zooming coefficient + !> Near-surface zooming coefficient [nondim] real :: adaptZoomCoeff - !> Stratification-dependent diffusion coefficient + !> Stratification-dependent diffusion coefficient [nondim] real :: adaptBuoyCoeff !> Reference density difference for stratification-dependent diffusion [R ~> kg m-3] @@ -55,8 +55,10 @@ subroutine init_coord_adapt(CS, nk, coordinateResolution, m_to_H, kg_m3_to_R) integer, intent(in) :: nk !< Number of layers in the grid real, dimension(:), intent(in) :: coordinateResolution !< Nominal near-surface resolution [m] or !! other units specified with m_to_H - real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses - real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density + real, intent(in) :: m_to_H !< A conversion factor from m to the units of thicknesses, + !! perhaps in units of [H m-1 ~> 1 or kg m-3] + real, intent(in) :: kg_m3_to_R !< A conversion factor from kg m-3 to the units of density, + !! perhaps in units of [R m3 kg-1 ~> 1] if (associated(CS)) call MOM_error(FATAL, "init_coord_adapt: CS already associated") allocate(CS) @@ -89,11 +91,11 @@ end subroutine end_coord_adapt subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoomCoeff, & adaptBuoyCoeff, adaptDrho0, adaptDoMin) type(adapt_CS), pointer :: CS !< The control structure for this module - real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales + real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales [nondim] real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining !! how much optimisation to apply real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth [H ~> m or kg m-2] - real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient + real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient [nondim] real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient real, optional, intent(in) :: adaptDrho0 !< Reference density difference for !! stratification-dependent diffusion [R ~> kg m-3] @@ -129,17 +131,25 @@ subroutine build_adapt_column(CS, G, GV, US, tv, i, j, zInt, tInt, sInt, h, nom_ !! relative to mean sea level or another locally !! valid reference height, converted to thickness !! units [H ~> m or kg m-2] - real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions + real, dimension(SZK_(GV)+1), intent(inout) :: zNext !< updated interface positions [H ~> m or kg m-2] ! Local variables integer :: k, nz - real :: h_up, b1, b_denom_1, d1, depth, nominal_z, stretching + real :: h_up ! The upwind source grid thickness based on the direction of the + ! adjustive fluxes [H ~> m or kg m-2] + real :: b1 ! The inverse of the tridiagonal denominator [nondim] + real :: b_denom_1 ! The leading term in the tridiagonal denominator [nondim] + real :: d1 ! A term in the tridiagonal expressions [nondim] + real :: depth ! Depth in thickness units [H ~> m or kg m-2] + real :: nominal_z ! A nominal interface position in thickness units [H ~> m or kg m-2] + real :: stretching ! A stretching factor for the water column [nondim] real :: drdz ! The vertical density gradient [R H-1 ~> kg m-4 or m-1] real, dimension(SZK_(GV)+1) :: alpha ! drho/dT [R C-1 ~> kg m-3 degC-1] real, dimension(SZK_(GV)+1) :: beta ! drho/dS [R S-1 ~> kg m-3 ppt-1] real, dimension(SZK_(GV)+1) :: del2sigma ! Laplacian of in situ density times grid spacing [R ~> kg m-3] real, dimension(SZK_(GV)+1) :: dh_d2s ! Thickness change in response to del2sigma [H ~> m or kg m-2] - real, dimension(SZK_(GV)) :: kGrid, c1 ! grid diffusivity on layers, and tridiagonal work array + real, dimension(SZK_(GV)) :: kGrid ! grid diffusivity on layers [nondim] + real, dimension(SZK_(GV)) :: c1 ! A tridiagonal work array [nondim] nz = CS%nk diff --git a/src/ALE/coord_rho.F90 b/src/ALE/coord_rho.F90 index 7b6c0e0f8c..3ed769f4e4 100644 --- a/src/ALE/coord_rho.F90 +++ b/src/ALE/coord_rho.F90 @@ -100,7 +100,7 @@ subroutine build_rho_column(CS, nz, depth, h, T, S, eqn_of_state, z_interface, & real, dimension(nz), intent(in) :: S !< Salinity for source column [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure real, dimension(CS%nk+1), & - intent(inout) :: z_interface !< Absolute positions of interfaces + intent(inout) :: z_interface !< Absolute positions of interfaces [H ~> m or kg m-2] real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same !! units as depth) [H ~> m or kg m-2] real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same @@ -200,7 +200,7 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz), intent(in) :: T !< T for column [C ~> degC] real, dimension(nz), intent(in) :: S !< S for column [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< Equation of state structure - real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, dimension(nz+1), intent(inout) :: zInterface !< Absolute positions of interfaces [Z ~> m] real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions !! in the same units as h [Z ~> m] @@ -216,7 +216,6 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ real, dimension(nz) :: pres ! The pressure used in the equation of state [R L2 T-2 ~> Pa]. real, dimension(nz) :: densities ! Layer densities [R ~> kg m-3] real, dimension(nz) :: T_tmp, S_tmp ! A temporary profile of temperature [C ~> degC] and salinity [S ~> ppt]. - real, dimension(nz) :: Tmp ! A temporary variable holding a remapped variable. real, dimension(nz) :: h0, h1, hTmp ! Temporary thicknesses [Z ~> m] real :: deviation ! When iterating to determine the final grid, this is the ! deviation between two successive grids [Z ~> m]. @@ -273,11 +272,9 @@ subroutine build_rho_column_iteratively(CS, remapCS, nz, depth, h, T, S, eqn_of_ h1(k) = x1(k+1) - x1(k) enddo - call remapping_core_h(remapCS, nz, h0, S, nz, h1, Tmp, h_neglect, h_neglect_edge) - S_tmp(:) = Tmp(:) + call remapping_core_h(remapCS, nz, h0, S, nz, h1, S_tmp, h_neglect, h_neglect_edge) - call remapping_core_h(remapCS, nz, h0, T, nz, h1, Tmp, h_neglect, h_neglect_edge) - T_tmp(:) = Tmp(:) + call remapping_core_h(remapCS, nz, h0, T, nz, h1, T_tmp, h_neglect, h_neglect_edge) ! Compute the deviation between two successive grids deviation = 0.0 @@ -365,17 +362,19 @@ end subroutine copy_finite_thicknesses subroutine old_inflate_layers_1d( min_thickness, nk, h ) ! Argument - real, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] + real, intent(in) :: min_thickness !< Minimum allowed thickness [H ~> m or kg m-2] or other units integer, intent(in) :: nk !< Number of layers in the grid - real, dimension(:), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] + real, dimension(:), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] or other units ! Local variable integer :: k integer :: k_found integer :: count_nonzero_layers - real :: delta - real :: correction - real :: maxThickness + real :: delta ! An increase to a layer to increase it to the minimum thickness in the + ! same units as h, often [H ~> m or kg m-2] + real :: correction ! The accumulated correction that will be applied to the thickest layer + ! to give mass conservation in the same units as h, often [H ~> m or kg m-2] + real :: maxThickness ! The thickness of the thickest layer in the same units as h, often [H ~> m or kg m-2] ! Count number of nonzero layers count_nonzero_layers = 0 diff --git a/src/ALE/coord_sigma.F90 b/src/ALE/coord_sigma.F90 index 19c3213996..a2a5820487 100644 --- a/src/ALE/coord_sigma.F90 +++ b/src/ALE/coord_sigma.F90 @@ -13,10 +13,10 @@ module coord_sigma !> Number of levels integer :: nk - !> Minimum thickness allowed for layers + !> Minimum thickness allowed for layers [H ~> m or kg m-2] real :: min_thickness - !> Target coordinate resolution, nondimensional + !> Target coordinate resolution [nondim] real, allocatable, dimension(:) :: coordinateResolution end type sigma_CS From 71665fb65fcf1df6c7f648e3d9998d68328a71a8 Mon Sep 17 00:00:00 2001 From: Ian Grooms Date: Sat, 10 Feb 2024 16:03:58 -0700 Subject: [PATCH 535/629] Fix biharmonic leith (#268) * Fix biharmonic Leith Biharmonic Leith uses Del omega at is-1 and js-1. This unavoidably requires u at js-3 and v at is-3, which are unavailable. It also requires Del omega at Ieq+1 and Jeq+1, which requires v at Ieq+3 and u at Jeq+3, which are unavailable. This necessitates a halo update. Fixes several bugs in Leith+E. - Fixes indexing when computing smoothed vorticity and its gradient - Crucially, computes `vert_vort_mag` when using Leith+E - Fixes some logic in the smoothing code - Other minor indexing fixes * Leith+E Logic Update Ah is required at h and q points. The original code computed Ah at h points, then packed into Ah_h, then applied upper bounds to Ah. If Ah_h is in the diag_table or if debug is true, then the value of Ah with upper bounds get packed into Ah_h. Then, at q points the code unpacks Ah_h. This update makes sure that the upper bound gets applied to q points, not just h points. * Leith+E halo updates The main thing that this commit does is to perform smoothing of u and v outside of the loop over layers. This swaps nz 2D blocking halo updates for a single blocking 3D halo update. * Leith+E smoothing This commit adds a runtime flag, SMOOTH_AH. If True (default) then `m_leithy` and `Ah` are both smoothed, which leads to many blocking communications. If False then these fields are rougher, but there is less communication. * Leith+E eliminate pass-var This commit removes one halo update in Leith+E. To achieve this requires re-indexing two assignments. The value of Ah and Kh are computed at h points, then re-used at q points. Without the halo update it is necessary to offset the assignment at h and q points, e.g. Kh(I,J) = Kh_h(i+1,j+1,k), to avoid accessing values that have not been computed. * Leith+E OBC Adds code so that Leith+E works with OBC. * Leith+E eliminate halo update This commit eliminates one more halo update in Leith+E. * *Correct rotational symmetry with USE_LEITHY This commit revises the smoothing code used when USE_LEITHY = True to give answers that respect rotational symmetry and it also corrects some horizontal indexing bugs and problems with the staggering in some halo update and smooth_x9 calls and reduces some loop ranges to their minimal required values. The specific changes include: 1. Corrected a horizontal indexing bug when interpolating Kh_h and Ah_h to corner (q) points when USE_LEITHY = True. These had previously been inappropriately copied from the thickness point to the southwest of the corner point. This required symmetric-memory-mode calculations of the thickness point viscosities whenever USE_LEITHY is true, but to avoid adding complicated logic, the symmetric-memory loop bounds are used for the calculation of Kh. 2. Revised smooth_x9 to give rotationally symmetric answers and split it into the two routines smooth_x9_h and smooth_x9_uv to reduce the memory used by this routine and reduce the use of optional arguments. 3. Eliminated 4 unneeded halo update calls, and added error handling for the case where Leith options are used with insufficiently wide halos. 4. Added new integers to indicate the loop ranges over which the viscosities and related variables should be calculated, depending on which options are active, and then adjusted 91 do-loop extents horizontal_viscosity code to reflect the loop ranges over which arrays are actually used. 5. Added a new 2-d variable for the squared viscosity for smoothing that can be used for halo updates and to avoid having a variable with confusingly inconsistent dimensions at various points in the code. 6. Corrected the position arguments on 2 smooth_x9 calls and 4 pass_var calls that are used when USE_LEITHY=.true. and SMOOTH_AH=.true. As previously written, these smooth_x9 and pass_var calls would work when in non-symmetric memory mode but would give incorrect answers when in symmetric memory mode. These revisions change answers when USE_LEITHY is true, but answers are bitwise identical in all other cases. --------- Co-authored-by: Robert Hallberg --- .../lateral/MOM_hor_visc.F90 | 565 ++++++++++-------- 1 file changed, 312 insertions(+), 253 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 5bd3809a85..4d57556d03 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -74,6 +74,8 @@ module MOM_hor_visc !! Ah is the background. Leithy = Leith+E real :: c_K !< Fraction of energy dissipated by the biharmonic term !! that gets backscattered in the Leith+E scheme. [nondim] + logical :: smooth_Ah !< If true (default), then Ah and m_leithy are smoothed. + !! This smoothing requires a lot of blocking communication. logical :: use_QG_Leith_visc !< If true, use QG Leith nonlinear eddy viscosity. !! KH is the background value. logical :: bound_Coriolis !< If true & SMAGORINSKY_AH is used, the biharmonic @@ -270,16 +272,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, vort_xy_dy, & ! y-derivative of vertical vorticity (d/dy(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] vort_xy_dy_smooth, & ! y-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dx, & ! x-derivative of horizontal divergence (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - ubtav, & ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] - u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + ubtav ! zonal barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G)) :: & Del2v, & ! The v-component of the Laplacian of velocity [L-1 T-1 ~> m-1 s-1] h_v, & ! Thickness interpolated to v points [H ~> m or kg m-2]. vort_xy_dx, & ! x-derivative of vertical vorticity (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] vort_xy_dx_smooth, & ! x-derivative of smoothed vertical vorticity [L-1 T-1 ~> m-1 s-1] div_xx_dy, & ! y-derivative of horizontal divergence (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - vbtav, & ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] - v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + vbtav ! meridional barotropic velocity averaged over a baroclinic time-step [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G)) :: & dudx_bt, dvdy_bt, & ! components in the barotropic horizontal tension [T-1 ~> s-1] div_xx, & ! Estimate of horizontal divergence at h-points [T-1 ~> s-1] @@ -297,8 +297,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, dudx, dvdy, & ! components in the horizontal tension [T-1 ~> s-1] dudx_smooth, dvdy_smooth, & ! components in the horizontal tension from smoothed velocity [T-1 ~> s-1] GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] - htot, & ! The total thickness of all layers [Z ~> m] - m_leithy ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] + m_leithy, & ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] + Ah_sq, & ! The square of the biharmonic viscosity [L8 T-2 ~> m8 s-2] + htot ! The total thickness of all layers [Z ~> m] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] @@ -321,9 +322,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, grad_vort_mag_q_2d, & ! Magnitude of 2d vorticity gradient at q-points [L-1 T-1 ~> m-1 s-1] Del2vort_q, & ! Laplacian of vorticity at q-points [L-2 T-1 ~> m-2 s-1] grad_div_mag_q, & ! Magnitude of divergence gradient at q-points [L-1 T-1 ~> m-1 s-1] - hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] - ! This form guarantees that hq/hu < 4. - GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] + hq, & ! harmonic mean of the harmonic means of the u- & v point thicknesses [H ~> m or kg m-2] + ! This form guarantees that hq/hu < 4. + GME_effic_q ! The filtered efficiency of the GME terms at q points [nondim] real :: grad_vel_mag_bt_q ! Magnitude of the barotropic velocity gradient tensor squared at q-points [T-2 ~> s-2] real :: boundary_mask_q ! A mask that zeroes out cells with at least one land edge [nondim] @@ -353,10 +354,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Zanna-Bolton fields real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & + u_smooth, & ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] 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)) :: & + v_smooth, & ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] ZB2020v !< Meridional acceleration due to convergence !! of along-coordinate stress tensor for ZB model !! [L T-2 ~> m s-2] @@ -400,6 +403,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: apply_OBC = .false. logical :: use_MEKE_Ku logical :: use_MEKE_Au + integer :: is_vort, ie_vort, js_vort, je_vort ! Loop ranges for vorticity terms + integer :: is_Kh, ie_Kh, js_Kh, je_Kh ! Loop ranges for thickness point viscosities integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] @@ -428,8 +433,6 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, inv_PI2 = 1.0/((4.0*atan(1.0))**2) inv_PI6 = inv_PI3 * inv_PI3 - m_leithy(:,:) = 0. ! Initialize - if (present(OBC)) then ; if (associated(OBC)) then ; if (OBC%OBC_pe) then apply_OBC = OBC%Flather_u_BCs_exist_globally .or. OBC%Flather_v_BCs_exist_globally apply_OBC = .true. @@ -465,6 +468,22 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, "RES_SCALE_MEKE_VISC is True.") endif + ! Set the halo sizes used for the thickness-point viscosities. + if (CS%use_Leithy) then + js_Kh = js-1 ; je_Kh = je+1 ; is_Kh = is-1 ; ie_Kh = ie+1 + else + js_Kh = Jsq ; je_Kh = je+1 ; is_Kh = Isq ; ie_Kh = ie+1 + endif + + ! Set the halo sizes used for the vorticity calculations. + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then + js_vort = js_Kh-2 ; je_vort = Jeq+2 ; is_vort = is_Kh-2 ; ie_vort = Ieq+2 + if ((G%isc-G%isd < 3) .or. (G%isc-G%isd < 3)) call MOM_error(FATAL, & + "The minimum halo size is 3 when a Leith viscosity is being used.") + else + js_vort = js-2 ; je_vort = Jeq+1 ; is_vort = is-2 ; ie_vort = Ieq+1 + endif + legacy_bound = (CS%Smagorinsky_Kh .or. CS%Leith_Kh) .and. & (CS%bound_Kh .and. .not.CS%better_bound_Kh) @@ -483,7 +502,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call pass_var(h, G%domain, halo=2) ! Calculate the barotropic horizontal tension - do J=js-2,je+2 ; do I=is-2,ie+2 + do j=js-2,je+2 ; do i=is-2,ie+2 dudx_bt(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * ubtav(I,j) - & G%IdyCu(I-1,j) * ubtav(I-1,j)) dvdy_bt(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * vbtav(i,J) - & @@ -502,11 +521,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo if (CS%no_slip) then - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + do J=js-2,je+1 ; do I=is-2,ie+1 sh_xy_bt(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo else - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + do J=js-2,je+1 ; do I=is-2,ie+1 sh_xy_bt(I,J) = G%mask2dBu(I,J) * ( dvdx_bt(I,J) + dudy_bt(I,J) ) enddo ; enddo endif @@ -557,12 +576,24 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! use_GME + if (CS%use_Leithy) then + ! Smooth the velocity. Right now it happens twice. In the future + ! one might make the number of smoothing cycles a user-specified parameter + do k=1,nz + ! One call applies the filter twice + u_smooth(:,:,k) = u(:,:,k) + v_smooth(:,:,k) = v(:,:,k) + call smooth_x9_uv(G, u_smooth(:,:,k), v_smooth(:,:,k), zero_land=.false.) + enddo + call pass_vector(u_smooth, v_smooth, G%Domain) + endif + !$OMP parallel do default(none) & !$OMP shared( & !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & - !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & - !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, & + !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, is_vort, ie_vort, js_vort, je_vort, & + !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & + !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & @@ -585,8 +616,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP h2uq, h2vq, hu, hv, hq, FatH, RoScl, GME_coeff, & !$OMP dudx_smooth, dudy_smooth, dvdx_smooth, dvdy_smooth, & !$OMP vort_xy_smooth, vort_xy_dx_smooth, vort_xy_dy_smooth, & - !$OMP sh_xx_smooth, sh_xy_smooth, u_smooth, v_smooth, & - !$OMP vert_vort_mag_smooth, m_leithy, AhLthy & + !$OMP sh_xx_smooth, sh_xy_smooth, & + !$OMP vert_vort_mag_smooth, m_leithy, Ah_sq, AhLthy & !$OMP ) do k=1,nz @@ -610,37 +641,32 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo ! Components for the shearing strain - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + do J=js_vort,je_vort ; do I=is_vort,ie_vort dvdx(I,J) = CS%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) = CS%DX_dyBu(I,J)*(u(I,j+1,k)*G%IdxCu(I,j+1) - u(I,j,k)*G%IdxCu(I,j)) enddo ; enddo if (CS%use_Leithy) then - ! Smooth the velocity. Right now it happens twice. In the future - ! one might make the number of smoothing cycles a user-specified parameter - u_smooth(:,:) = u(:,:,k) - v_smooth(:,:) = v(:,:,k) - call smooth_x9(CS, G, field_u=u_smooth,field_v=v_smooth) ! one call applies the filter twice ! Calculate horizontal tension from smoothed velocity - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - dudx_smooth(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u_smooth(I,j) - & - G%IdyCu(I-1,j) * u_smooth(I-1,j)) - dvdy_smooth(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v_smooth(i,J) - & - G%IdxCv(i,J-1) * v_smooth(i,J-1)) + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + dudx_smooth(i,j) = CS%DY_dxT(i,j)*(G%IdyCu(I,j) * u_smooth(I,j,k) - & + G%IdyCu(I-1,j) * u_smooth(I-1,j,k)) + dvdy_smooth(i,j) = CS%DX_dyT(i,j)*(G%IdxCv(i,J) * v_smooth(i,J,k) - & + G%IdxCv(i,J-1) * v_smooth(i,J-1,k)) sh_xx_smooth(i,j) = dudx_smooth(i,j) - dvdy_smooth(i,j) enddo ; enddo ! Components for the shearing strain from smoothed velocity - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh dvdx_smooth(I,J) = CS%DY_dxBu(I,J) * & - (v_smooth(i+1,J)*G%IdyCv(i+1,J) - v_smooth(i,J)*G%IdyCv(i,J)) + (v_smooth(i+1,J,k)*G%IdyCv(i+1,J) - v_smooth(i,J,k)*G%IdyCv(i,J)) dudy_smooth(I,J) = CS%DX_dyBu(I,J) * & - (u_smooth(I,j+1)*G%IdxCu(I,j+1) - u_smooth(I,j)*G%IdxCu(I,j)) + (u_smooth(I,j+1,k)*G%IdxCu(I,j+1) - u_smooth(I,j,k)*G%IdxCu(I,j)) enddo ; enddo - end if ! use Leith+E + endif ! use Leith+E if (CS%id_normstress > 0) then - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + do j=js,je ; do i=is,ie NoSt(i,j,k) = sh_xx(i,j) enddo ; enddo endif @@ -651,17 +677,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! even with OBCs if the accelerations are zeroed at OBC points, in which ! case the j-loop for h_u could collapse to j=js=1,je+1. -RWH if (CS%use_land_mask) then - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + do j=js-2,je+2 ; do I=is-2,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 + do J=js-2,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 else - do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + do j=js-2,je+2 ; do I=is-2,Ieq+1 h_u(I,j) = 0.5 * (h(i,j,k) + h(i+1,j,k)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + do J=js-2,Jeq+1 ; do i=is-2,ie+2 h_v(i,J) = 0.5 * (h(i,j,k) + h(i,j+1,k)) enddo ; enddo endif @@ -671,8 +697,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (apply_OBC) then ; do n=1,OBC%number_of_segments J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB if (OBC%zero_strain .or. OBC%freeslip_strain .or. OBC%computed_strain) then - if (OBC%segment(n)%is_N_or_S .and. (J >= js-2) .and. (J <= Jeq+1)) then - do I=OBC%segment(n)%HI%IsdB,OBC%segment(n)%HI%IedB + if (OBC%segment(n)%is_N_or_S .and. (J >= Js_vort) .and. (J <= Je_vort)) then + do I = max(OBC%segment(n)%HI%IsdB,Is_vort), min(OBC%segment(n)%HI%IedB,Ie_vort) if (OBC%zero_strain) then dvdx(I,J) = 0. ; dudy(I,J) = 0. elseif (OBC%freeslip_strain) then @@ -692,9 +718,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, dudy(I,J) = CS%DX_dyBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdxCu(I,j+1)*G%dxBu(I,J) endif endif + if (CS%use_Leithy) then + dvdx_smooth(I,J) = dvdx(I,J) + dudy_smooth(I,J) = dudy(I,J) + endif enddo - elseif (OBC%segment(n)%is_E_or_W .and. (I >= is-2) .and. (I <= Ieq+1)) then - do J=OBC%segment(n)%HI%JsdB,OBC%segment(n)%HI%JedB + elseif (OBC%segment(n)%is_E_or_W .and. (I >= is_vort) .and. (I <= ie_vort)) then + do J = max(OBC%segment(n)%HI%JsdB,js_vort), min(OBC%segment(n)%HI%JedB,je_vort) if (OBC%zero_strain) then dvdx(I,J) = 0. ; dudy(I,J) = 0. elseif (OBC%freeslip_strain) then @@ -714,6 +744,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, dvdx(I,J) = CS%DY_dxBu(I,J)*OBC%segment(n)%tangential_grad(I,J,k)*G%IdyCv(i+1,J)*G%dxBu(I,J) endif endif + if (CS%use_Leithy) then + dvdx_smooth(I,J) = dvdx(I,J) + dudy_smooth(I,J) = dudy(I,J) + endif enddo endif endif @@ -723,25 +757,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! OBC projections, but they might not be necessary if the accelerations ! are always zeroed out at OBC points, in which case the i-loop below ! becomes do i=is-1,ie+1. -RWH - if ((J >= Jsq-1) .and. (J <= Jeq+1)) then + if ((J >= js-2) .and. (J <= Jeq+1)) then do i = max(is-2,OBC%segment(n)%HI%isd), min(ie+2,OBC%segment(n)%HI%ied) h_v(i,J) = h(i,j,k) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then - if ((J >= Jsq-1) .and. (J <= Jeq+1)) then + if ((J >= js-2) .and. (J <= Jeq+1)) then do i = max(is-2,OBC%segment(n)%HI%isd), min(ie+2,OBC%segment(n)%HI%ied) h_v(i,J) = h(i,j+1,k) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then - if ((I >= Isq-1) .and. (I <= Ieq+1)) then + if ((I >= is-2) .and. (I <= Ieq+1)) then do j = max(js-2,OBC%segment(n)%HI%jsd), min(je+2,OBC%segment(n)%HI%jed) h_u(I,j) = h(i,j,k) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then - if ((I >= Isq-1) .and. (I <= Ieq+1)) then + if ((I >= is-2) .and. (I <= Ieq+1)) then do j = max(js-2,OBC%segment(n)%HI%jsd), min(je+2,OBC%segment(n)%HI%jed) h_u(I,j) = h(i+1,j,k) enddo @@ -753,25 +787,25 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, J = OBC%segment(n)%HI%JsdB ; I = OBC%segment(n)%HI%IsdB if (OBC%segment(n)%direction == OBC_DIRECTION_N) then if ((J >= js-2) .and. (J <= je)) then - do I = max(Isq-1,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) + do I = max(is-2,OBC%segment(n)%HI%IsdB), min(Ieq+1,OBC%segment(n)%HI%IedB) h_u(I,j+1) = h_u(I,j) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_S) then if ((J >= js-1) .and. (J <= je+1)) then - do I = max(Isq-1,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) + do I = max(is-2,OBC%segment(n)%HI%isd), min(Ieq+1,OBC%segment(n)%HI%ied) h_u(I,j) = h_u(I,j+1) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_E) then if ((I >= is-2) .and. (I <= ie)) then - do J = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) + do J = max(js-2,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) h_v(i+1,J) = h_v(i,J) enddo endif elseif (OBC%segment(n)%direction == OBC_DIRECTION_W) then if ((I >= is-1) .and. (I <= ie+1)) then - do J = max(Jsq-1,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) + do J = max(js-2,OBC%segment(n)%HI%jsd), min(Jeq+1,OBC%segment(n)%HI%jed) h_v(i,J) = h_v(i+1,J) enddo endif @@ -796,11 +830,11 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Shearing strain (including no-slip boundary conditions at the 2-D land-sea mask). ! dudy_smooth and dvdx_smooth do not (yet) include modifications at OBCs from above. if (CS%no_slip) then - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq sh_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) enddo ; enddo else - do J=js-2,Jeq+1 ; do I=is-2,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq sh_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) + dudy_smooth(I,J) ) enddo ; enddo endif @@ -833,55 +867,53 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! Vorticity - if (CS%no_slip) then - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 - vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) - enddo ; enddo - else - 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) ) - enddo ; enddo + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy) .or. (CS%id_vort_xy_q>0)) then + if (CS%no_slip) then + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + else + do J=js_vort,je_vort ; do I=is_vort,ie_vort + vort_xy(I,J) = G%mask2dBu(I,J) * ( dvdx(I,J) - dudy(I,J) ) + enddo ; enddo + endif endif if (CS%use_Leithy) then if (CS%no_slip) then - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh vort_xy_smooth(I,J) = (2.0-G%mask2dBu(I,J)) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) enddo ; enddo else - do J=Jsq-2,Jeq+2 ; do I=Isq-2,Ieq+2 + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh vort_xy_smooth(I,J) = G%mask2dBu(I,J) * ( dvdx_smooth(I,J) - dudy_smooth(I,J) ) enddo ; enddo endif endif - ! Divergence - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 - div_xx(i,j) = dudx(i,j) + dvdy(i,j) - enddo ; enddo if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then ! Vorticity gradient - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js-2,je_Kh ; do i=is_Kh-1,ie_Kh+1 DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) vort_xy_dx(i,J) = DY_dxBu * (vort_xy(I,J) * G%IdyCu(I,j) - vort_xy(I-1,J) * G%IdyCu(I-1,j)) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + do j=js_Kh-1,je_Kh+1 ; do I=is-2,ie_Kh DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) vort_xy_dy(I,j) = DX_dyBu * (vort_xy(I,J) * G%IdxCv(i,J) - vort_xy(I,J-1) * G%IdxCv(i,J-1)) enddo ; enddo if (CS%use_Leithy) then ! Gradient of smoothed vorticity - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js_Kh-1,je_Kh ; do i=is_Kh,ie_Kh DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) vort_xy_dx_smooth(i,J) = DY_dxBu * & (vort_xy_smooth(I,J) * G%IdyCu(I,j) - vort_xy_smooth(I-1,J) * G%IdyCu(I-1,j)) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + do j=js_Kh,je_Kh ; do I=is_Kh-1,ie_Kh DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) vort_xy_dy_smooth(I,j) = DX_dyBu * & (vort_xy_smooth(I,J) * G%IdxCv(i,J) - vort_xy_smooth(I,J-1) * G%IdxCv(i,J-1)) @@ -889,46 +921,53 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! If Leithy ! Laplacian of vorticity - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + ! if (CS%Leith_Ah .or. CS%use_Leithy) then + do J=js_Kh-1,je_Kh ; do I=is_Kh-1,ie_Kh DY_dxBu = G%dyBu(I,J) * G%IdxBu(I,J) DX_dyBu = G%dxBu(I,J) * G%IdyBu(I,J) Del2vort_q(I,J) = DY_dxBu * (vort_xy_dx(i+1,J) * G%IdyCv(i+1,J) - vort_xy_dx(i,J) * G%IdyCv(i,J)) + & DX_dyBu * (vort_xy_dy(I,j+1) * G%IdyCu(I,j+1) - vort_xy_dy(I,j) * G%IdyCu(I,j)) enddo ; enddo + ! endif if (CS%modified_Leith) then + ! Divergence + do j=js_Kh-1,je_Kh+1 ; do i=is_Kh-1,ie_Kh+1 + div_xx(i,j) = dudx(i,j) + dvdy(i,j) + enddo ; enddo + ! Divergence gradient - do j=Jsq-1,Jeq+2 ; do I=Isq-1,Ieq+1 + do j=js-1,je+1 ; do I=is_Kh-1,ie_Kh div_xx_dx(I,j) = G%IdxCu(I,j)*(div_xx(i+1,j) - div_xx(i,j)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js_Kh-1,je_Kh ; do i=is-1,ie+1 div_xx_dy(i,J) = G%IdyCv(i,J)*(div_xx(i,j+1) - div_xx(i,j)) enddo ; enddo ! Magnitude of divergence gradient - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_div_mag_h(i,j) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I-1,j)))**2 + & (0.5*(div_xx_dy(i,J) + div_xx_dy(i,J-1)))**2) enddo ; enddo - do j=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq grad_div_mag_q(I,J) = sqrt((0.5*(div_xx_dx(I,j) + div_xx_dx(I,j+1)))**2 + & (0.5*(div_xx_dy(i,J) + div_xx_dy(i+1,J)))**2) enddo ; enddo else - do j=Jsq-1,Jeq+2 ; do I=is-2,Ieq+1 + do j=js-1,je+1 ; do I=is_Kh-1,ie_Kh div_xx_dx(I,j) = 0.0 enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=Isq-1,Ieq+2 + do J=js_Kh-1,je_Kh ; do i=is-1,ie+1 div_xx_dy(i,J) = 0.0 enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_div_mag_h(i,j) = 0.0 enddo ; enddo - do J=Jsq-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do J=js-1,Jeq ; do I=is-1,Ieq grad_div_mag_q(I,J) = 0.0 enddo ; enddo @@ -936,17 +975,17 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Add in beta for the Leith viscosity if (CS%use_beta_in_Leith) then - do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+1 ; do i=is-1,ie+1 vort_xy_dx(i,J) = vort_xy_dx(i,J) + 0.5 * ( G%dF_dx(i,j) + G%dF_dx(i,j+1)) enddo ; enddo - do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 + do j=js-1,je+1 ; do I=is-2,Ieq+1 vort_xy_dy(I,j) = vort_xy_dy(I,j) + 0.5 * ( G%dF_dy(i,j) + G%dF_dy(i+1,j)) enddo ; enddo endif ! CS%use_beta_in_Leith if (CS%use_QG_Leith_visc) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_vort_mag_h_2d(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + & (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 ) enddo ; enddo @@ -961,7 +1000,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_vort_mag_h(i,j) = SQRT((0.5*(vort_xy_dx(i,J) + vort_xy_dx(i,J-1)))**2 + & (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I-1,j)))**2 ) enddo ; enddo @@ -971,7 +1010,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo if (CS%use_Leithy) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh vert_vort_mag_smooth(i,j) = SQRT((0.5*(vort_xy_dx_smooth(i,J) + & vort_xy_dx_smooth(i,J-1)))**2 + & (0.5*(vort_xy_dy_smooth(I,j) + & @@ -982,7 +1021,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif ! CS%Leith_Kh if ((CS%Smagorinsky_Kh) .or. (CS%Smagorinsky_Ah)) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh sh_xx_sq = sh_xx(i,j)**2 sh_xy_sq = 0.25 * ( (sh_xy(I-1,J-1)**2 + sh_xy(I,J)**2) & + (sh_xy(I-1,J)**2 + sh_xy(I,J-1)**2) ) @@ -991,13 +1030,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%better_bound_Ah .or. CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh h_min = min(h_u(I,j), h_u(I-1,j), h_v(i,J), h_v(i,J-1)) hrat_min(i,j) = min(1.0, h_min / (h(i,j,k) + h_neglect)) enddo ; enddo if (CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh visc_bound_rem(i,j) = 1.0 enddo ; enddo endif @@ -1008,28 +1047,28 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! largest value from several parameterizations. Also get ! the Laplacian component of str_xx. - if ((CS%Leith_Kh) .or. (CS%Leith_Ah)) then + if ((CS%Leith_Kh) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%use_QG_Leith_visc) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh grad_vort = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) grad_vort_qg = 3. * grad_vort_mag_h_2d(i,j) vert_vort_mag(i,j) = min(grad_vort, grad_vort_qg) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh vert_vort_mag(i,j) = grad_vort_mag_h(i,j) + grad_div_mag_h(i,j) enddo ; enddo endif endif ! Static (pre-computed) background viscosity - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = CS%Kh_bg_xx(i,j) enddo ; enddo ! NOTE: The following do-block can be decomposed and vectorized after the ! stack size has been reduced. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh if (CS%add_LES_viscosity) then if (CS%Smagorinsky_Kh) & Kh(i,j) = Kh(i,j) + CS%Laplac2_const_xx(i,j) * Shear_mag(i,j) @@ -1046,38 +1085,38 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! All viscosity contributions above are subject to resolution scaling if (rescale_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = VarMix%Res_fn_h(i,j) * Kh(i,j) enddo ; enddo endif if (legacy_bound) then ! Older method of bounding for stability - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = min(Kh(i,j), CS%Kh_Max_xx(i,j)) enddo ; enddo endif ! Place a floor on the viscosity, if desired. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = max(Kh(i,j), CS%Kh_bg_min) enddo ; enddo if (use_MEKE_Ku) then ! *Add* the MEKE contribution (which might be negative) if (CS%res_scale_MEKE) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) * VarMix%Res_fn_h(i,j) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = Kh(i,j) + MEKE%Ku(i,j) enddo ; enddo endif endif if (CS%anisotropic) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh ! *Add* the tension component of anisotropic viscosity Kh(i,j) = Kh(i,j) + CS%Kh_aniso * (1. - CS%n1n2_h(i,j)**2) enddo ; enddo @@ -1085,7 +1124,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Newer method of bounding for stability if (CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh if (Kh(i,j) >= hrat_min(i,j) * CS%Kh_Max_xx(i,j)) then visc_bound_rem(i,j) = 0.0 Kh(i,j) = hrat_min(i,j) * CS%Kh_Max_xx(i,j) @@ -1098,19 +1137,19 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! In Leith+E parameterization Kh is computed after Ah in the biharmonic loop. ! The harmonic component of str_xx is added in the biharmonic loop. if (CS%use_Leithy) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh(i,j) = 0. enddo ; enddo - end if + endif if (CS%id_Kh_h>0 .or. CS%debug) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Kh_h(i,j,k) = Kh(i,j) enddo ; enddo endif if (CS%id_grid_Re_Kh>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js,je ; do i=is,ie KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) grid_Kh = max(Kh(i,j), CS%min_grid_Kh) grid_Re_Kh(i,j,k) = (sqrt(KE) * sqrt(CS%grid_sp_h2(i,j))) / grid_Kh @@ -1118,13 +1157,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%id_div_xx_h>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - div_xx_h(i,j,k) = div_xx(i,j) + do j=js,je ; do i=is,ie + div_xx_h(i,j,k) = dudx(i,j) + dvdy(i,j) enddo ; enddo endif if (CS%id_sh_xx_h>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js,je ; do i=is,ie sh_xx_h(i,j,k) = sh_xx(i,j) enddo ; enddo endif @@ -1151,21 +1190,21 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Determine the biharmonic viscosity at h points, using the ! largest value from several parameterizations. Also get the ! biharmonic component of str_xx. - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = CS%Ah_bg_xx(i,j) enddo ; enddo if ((CS%Smagorinsky_Ah) .or. (CS%Leith_Ah) .or. (CS%use_Leithy)) then if (CS%Smagorinsky_Ah) then if (CS%bound_Coriolis) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh AhSm = Shear_mag(i,j) * (CS%Biharm_const_xx(i,j) & + CS%Biharm_const2_xx(i,j) * Shear_mag(i,j) & ) Ah(i,j) = max(Ah(i,j), AhSm) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh AhSm = CS%Biharm_const_xx(i,j) * Shear_mag(i,j) Ah(i,j) = max(Ah(i,j), AhSm) enddo ; enddo @@ -1173,7 +1212,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif if (CS%Leith_Ah) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) AhLth = CS%Biharm6_const_xx(i,j) * abs(Del2vort_h) * inv_PI6 @@ -1183,7 +1222,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_Leithy) then ! Get m_leithy - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if (CS%smooth_Ah) m_leithy(:,:) = 0.0 ! This is here to initialize domain edge halo values. + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) AhLth = CS%Biharm6_const_xx(i,j) * inv_PI6 * abs(Del2vort_h) @@ -1197,30 +1237,44 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, endif endif enddo ; enddo - ! Smooth m_leithy - call smooth_x9(CS, G, field_h=m_leithy, zero_land=.true.) + + if (CS%smooth_Ah) then + ! Smooth m_leithy. A single call smoothes twice. + call pass_var(m_leithy, G%Domain, halo=2) + call smooth_x9_h(G, m_leithy, zero_land=.true.) + call pass_var(m_leithy, G%Domain) + endif ! Get Ah - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Del2vort_h = 0.25 * ((Del2vort_q(I,J) + Del2vort_q(I-1,J-1)) + & (Del2vort_q(I-1,J) + Del2vort_q(I,J-1))) AhLthy = CS%Biharm6_const_xx(i,j) * inv_PI6 * & sqrt(max(0.,Del2vort_h**2 - m_leithy(i,j)*vert_vort_mag_smooth(i,j)**2)) Ah(i,j) = max(CS%Ah_bg_xx(i,j), AhLthy) enddo ; enddo - ! Smooth Ah before applying upper bound - ! square, then smooth, then square root - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Ah_h(i,j,k) = Ah(i,j)**2 - enddo ; enddo - call smooth_x9(CS, G, field_h=Ah_h(:,:,k)) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Ah_h(i,j,k) = sqrt(Ah_h(i,j,k)) - Ah(i,j) = Ah_h(i,j,k) - enddo ; enddo + if (CS%smooth_Ah) then + ! Smooth Ah before applying upper bound. Square Ah, then smooth, then take its square root. + Ah_sq(:,:) = 0.0 ! This is here to initialize domain edge halo values. + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Ah_sq(i,j) = Ah(i,j)**2 + enddo ; enddo + call pass_var(Ah_sq, G%Domain, halo=2) + ! A single call smoothes twice. + call smooth_x9_h(G, Ah_sq, zero_land=.false.) + call pass_var(Ah_sq, G%Domain) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Ah_h(i,j,k) = max(CS%Ah_bg_xx(i,j), sqrt(max(0., Ah_sq(i,j)))) + Ah(i,j) = Ah_h(i,j,k) + enddo ; enddo + else + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Ah_h(i,j,k) = Ah(i,j) + enddo ; enddo + endif endif if (CS%bound_Ah .and. .not. CS%better_bound_Ah) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = min(Ah(i,j), CS%Ah_Max_xx(i,j)) enddo ; enddo endif @@ -1228,13 +1282,13 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (use_MEKE_Au) then ! *Add* the MEKE contribution - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = Ah(i,j) + MEKE%Au(i,j) enddo ; enddo endif if (CS%Re_Ah > 0.0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh KE = 0.125*((u(I,j,k)+u(I-1,j,k))**2 + (v(i,J,k)+v(i,J-1,k))**2) Ah(i,j) = sqrt(KE) * CS%Re_Ah_const_xx(i,j) enddo ; enddo @@ -1242,18 +1296,18 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%better_bound_Ah) then if (CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = min(Ah(i,j), visc_bound_rem(i,j) * hrat_min(i,j) * CS%Ah_Max_xx(i,j)) enddo ; enddo else - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah(i,j) = min(Ah(i,j), hrat_min(i,j) * CS%Ah_Max_xx(i,j)) enddo ; enddo endif endif - if ((CS%id_Ah_h>0) .or. CS%debug) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + if ((CS%id_Ah_h>0) .or. CS%debug .or. CS%use_Leithy) then + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh Ah_h(i,j,k) = Ah(i,j) enddo ; enddo endif @@ -1261,14 +1315,14 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, if (CS%use_Leithy) then ! Compute Leith+E Kh after bounds have been applied to Ah ! and after it has been smoothed. Kh = -m_leithy * Ah - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - Kh(i,j) = -m_leithy(i,j) * Ah(i,j) - Kh_h(i,j,k) = Kh(i,j) + do j=js_Kh,je_Kh ; do i=is_Kh,ie_Kh + Kh(i,j) = -m_leithy(i,j) * Ah(i,j) + Kh_h(i,j,k) = Kh(i,j) enddo ; enddo endif if (CS%id_grid_Re_Ah>0) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js,je ; do i=is,ie KE = 0.125 * ((u(I,j,k) + u(I-1,j,k))**2 + (v(i,J,k) + v(i,J-1,k))**2) grid_Ah = max(Ah(i,j), CS%min_grid_Ah) grid_Re_Ah(i,j,k) = (sqrt(KE) * CS%grid_sp_h3(i,j)) / grid_Ah @@ -1462,7 +1516,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Leith+E doesn't recompute Kh at q points, it just interpolates it from h to q points if (CS%use_Leithy) then - Kh(I,J) = Kh_h(i+1,j+1,k) + Kh(I,J) = 0.25 * ((Kh_h(i,j,k) + Kh_h(i+1,j+1,k)) + (Kh_h(i,j+1,k) + Kh_h(i+1,j,k))) end if if (CS%id_Kh_q>0 .or. CS%debug) & @@ -1569,7 +1623,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, ! Leith+E doesn't recompute Ah at q points, it just interpolates it from h to q points if (CS%use_Leithy) then do J=js-1,Jeq ; do I=is-1,Ieq - Ah(I,J) = Ah_h(i+1,j+1,k) + Ah(I,J) = 0.25 * ((Ah_h(i,j,k) + Ah_h(i+1,j+1,k)) + (Ah_h(i,j+1,k) + Ah_h(i+1,j,k))) enddo ; enddo end if @@ -1633,7 +1687,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, else ! .not. use_GME ! This changes the units of str_xx from [L2 T-2 ~> m2 s-2] to [H L2 T-2 ~> m3 s-2 or kg s-2]. - do J=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 str_xx(i,j) = str_xx(i,j) * (h(i,j,k) * CS%reduction_xx(i,j)) enddo ; enddo @@ -2205,7 +2259,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (.not.CS%Laplacian) CS%use_Kh_bg_2d = .false. call get_param(param_file, mdl, "KH_BG_2D_BUG", CS%Kh_bg_2d_bug, & "If true, retain an answer-changing horizontal indexing bug in setting "//& - "the corner-point viscosities when USE_KH_BG_2D=True. This is"//& + "the corner-point viscosities when USE_KH_BG_2D=True. This is "//& "not recommended.", default=.false., do_not_log=.not.CS%use_Kh_bg_2d) call get_param(param_file, mdl, "USE_GME", CS%use_GME, & @@ -2215,13 +2269,17 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) "Use the split time stepping if true.", default=.true., do_not_log=.true.) if (CS%use_Leithy) then if (.not.(CS%biharmonic .and. CS%Laplacian)) then - call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& + call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init: "//& "LAPLACIAN and BIHARMONIC must both be True when USE_LEITHY=True.") endif - call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, & - "Fraction of biharmonic dissipation that gets backscattered, "//& - "in Leith+E.", units="nondim", default=1.0) endif + call get_param(param_file, mdl, "LEITHY_CK", CS%c_K, & + "Fraction of biharmonic dissipation that gets backscattered, "//& + "in Leith+E.", units="nondim", default=1.0, do_not_log=.not.CS%use_Leithy) + call get_param(param_file, mdl, "SMOOTH_AH", CS%smooth_Ah, & + "If true, Ah and m_leithy are smoothed within Leith+E. This requires "//& + "lots of blocking communications, which can be expensive", & + default=.true., do_not_log=.not.CS%use_Leithy) if (CS%use_GME .and. .not.split) call MOM_error(FATAL,"ERROR: Currently, USE_GME = True "// & "cannot be used with SPLIT=False.") @@ -2358,7 +2416,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%dx2q(I,J) = G%dxBu(I,J)*G%dxBu(I,J) ; CS%dy2q(I,J) = G%dyBu(I,J)*G%dyBu(I,J) CS%DX_dyBu(I,J) = G%dxBu(I,J)*G%IdyBu(I,J) ; CS%DY_dxBu(I,J) = G%dyBu(I,J)*G%IdxBu(I,J) enddo ; enddo - do j=Jsq-1,Jeq+2 ; do i=Isq-1,Ieq+2 + do j=js-2,Jeq+2 ; do i=is-2,Ieq+2 CS%dx2h(i,j) = G%dxT(i,j)*G%dxT(i,j) ; CS%dy2h(i,j) = G%dyT(i,j)*G%dyT(i,j) CS%DX_dyT(i,j) = G%dxT(i,j)*G%IdyT(i,j) ; CS%DY_dxT(i,j) = G%dyT(i,j)*G%IdxT(i,j) enddo ; enddo @@ -2399,7 +2457,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! Calculate and store the background viscosity at h-points min_grid_sp_h2 = huge(1.) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 ! Static factors in the Smagorinsky and Leith schemes grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j) + CS%dy2h(i,j)) CS%grid_sp_h2(i,j) = grid_sp_h2 @@ -2458,11 +2516,11 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) enddo ; enddo endif if (CS%biharmonic) then - do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 CS%Idx2dyCu(I,j) = (G%IdxCu(I,j)*G%IdxCu(I,j)) * G%IdyCu(I,j) CS%Idxdy2u(I,j) = G%IdxCu(I,j) * (G%IdyCu(I,j)*G%IdyCu(I,j)) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 CS%Idx2dyCv(i,J) = (G%IdxCv(i,J)*G%IdxCv(i,J)) * G%IdyCv(i,J) CS%Idxdy2v(i,J) = G%IdxCv(i,J) * (G%IdyCv(i,J)*G%IdyCv(i,J)) enddo ; enddo @@ -2474,7 +2532,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) BoundCorConst = 1.0 / (5.0*(bound_Cor_vel*bound_Cor_vel)) min_grid_sp_h4 = huge(1.) - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 grid_sp_h2 = (2.0*CS%dx2h(i,j)*CS%dy2h(i,j)) / (CS%dx2h(i,j)+CS%dy2h(i,j)) grid_sp_h3 = grid_sp_h2*sqrt(grid_sp_h2) CS%grid_sp_h3(i,j) = grid_sp_h3 @@ -2532,7 +2590,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) endif ! The Laplacian bounds should avoid overshoots when CS%bound_coef < 1. if (CS%Laplacian .and. CS%better_bound_Kh) then - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 denom = max( & (CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) * & max(G%IdyCu(I,j)*G%IareaCu(I,j), G%IdyCu(I-1,j)*G%IareaCu(I-1,j)) ), & @@ -2560,7 +2618,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) ! The biharmonic bounds should avoid overshoots when CS%bound_coef < 0.5, but ! empirically work for CS%bound_coef <~ 1.0 if (CS%biharmonic .and. CS%better_bound_Ah) then - do j=js-1,Jeq+1 ; do I=Isq-1,Ieq+1 + do j=js-1,Jeq+1 ; do I=is-2,Ieq+1 u0u(I,j) = (CS%Idxdy2u(I,j)*(CS%dy2h(i+1,j)*CS%DY_dxT(i+1,j)*(G%IdyCu(I+1,j) + G%IdyCu(I,j)) + & CS%dy2h(i,j) * CS%DY_dxT(i,j) * (G%IdyCu(I,j) + G%IdyCu(I-1,j)) ) + & CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & @@ -2570,7 +2628,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Idx2dyCu(I,j)*(CS%dx2q(I,J) * CS%DY_dxBu(I,J) * (G%IdyCv(i+1,J) + G%IdyCv(i,J)) + & CS%dx2q(I,J-1)*CS%DY_dxBu(I,J-1)*(G%IdyCv(i+1,J-1) + G%IdyCv(i,J-1)) ) ) enddo ; enddo - do J=Jsq-1,Jeq+1 ; do i=is-1,Ieq+1 + do J=js-2,Jeq+1 ; do i=is-1,Ieq+1 v0u(i,J) = (CS%Idxdy2v(i,J)*(CS%dy2q(I,J) * CS%DX_dyBu(I,J) * (G%IdxCu(I,j+1) + G%IdxCu(I,j)) + & CS%dy2q(I-1,J)*CS%DX_dyBu(I-1,J)*(G%IdxCu(I-1,j+1) + G%IdxCu(I-1,j)) ) + & CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DY_dxT(i,j+1)*(G%IdyCu(I,j+1) + G%IdyCu(I-1,j+1)) + & @@ -2580,7 +2638,7 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) CS%Idx2dyCv(i,J)*(CS%dx2h(i,j+1)*CS%DX_dyT(i,j+1)*(G%IdxCv(i,J+1) + G%IdxCv(i,J)) + & CS%dx2h(i,j) * CS%DX_dyT(i,j) * (G%IdxCv(i,J) + G%IdxCv(i,J-1)) ) ) enddo ; enddo - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 + do j=js-1,Jeq+1 ; do i=is-1,Ieq+1 denom = max( & (CS%dy2h(i,j) * & (CS%DY_dxT(i,j)*(G%IdyCu(I,j)*u0u(I,j) + G%IdyCu(I-1,j)*u0u(I-1,j)) + & @@ -2859,112 +2917,113 @@ subroutine smooth_GME(CS, G, GME_flux_h, GME_flux_q) enddo ! s-loop end subroutine smooth_GME -!> Apply a 9-point smoothing filter twice to reduce horizontal two-grid-point noise -!! Note that this subroutine does not conserve mass or angular momentum, so don't use it -!! in situations where you need conservation. Also can't apply it to Ah and Kh in the -!! horizontal_viscosity subroutine because they are not supposed to be halo-updated. -!! But you _can_ apply them to Kh_h and Ah_h. -subroutine smooth_x9(CS, G, field_h, field_u, field_v, field_q, zero_land) - type(hor_visc_CS), intent(in) :: CS !< Control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZI_(G),SZJ_(G)), optional, intent(inout) :: field_h !< field to be smoothed - !! at h points - real, dimension(SZIB_(G),SZJ_(G)), optional, intent(inout) :: field_u !< field to be smoothed - !! at u points - real, dimension(SZI_(G),SZJB_(G)), optional, intent(inout) :: field_v !< field to be smoothed - !! at v points - real, dimension(SZIB_(G),SZJB_(G)), optional, intent(inout) :: field_q !< field to be smoothed - !! at q points - logical, optional, intent(in) :: zero_land !< An optional argument - !! indicating whether to set values - !! on land to zero (.true.) or - !! whether to ignore land values - !! (.false. or not present) - ! local variables. It would be good to make the _original variables allocatable. - real, dimension(SZI_(G),SZJ_(G)) :: field_h_original - real, dimension(SZIB_(G),SZJ_(G)) :: field_u_original - real, dimension(SZI_(G),SZJB_(G)) :: field_v_original - real, dimension(SZIB_(G),SZJB_(G)) :: field_q_original - real, dimension(3,3) :: weights, local_weights ! averaging weights for smoothing, nondimensional - logical :: zero_land_val ! actual value of zero_land optional argument - integer :: i, j, s - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq +!> Apply a 9-point smoothing filter twice to a field staggered at a thickness point to reduce +!! horizontal two-grid-point noise. +!! Note that this subroutine does not conserve mass, so don't use it in situations where you +!! need conservation. Also note that it assumes that the input field has valid values in the +!! first two halo points upon entry. +subroutine smooth_x9_h(G, field_h, zero_land) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: field_h !< h-point field to be smoothed [arbitrary] + logical, optional, intent(in) :: zero_land !< If present and false, return the average + !! of the surrounding ocean points when + !! smoothing, otherwise use a value of 0 for + !! land points and include them in the averages. + ! Local variables + real :: fh_prev(SZI_(G),SZJ_(G)) ! The value of the h-point field at the previous iteration [arbitrary] + real :: Iwts ! The inverse of the sum of the weights [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, s, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec - Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB - weights = reshape([1., 2., 1., 2., 4., 2., 1., 2., 1.],shape(weights))/16. + zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land + + do s=1,0,-1 + fh_prev(:,:) = field_h(:,:) + ! apply smoothing on field_h using rotationally symmetric expressions. + do j=js-s,je+s ; do i=is-s,ie+s ; if (G%mask2dT(i,j) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dT(i,j) + & + ( 2.0*((G%mask2dT(i-1,j) + G%mask2dT(i+1,j)) + & + (G%mask2dT(i,j-1) + G%mask2dT(i,j+1))) + & + ((G%mask2dT(i-1,j-1) + G%mask2dT(i+1,j+1)) + & + (G%mask2dT(i-1,j+1) + G%mask2dT(i+1,j-1))) ) ) + 1.0e-16 ) + field_h(i,j) = Iwts * ( 4.0*G%mask2dT(i,j) * fh_prev(i,j) & + + (2.0*((G%mask2dT(i-1,j) * fh_prev(i-1,j) + G%mask2dT(i+1,j) * fh_prev(i+1,j)) + & + (G%mask2dT(i,j-1) * fh_prev(i,j-1) + G%mask2dT(i,j+1) * fh_prev(i,j+1))) & + + ((G%mask2dT(i-1,j-1) * fh_prev(i-1,j-1) + G%mask2dT(i+1,j+1) * fh_prev(i+1,j+1)) + & + (G%mask2dT(i-1,j+1) * fh_prev(i-1,j+1) + G%mask2dT(i+1,j-1) * fh_prev(i-1,j-1))) )) + endif ; enddo ; enddo + enddo + +end subroutine smooth_x9_h + +!> Apply a 9-point smoothing filter twice to a pair of velocity components to reduce +!! horizontal two-grid-point noise. +!! Note that this subroutine does not conserve angular momentum, so don't use it +!! in situations where you need conservation. Also note that it assumes that the +!! input fields have valid values in the first two halo points upon entry. +subroutine smooth_x9_uv(G, field_u, field_v, zero_land) + type(ocean_grid_type), intent(in) :: G !< Ocean grid + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed[arbitrary] + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: field_v !< v-point field to be smoothed [arbitrary] + logical, optional, intent(in) :: zero_land !< If present and false, return the average + !! of the surrounding ocean points when + !! smoothing, otherwise use a value of 0 for + !! land points and include them in the averages. + + ! Local variables. + real :: fu_prev(SZIB_(G),SZJ_(G)) ! The value of the u-point field at the previous iteration [arbitrary] + real :: fv_prev(SZI_(G),SZJB_(G)) ! The value of the v-point field at the previous iteration [arbitrary] + real :: Iwts ! The inverse of the sum of the weights [nondim] + logical :: zero_land_val ! The value of the zero_land optional argument or .true. if it is absent. + integer :: i, j, s, is, ie, js, je, Isq, Ieq, Jsq, Jeq - if (present(zero_land)) then - zero_land_val = zero_land - else - zero_land_val = .false. - endif - - if (present(field_h)) then - call pass_var(field_h, G%Domain, halo=2) ! Halo size 2 ensures that you can smooth twice - do s=1,0,-1 - field_h_original(:,:) = field_h(:,:) - ! apply smoothing on field_h - do j=js-s,je+s ; do i=is-s,ie+s - ! skip land points - if (G%mask2dT(i,j)==0.) cycle - ! compute local weights - local_weights = weights*G%mask2dT(i-1:i+1,j-1:j+1) - if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) - field_h(i,j) = sum(local_weights*field_h_original(i-1:i+1,j-1:j+1)) - enddo ; enddo - enddo - call pass_var(field_h, G%Domain) - endif - - if (present(field_u)) then - call pass_vector(field_u, field_v, G%Domain, halo=2) - do s=1,0,-1 - field_u_original(:,:) = field_u(:,:) - ! apply smoothing on field_u - do j=js-s,je+s ; do I=Isq-s,Ieq+s - ! skip land points - if (G%mask2dCu(I,j)==0.) cycle - ! compute local weights - local_weights = weights*G%mask2dCu(I-1:I+1,j-1:j+1) - if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) - field_u(I,j) = sum(local_weights*field_u_original(I-1:I+1,j-1:j+1)) - enddo ; enddo - - field_v_original(:,:) = field_v(:,:) - ! apply smoothing on field_v - do J=Jsq-s,Jeq+s ; do i=is-s,ie+s - ! skip land points - if (G%mask2dCv(i,J)==0.) cycle - ! compute local weights - local_weights = weights*G%mask2dCv(i-1:i+1,J-1:J+1) - if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) - field_v(i,J) = sum(local_weights*field_v_original(i-1:i+1,J-1:J+1)) - enddo ; enddo - enddo - call pass_vector(field_u, field_v, G%Domain) - endif - - if (present(field_q)) then - call pass_var(field_q, G%Domain, halo=2, position=CORNER) - do s=1,0,-1 - field_q_original(:,:) = field_q(:,:) - ! apply smoothing on field_q - do J=Jsq-s,Jeq+s ; do I=Isq-s,Ieq+s - ! skip land points - if (G%mask2dBu(I,J)==0.) cycle - ! compute local weights - local_weights = weights*G%mask2dBu(I-1:I+1,J-1:J+1) - if (zero_land_val) local_weights = local_weights/(sum(local_weights) + 1.E-16) - field_q(I,J) = sum(local_weights*field_q_original(I-1:I+1,J-1:J+1)) - enddo ; enddo - enddo - call pass_var(field_q, G%Domain, position=CORNER) - endif + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + Isq = G%IscB ; Ieq = G%IecB ; Jsq = G%JscB ; Jeq = G%JecB -end subroutine smooth_x9 + zero_land_val = .true. ; if (present(zero_land)) zero_land_val = zero_land + + do s=1,0,-1 + fu_prev(:,:) = field_u(:,:) + ! apply smoothing on field_u using the original non-rotationally symmetric expressions. + do j=js-s,je+s ; do I=Isq-s,Ieq+s ; if (G%mask2dCu(I,j) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCu(I,j) + & + ( 2.0*((G%mask2dCu(I-1,j) + G%mask2dCu(I+1,j)) + & + (G%mask2dCu(I,j-1) + G%mask2dCu(I,j+1))) + & + ((G%mask2dCu(I-1,j-1) + G%mask2dCu(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) + G%mask2dCu(I+1,j-1))) ) ) + 1.0e-16 ) + field_u(I,j) = Iwts * ( 4.0*G%mask2dCu(I,j) * fu_prev(I,j) & + + (2.0*((G%mask2dCu(I-1,j) * fu_prev(I-1,j) + G%mask2dCu(I+1,j) * fu_prev(I+1,j)) + & + (G%mask2dCu(I,j-1) * fu_prev(I,j-1) + G%mask2dCu(I,j+1) * fu_prev(I,j+1))) & + + ((G%mask2dCu(I-1,j-1) * fu_prev(I-1,j-1) + G%mask2dCu(I+1,j+1) * fu_prev(I+1,j+1)) + & + (G%mask2dCu(I-1,j+1) * fu_prev(I-1,j+1) + G%mask2dCu(I+1,j-1) * fu_prev(I-1,j-1))) )) + endif ; enddo ; enddo + + fv_prev(:,:) = field_v(:,:) + ! apply smoothing on field_v using the original non-rotationally symmetric expressions. + do J=Jsq-s,Jeq+s ; do i=is-s,ie+s ; if (G%mask2dCv(i,J) > 0.0) then + Iwts = 0.0625 + if (.not. zero_land_val) & + Iwts = 1.0 / ( (4.0*G%mask2dCv(i,J) + & + ( 2.0*((G%mask2dCv(i-1,J) + G%mask2dCv(i+1,J)) + & + (G%mask2dCv(i,J-1) + G%mask2dCv(i,J+1))) + & + ((G%mask2dCv(i-1,J-1) + G%mask2dCv(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) + G%mask2dCv(i+1,J-1))) ) ) + 1.0e-16 ) + field_v(i,J) = Iwts * ( 4.0*G%mask2dCv(i,J) * fv_prev(i,J) & + + (2.0*((G%mask2dCv(i-1,J) * fv_prev(i-1,J) + G%mask2dCv(i+1,J) * fv_prev(i+1,J)) + & + (G%mask2dCv(i,J-1) * fv_prev(i,J-1) + G%mask2dCv(i,J+1) * fv_prev(i,J+1))) & + + ((G%mask2dCv(i-1,J-1) * fv_prev(i-1,J-1) + G%mask2dCv(i+1,J+1) * fv_prev(i+1,J+1)) + & + (G%mask2dCv(i-1,J+1) * fv_prev(i-1,J+1) + G%mask2dCv(i+1,J-1) * fv_prev(i-1,J-1))) )) + endif ; enddo ; enddo + enddo + +end subroutine smooth_x9_uv !> Deallocates any variables allocated in hor_visc_init. subroutine hor_visc_end(CS) From c37a2f0d051ba6a5e83a828828c7fa90f0446e88 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Jan 2024 21:21:55 -0500 Subject: [PATCH 536/629] Document core and linear EOS variable units Modified comments to document the units of 17 variables in 5 files in the core directory and another 5 variables in MOM_EOS_linear.F90. Only comments are changed and all answers are bitwise identical. --- src/core/MOM.F90 | 6 +++--- src/core/MOM_check_scaling.F90 | 2 +- src/core/MOM_forcing_type.F90 | 25 +++++++++++++----------- src/core/MOM_isopycnal_slopes.F90 | 5 ++++- src/core/MOM_verticalGrid.F90 | 16 ++++++++++----- src/equation_of_state/MOM_EOS_linear.F90 | 6 +++--- 6 files changed, 36 insertions(+), 24 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2800011ccf..1922e87926 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -263,7 +263,7 @@ module MOM type(MOM_stoch_eos_CS) :: stoch_eos_CS !< structure containing random pattern for stoch EOS logical :: alternate_first_direction !< If true, alternate whether the x- or y-direction !! updates occur first in directionally split parts of the calculation. - real :: first_dir_restart = -1.0 !< A real copy of G%first_direction for use in restart files + real :: first_dir_restart = -1.0 !< A real copy of G%first_direction for use in restart files [nondim] logical :: offline_tracer_mode = .false. !< If true, step_offline() is called instead of step_MOM(). !! This is intended for running MOM6 in offline tracer mode @@ -1205,7 +1205,7 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & endif !OBC segment data update for some fields can be less frequent than others - if(associated(CS%OBC)) then + if (associated(CS%OBC)) then CS%OBC%update_OBC_seg_data = .false. if (CS%dt_obc_seg_period == 0.0) CS%OBC%update_OBC_seg_data = .true. if (CS%dt_obc_seg_period > 0.0) then @@ -2079,7 +2079,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & real :: Hmix_z, Hmix_UV_z ! Temporary variables with averaging depths [Z ~> m] real :: HFrz_z ! Temporary variable with the melt potential depth [Z ~> m] - real :: default_val ! default value for a parameter + real :: default_val ! The default value for DTBT_RESET_PERIOD [s] logical :: write_geom_files ! If true, write out the grid geometry files. logical :: new_sim ! If true, this has been determined to be a new simulation logical :: use_geothermal ! If true, apply geothermal heating. diff --git a/src/core/MOM_check_scaling.F90 b/src/core/MOM_check_scaling.F90 index 1d7c27b6fd..2841514924 100644 --- a/src/core/MOM_check_scaling.F90 +++ b/src/core/MOM_check_scaling.F90 @@ -29,7 +29,7 @@ subroutine check_MOM6_scaling_factors(GV, US) ! Local variables integer, parameter :: ndims = 8 ! The number of rescalable dimensional factors. - real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units. + real, dimension(ndims) :: scales ! An array of scaling factors for each of the basic units [various]. integer, dimension(ndims) :: scale_pow2 ! The powers of 2 that give each element of scales. character(len=2), dimension(ndims) :: key integer, allocatable :: weights(:) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index dcbf440292..b2ccdde71f 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -3492,7 +3492,7 @@ end subroutine get_mech_forcing_groups !> Allocates and zeroes-out array. subroutine myAlloc(array, is, ie, js, je, flag) - real, dimension(:,:), pointer :: array !< Array to be allocated + real, dimension(:,:), pointer :: array !< Array to be allocated [arbitrary] integer, intent(in) :: is !< Start i-index integer, intent(in) :: ie !< End i-index integer, intent(in) :: js !< Start j-index @@ -3970,11 +3970,12 @@ end subroutine homogenize_forcing subroutine homogenize_field_t(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: var !< The variable to homogenize - real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] + real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the + !! variable that is reversed in the + !! return value [a A-1 ~> 1] - real :: avg ! Global average of var, in the same units as var + real :: avg ! Global average of var, in the same units as var [A ~> a] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -3987,11 +3988,12 @@ end subroutine homogenize_field_t subroutine homogenize_field_v(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value + !! variable that is reversed in the + !! return value [a A-1 ~> 1] - real :: avg ! Global average of var, in the same units as var + real :: avg ! Global average of var, in the same units as var [A ~> a] integer :: i, j, is, ie, jsB, jeB is = G%isc ; ie = G%iec ; jsB = G%jscB ; jeB = G%jecB @@ -4004,11 +4006,12 @@ end subroutine homogenize_field_v subroutine homogenize_field_u(var, G, tmp_scale) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize + real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: var !< The variable to homogenize [A ~> a] real, optional, intent(in) :: tmp_scale !< A temporary rescaling factor for the - !! variable that is reversed in the return value + !! variable that is reversed in the + !! return value [a A-1 ~> 1] - real :: avg ! Global average of var, in the same units as var + real :: avg ! Global average of var, in the same units as var [A ~> a] integer :: i, j, isB, ieB, js, je isB = G%iscB ; ieB = G%iecB ; js = G%jsc ; je = G%jec diff --git a/src/core/MOM_isopycnal_slopes.F90 b/src/core/MOM_isopycnal_slopes.F90 index 5aa78cb87a..9defa597ab 100644 --- a/src/core/MOM_isopycnal_slopes.F90 +++ b/src/core/MOM_isopycnal_slopes.F90 @@ -70,7 +70,10 @@ subroutine calc_isoneutral_slopes(G, GV, US, h, e, tv, dt_kappa_smooth, use_stan ! in massless layers filled vertically by diffusion. real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & pres ! The pressure at an interface [R L2 T-2 ~> Pa]. - real, dimension(SZI_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that will be ingored. + real, dimension(SZI_(G)) :: scrap ! An array to pass to calculate_density_second_derivs() that is + ! set there but will be ignored, it is used simultaneously with four different + ! inconsistent units of [R S-1 C-1 ~> kg m-3 degC-1 ppt-1], [R S-2 ~> kg m-3 ppt-2], + ! [T2 S-1 L-2 ~> kg m-3 ppt-1 Pa-1] and [T2 C-1 L-2 ~> kg m-3 degC-1 Pa-1]. real, dimension(SZIB_(G)) :: & drho_dT_u, & ! The derivative of density with temperature at u points [R C-1 ~> kg m-3 degC-1]. drho_dS_u ! The derivative of density with salinity at u points [R S-1 ~> kg m-3 ppt-1]. diff --git a/src/core/MOM_verticalGrid.F90 b/src/core/MOM_verticalGrid.F90 index b0b9fa9fcd..b6cc97d943 100644 --- a/src/core/MOM_verticalGrid.F90 +++ b/src/core/MOM_verticalGrid.F90 @@ -35,8 +35,12 @@ module MOM_verticalGrid character(len=40) :: zAxisUnits !< The units that vertical coordinates are written in character(len=40) :: zAxisLongName !< Coordinate name to appear in files, !! e.g. "Target Potential Density" or "Height" - real, allocatable, dimension(:) :: sLayer !< Coordinate values of layer centers - real, allocatable, dimension(:) :: sInterface !< Coordinate values on interfaces + real, allocatable, dimension(:) :: sLayer !< Coordinate values of layer centers, in unscaled + !! units that depend on the vertical coordinate, such as [kg m-3] for an + !! isopycnal or some hybrid coordinates, [m] for a Z* coordinate, + !! or [nondim] for a sigma coordinate. + real, allocatable, dimension(:) :: sInterface !< Coordinate values on interfaces, in the same + !! unscale units as sLayer [various]. integer :: direction = 1 !< Direction defaults to 1, positive up. ! The following variables give information about the vertical grid. @@ -326,9 +330,11 @@ end function get_tr_flux_units !> This sets the coordinate data for the "layer mode" of the isopycnal model. subroutine setVerticalGridAxes( Rlay, GV, scale ) - type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data - real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density [R ~> kg m-3] - real, intent(in) :: scale !< A unit scaling factor for Rlay + type(verticalGrid_type), intent(inout) :: GV !< The container for vertical grid data + real, dimension(GV%ke), intent(in) :: Rlay !< The layer target density [R ~> kg m-3] + real, intent(in) :: scale !< A unit scaling factor for Rlay to convert + !! it into the units of sInterface, usually + !! [kg m-3 R-1 ~> 1] when used in layer mode. ! Local variables integer :: k, nk diff --git a/src/equation_of_state/MOM_EOS_linear.F90 b/src/equation_of_state/MOM_EOS_linear.F90 index db67040304..8984fbca88 100644 --- a/src/equation_of_state/MOM_EOS_linear.F90 +++ b/src/equation_of_state/MOM_EOS_linear.F90 @@ -167,7 +167,7 @@ elemental subroutine calculate_specvol_derivs_elem_linear(this, T, S, pressure, real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with !! potential temperature [m3 kg-1 degC-1] ! Local variables - real :: I_rho2 + real :: I_rho2 ! The inverse of density squared [m6 kg-2] ! Sv = 1.0 / (Rho_T0_S0 + dRho_dT*T + dRho_dS*S) I_rho2 = 1.0 / (this%Rho_T0_S0 + (this%dRho_dT*T + this%dRho_dS*S))**2 @@ -317,7 +317,7 @@ subroutine int_density_dz_linear(T, S, z_t, z_b, rho_ref, rho_0_pres, G_e, HI, & real :: intz(5) ! The integrals of density with height at the ! 5 sub-column locations [R L2 T-2 ~> Pa] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. + real, parameter :: C1_6 = 1.0/6.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 @@ -488,7 +488,7 @@ subroutine int_spec_vol_dp_linear(T, S, p_t, p_b, alpha_ref, HI, Rho_T0_S0, & real :: intp(5) ! The integrals of specific volume with pressure at the ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. - real, parameter :: C1_6 = 1.0/6.0, C1_90 = 1.0/90.0 ! Rational constants. + real, parameter :: C1_6 = 1.0/6.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 From 0fb905fdc40d15df28a9f3184d7c58f25ee7242c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Jan 2024 07:53:39 -0500 Subject: [PATCH 537/629] +(*)non-Boussinesq ALE_sponges work in Z units Revised the ALE_sponge code to convert the model's thicknesses (in thickness units of [H ~> m or kg m-2]) into layer vertical extents (in height units of [Z ~> m]) to match how the input datasets vertical grids are specified and to avoid using the Boussinesq reference density to do the opposite conversion when in non-Boussinesq mode. The internal conversion in apply_ALE_sponge between layer thicknesses and layer vertical extents matches those in thickness_to_dz, and uses the layer-averaged specific volumes when in non-Boussinesq mode. As a part of these changes, 12 internal variables in MOM_ALE_sponge were renamed (e.g., from data_h to data_dz) to more clearly reflect that they are the layer vertical extents instead of thicknesses, and there are new 3-d variables dz_model, that is created from h when the sponges are applied to the velocities, and data_dz to handle the conversion of the input thicknesses or vertical extents in initialize_ALE_sponge_fixed. This commit includes adding a new thermo_var_type argument to apply_ALE_sponge, a new unit_scale_type argument to rotate_ALE_sponge and initialize_ALE_sponge_varying and the new optional argument data_h_is_Z to initialize_ALE_sponge_fixed to indicate that the in thicknesses arguments are vertical distances (in [Z ~> m]) and do not need to be rescaled inside of the ALE_sponge code, and similarly for the new optional argument data_h_in_Z to get_ALE_sponge_thicknesses. This commit also adds halo size and Omit_Corners arguments to the pass_var calls in the ALE_sponge code. There are new optional arguments to 2 publicly visible routines, and new mandatory arguments to 3 others, but by default the meaning and units of all previous arguments are the same, and answers will be bitwise identical in any Boussinesq cases. However, answers will change in any non-Boussinesq cases that use the ALE_sponges. --- src/core/MOM.F90 | 2 +- .../MOM_state_initialization.F90 | 14 +- .../vertical/MOM_ALE_sponge.F90 | 261 +++++++++++------- .../vertical/MOM_diabatic_driver.F90 | 4 +- 4 files changed, 167 insertions(+), 114 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 1922e87926..9d64b9bf17 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2958,7 +2958,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if (associated(ALE_sponge_in_CSp)) then - call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, GV, turns, param_file) + call rotate_ALE_sponge(ALE_sponge_in_CSp, G_in, CS%ALE_sponge_CSp, G, GV, US, turns, param_file) call update_ALE_sponge_field(CS%ALE_sponge_CSp, T_in, G, GV, CS%T) call update_ALE_sponge_field(CS%ALE_sponge_CSp, S_in, G, GV, CS%S) endif diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 855a6f2aa0..0bd155e8e4 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -2074,9 +2074,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t ! else ! Initialize sponges without supplying sponge grid ! if (sponge_uv) then -! call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, Idamp_u, Idamp_v) +! call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp, Idamp_u, Idamp_v) ! else -! call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) +! call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp) ! endif endif @@ -2118,9 +2118,11 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t endif if (sponge_uv) then - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data, Idamp_u, Idamp_v) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, dz, nz_data, Idamp_u, Idamp_v, & + data_h_is_Z=.true.) else - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, h, nz_data) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, dz, nz_data, & + data_h_is_Z=.true.) endif if (use_temperature) then call set_up_ALE_sponge_field(tmp_T, G, GV, tv%T, ALE_CSp, 'temp', & @@ -2147,9 +2149,9 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t else ! Initialize sponges without supplying sponge grid if (sponge_uv) then - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp, Idamp_u, Idamp_v) + call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp, Idamp_u, Idamp_v) else - call initialize_ALE_sponge(Idamp, G, GV, param_file, ALE_CSp) + call initialize_ALE_sponge(Idamp, G, GV, US, param_file, ALE_CSp) endif ! The remaining calls to set_up_sponge_field can be in any order. if ( use_temperature) then diff --git a/src/parameterizations/vertical/MOM_ALE_sponge.F90 b/src/parameterizations/vertical/MOM_ALE_sponge.F90 index 508362c4cc..0f4b50237e 100644 --- a/src/parameterizations/vertical/MOM_ALE_sponge.F90 +++ b/src/parameterizations/vertical/MOM_ALE_sponge.F90 @@ -16,7 +16,7 @@ module MOM_ALE_sponge use MOM_coms, only : sum_across_PEs use MOM_diag_mediator, only : post_data, query_averaging_enabled, register_diag_field use MOM_diag_mediator, only : diag_ctrl -use MOM_domains, only : pass_var +use MOM_domains, only : pass_var, To_ALL, Omit_Corners use MOM_error_handler, only : MOM_error, FATAL, NOTE, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type @@ -27,6 +27,7 @@ module MOM_ALE_sponge use MOM_spatial_means, only : global_i_mean use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -66,22 +67,22 @@ module MOM_ALE_sponge ! vary with the Boussinesq approximation, the Boussinesq variant is given first. !> A structure for creating arrays of pointers to 3D arrays with extra gridding information -type :: p3d +type :: p3d ; private !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] - real, dimension(:,:,:), pointer :: h => NULL() !< pointer to the data grid [H ~> m or kg m-2] + real, dimension(:,:,:), pointer :: dz => NULL() !< pointer to the data grid spacing [Z ~> m] end type p3d !> A structure for creating arrays of pointers to 2D arrays with extra gridding information -type :: p2d +type :: p2d ; private 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] real, dimension(:,:), pointer :: p => NULL() !< pointer to the data [various] - real, dimension(:,:), pointer :: h => NULL() !< pointer the data grid [H ~> m or kg m-2] + real, dimension(:,:), pointer :: dz => NULL() !< pointer to the data grid spacing [Z ~> m] character(len=:), allocatable :: name !< The name of the input field character(len=:), allocatable :: long_name !< The long name of the input field character(len=:), allocatable :: unit !< The unit of the input field @@ -114,9 +115,9 @@ module MOM_ALE_sponge type(p2d) :: Ref_val_v !< The values to which the v-velocities are damped. type(p3d) :: var_u !< Pointer to the u velocities that are being damped. type(p3d) :: var_v !< Pointer to the v velocities that are being damped. - type(p2d) :: Ref_h !< Grid on which reference data is provided (older code). - type(p2d) :: Ref_hu !< u-point grid on which reference data is provided (older code). - type(p2d) :: Ref_hv !< v-point grid on which reference data is provided (older code). + type(p2d) :: Ref_dz !< Grid on which reference data is provided (older code). + type(p2d) :: Ref_dzu !< u-point grid on which reference data is provided (older code). + type(p2d) :: Ref_dzv !< v-point grid on which reference data is provided (older code). type(diag_ctrl), pointer :: diag !< A structure that is used to regulate the !! timing of diagnostic output. @@ -133,13 +134,13 @@ module MOM_ALE_sponge logical :: time_varying_sponges !< True if using newer sponge code logical :: spongeDataOngrid !< True if the sponge data are on the model horizontal grid - real :: varying_input_h_mask !< An input file thickness below which the target values with time-varying - !! sponges are replaced by the value above [H ~> m or kg m-2]. + real :: varying_input_dz_mask !< An input file thickness below which the target values with time-varying + !! sponges are replaced by the value above [Z ~> m]. !! It is not clear why this needs to be greater than 0. !>@{ Diagnostic IDs - integer, dimension(MAX_FIELDS_) :: id_sp_tendency !< Diagnostic ids for tracers - !! tendency due to sponges + integer, dimension(MAX_FIELDS_) :: id_sp_tendency !< Diagnostic ids for tracer + !! tendencies due to sponges integer :: id_sp_u_tendency !< Diagnostic id for zonal momentum tendency due to !! Rayleigh damping integer :: id_sp_v_tendency !< Diagnostic id for meridional momentum tendency due to @@ -152,10 +153,10 @@ module MOM_ALE_sponge !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. It also stores the target interface heights. subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, nz_data, & - Iresttime_u_in, Iresttime_v_in) + Iresttime_u_in, Iresttime_v_in, data_h_is_Z) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure integer, intent(in) :: nz_data !< The total number of sponge input layers. real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file @@ -163,21 +164,28 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for this module (in/out). real, dimension(SZI_(G),SZJ_(G),nz_data), intent(inout) :: data_h !< The thicknesses of the sponge - !! input layers [H ~> m or kg m-2]. - real, dimension(SZIB_(G),SZJ_(G)), intent(in), optional :: Iresttime_u_in !< The inverse of the restoring + !! input layers, in [H ~> m or kg m-2] or [Z ~> m] + !! depending on data_h_is_Z. + real, dimension(SZIB_(G),SZJ_(G)), optional, intent(in) :: Iresttime_u_in !< The inverse of the restoring !! time at U-points [T-1 ~> s-1]. - real, dimension(SZI_(G),SZJB_(G)), intent(in), optional :: Iresttime_v_in !< The inverse of the restoring - ! time at v-points [T-1 ~> s-1]. - + real, dimension(SZI_(G),SZJB_(G)), optional, intent(in) :: Iresttime_v_in !< The inverse of the restoring + !! time at v-points [T-1 ~> s-1]. + logical, optional, intent(in) :: data_h_is_Z !< If present and true data_h is already in + !! depth units. Omitting this is the same as setting + !! it to false. ! Local variables character(len=40) :: mdl = "MOM_sponge" ! This module's name. real, allocatable, dimension(:,:) :: Iresttime_u !< inverse of the restoring time at u points [T-1 ~> s-1] real, allocatable, dimension(:,:) :: Iresttime_v !< inverse of the restoring time at v points [T-1 ~> s-1] + real, dimension(SZI_(G),SZJ_(G),nz_data) :: data_dz !< The vertical extent of the sponge + !! input layers [Z ~> m]. + real :: data_h_to_Z_scale ! A scaling factor to convert data_h into the right units, often [Z H-1 ~> 1 or m3 kg-1] ! This include declares and sets the variable "version". # include "version_variable.h" character(len=64) :: remapScheme logical :: use_sponge + logical :: data_h_to_Z logical :: bndExtrapolation = .true. ! If true, extrapolate boundaries integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. integer :: i, j, k, col, total_sponge_cols, total_sponge_cols_u, total_sponge_cols_v @@ -236,6 +244,11 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, CS%time_varying_sponges = .false. CS%nz = GV%ke + data_h_to_Z_scale = GV%H_to_Z ; if (present(data_h_is_Z)) data_h_to_Z_scale = 1.0 + + do k=1,nz_data ; do j=G%jsc,G%jec ; do i=G%isc,G%iec + data_dz(i,j,k) = data_h_to_Z_scale * data_h(i,j,k) + enddo ; enddo ; enddo ! number of columns to be restored CS%num_col = 0 ; CS%fldno = 0 do j=G%jsc,G%jec ; do i=G%isc,G%iec @@ -253,14 +266,14 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, if ((Iresttime(i,j) > 0.0) .and. (G%mask2dT(i,j) > 0.0)) then CS%col_i(col) = i ; CS%col_j(col) = j CS%Iresttime_col(col) = Iresttime(i,j) - col = col +1 + col = col + 1 endif enddo ; enddo ! same for total number of arbitrary layers and correspondent data CS%nz_data = nz_data - allocate(CS%Ref_h%p(CS%nz_data,CS%num_col)) + allocate(CS%Ref_dz%p(CS%nz_data,CS%num_col), source=0.0) do col=1,CS%num_col ; do K=1,CS%nz_data - CS%Ref_h%p(K,col) = data_h(CS%col_i(col),CS%col_j(col),K) + CS%Ref_dz%p(K,col) = data_dz(CS%col_i(col),CS%col_j(col),K) enddo ; enddo endif @@ -278,8 +291,8 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) - call pass_var(Iresttime,G%Domain) - call pass_var(data_h,G%Domain) + call pass_var(Iresttime, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(data_dz, G%Domain, To_All+Omit_Corners, halo=1) ! u points CS%num_col_u = 0 ; @@ -312,11 +325,11 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo ! same for total number of arbitrary layers and correspondent data - allocate(CS%Ref_hu%p(CS%nz_data,CS%num_col_u)) + allocate(CS%Ref_dzu%p(CS%nz_data,CS%num_col_u), source=0.0) do col=1,CS%num_col_u I = CS%col_i_u(col) ; j = CS%col_j_u(col) do k=1,CS%nz_data - CS%Ref_hu%p(k,col) = 0.5 * (data_h(i,j,k) + data_h(i+1,j,k)) + CS%Ref_dzu%p(k,col) = 0.5 * (data_dz(i,j,k) + data_dz(i+1,j,k)) enddo enddo endif @@ -356,11 +369,11 @@ subroutine initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, CS, data_h, enddo ; enddo ! same for total number of arbitrary layers and correspondent data - allocate(CS%Ref_hv%p(CS%nz_data,CS%num_col_v)) + allocate(CS%Ref_dzv%p(CS%nz_data,CS%num_col_v), source=0.0) do col=1,CS%num_col_v i = CS%col_i_v(col) ; J = CS%col_j_v(col) do k=1,CS%nz_data - CS%Ref_hv%p(k,col) = 0.5 * (data_h(i,j,k) + data_h(i,j+1,k)) + CS%Ref_dzv%p(k,col) = 0.5 * (data_dz(i,j,k) + data_dz(i,j+1,k)) enddo enddo endif @@ -382,15 +395,22 @@ function get_ALE_sponge_nz_data(CS) end function get_ALE_sponge_nz_data !> Return the thicknesses used for the data with a fixed ALE sponge -subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) +subroutine get_ALE_sponge_thicknesses(G, GV, data_h, sponge_mask, CS, data_h_in_Z) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure (in). + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, allocatable, dimension(:,:,:), & - intent(inout) :: data_h !< The thicknesses of the sponge input layers [H ~> m or kg m-2]. + intent(inout) :: data_h !< The thicknesses of the sponge input layers expressed + !! as vertical extents [Z ~> m] or in thickness units + !! [H ~> m or kg m-2], depending on the value of data_h_in_Z. logical, dimension(SZI_(G),SZJ_(G)), & intent(out) :: sponge_mask !< A logical mask that is true where !! sponges are being applied. type(ALE_sponge_CS), pointer :: CS !< A pointer that is set to point to the control !! structure for the ALE_sponge module. + logical, optional, intent(in) :: data_h_in_Z !< If present and true data_h is returned in + !! depth units. Omitting this is the same as setting + !! it to false. + real :: Z_to_data_h_units ! A scaling factor to return data_h in the right units, often [H Z-1 ~> 1 or kg m-3] integer :: c, i, j, k if (allocated(data_h)) call MOM_error(FATAL, & @@ -406,11 +426,13 @@ subroutine get_ALE_sponge_thicknesses(G, data_h, sponge_mask, CS) allocate(data_h(G%isd:G%ied,G%jsd:G%jed,CS%nz_data), source=-1.0) sponge_mask(:,:) = .false. + Z_to_data_h_units = GV%Z_to_H ; if (present(data_h_in_Z)) Z_to_data_h_units = 1.0 + do c=1,CS%num_col i = CS%col_i(c) ; j = CS%col_j(c) sponge_mask(i,j) = .true. do k=1,CS%nz_data - data_h(i,j,k) = CS%Ref_h%p(k,c) + data_h(i,j,k) = Z_to_data_h_units*CS%Ref_dz%p(k,c) enddo enddo @@ -419,10 +441,11 @@ end subroutine get_ALE_sponge_thicknesses !> This subroutine determines the number of points which are to be restored in the computational !! domain. Only points that have positive values of Iresttime and which mask2dT indicates are ocean !! points are included in the sponges. -subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Iresttime_u_in, Iresttime_v_in) +subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, CS, Iresttime_u_in, Iresttime_v_in) type(ocean_grid_type), intent(in) :: G !< The ocean's 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)), intent(inout) :: Iresttime !< The inverse of the restoring time [T-1 ~> s-1]. type(param_file_type), intent(in) :: param_file !< A structure indicating the open file to parse !! for model parameter values. @@ -471,10 +494,10 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest "than PCM. E.g., if PPM is used for remapping, a "//& "PPM reconstruction will also be used within boundary cells.", & default=.false., do_not_log=.true.) - call get_param(param_file, mdl, "VARYING_SPONGE_MASK_THICKNESS", CS%varying_input_h_mask, & + call get_param(param_file, mdl, "VARYING_SPONGE_MASK_THICKNESS", CS%varying_input_dz_mask, & "An input file thickness below which the target values with "//& "time-varying sponges are replaced by the value above.", & - units="m", default=0.001, scale=GV%m_to_H) + units="m", default=0.001, scale=US%m_to_Z) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & @@ -531,7 +554,7 @@ subroutine initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, CS, Irest allocate(Iresttime_u(G%isdB:G%iedB,G%jsd:G%jed), source=0.0) allocate(Iresttime_v(G%isd:G%ied,G%jsdB:G%jedB), source=0.0) - call pass_var(Iresttime,G%Domain) + call pass_var(Iresttime, G%Domain, To_All+Omit_Corners, halo=1) ! u points if (present(Iresttime_u_in)) then Iresttime_u(:,:) = Iresttime_u_in(:,:) @@ -755,7 +778,7 @@ subroutine set_up_ALE_sponge_field_varying(filename, fieldname, Time, G, GV, US, ! initializes the target profile array for this field ! for all columns which will be masked allocate(CS%Ref_val(CS%fldno)%p(nz_data,CS%num_col), source=0.0) - allocate(CS%Ref_val(CS%fldno)%h(nz_data,CS%num_col), source=0.0) + allocate(CS%Ref_val(CS%fldno)%dz(nz_data,CS%num_col), source=0.0) CS%var(CS%fldno)%p => f_ptr end subroutine set_up_ALE_sponge_field_varying @@ -863,32 +886,35 @@ subroutine set_up_ALE_sponge_vel_field_varying(filename_u, fieldname_u, filename ! stores the reference profile allocate(CS%Ref_val_u%p(fld_sz(3),CS%num_col_u), source=0.0) - allocate(CS%Ref_val_u%h(fld_sz(3),CS%num_col_u), source=0.0) + allocate(CS%Ref_val_u%dz(fld_sz(3),CS%num_col_u), source=0.0) CS%var_u%p => u_ptr allocate(CS%Ref_val_v%p(fld_sz(3),CS%num_col_v), source=0.0) - allocate(CS%Ref_val_v%h(fld_sz(3),CS%num_col_v), source=0.0) + allocate(CS%Ref_val_v%dz(fld_sz(3),CS%num_col_v), source=0.0) CS%var_v%p => v_ptr end subroutine set_up_ALE_sponge_vel_field_varying !> This subroutine applies damping to the layers thicknesses, temp, salt and a variety of tracers !! for every column where there is damping. -subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) +subroutine apply_ALE_sponge(h, tv, dt, G, GV, US, CS, Time) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure (in). type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] (in) + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables real, intent(in) :: dt !< The amount of time covered by this call [T ~> s]. type(ALE_sponge_CS), pointer :: CS !< A pointer to the control structure for this module !! that is set by a previous call to initialize_ALE_sponge (in). type(time_type), intent(in) :: Time !< The current model date + ! Local variables real :: damp ! The timestep times the local damping coefficient [nondim]. real :: I1pdamp ! I1pdamp is 1/(1 + damp). [nondim]. real, allocatable, dimension(:) :: tmp_val2 ! data values on the original grid [various] real, dimension(SZK_(GV)) :: tmp_val1 ! data values remapped to model grid [various] - real, dimension(SZK_(GV)) :: h_col ! A column of thicknesses at h, u or v points [H ~> m or kg m-2] + real, dimension(SZK_(GV)) :: dz_col ! A column of thicknesses at h, u or v points [Z ~> m] real, allocatable, dimension(:,:,:) :: sp_val ! A temporary array for fields [various] real, allocatable, dimension(:,:,:) :: mask_z ! A temporary array for field mask at h pts [nondim] real, allocatable, dimension(:,:,:) :: mask_u ! A temporary array for field mask at u pts [nondim] @@ -899,7 +925,9 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] real, allocatable, dimension(:,:,:) :: tmp_v !< A temporary array for v sponge acceleration diagnostics !! first in [L T-1 ~> m s-1] then in [L T-2 ~> m s-2] - real, dimension(:), allocatable :: hsrc ! Source thicknesses [Z ~> m]. + real, dimension(:), allocatable :: dz_src ! Source thicknesses [Z ~> m]. + real :: dz_model(SZI_(G),SZJ_(G),SZK_(GV)) ! Vertical distance across model layers [Z ~> m] + ! Local variables for ALE remapping real, dimension(:), allocatable :: tmpT1d ! A temporary variable for ALE remapping [various] integer :: c, m, i, j, k, is, ie, js, je, nz, nz_data @@ -908,7 +936,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! edges in the input file [Z ~> m] real :: missing_value ! The missing value in the input data field [various] real :: Idt ! The inverse of the timestep [T-1 ~> s-1] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] + real :: dz_neglect, dz_neglect_edge ! Negligible layer extents [Z ~> m] real :: zTopOfCell, zBottomOfCell ! Interface heights (positive upward) in the input dataset [Z ~> m]. real :: sp_val_u ! Interpolation of sp_val to u-points, often a velocity in [L T-1 ~> m s-1] real :: sp_val_v ! Interpolation of sp_val to v-points, often a velocity in [L T-1 ~> m s-1] @@ -920,11 +948,13 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) Idt = 1.0/dt if (CS%remap_answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + dz_neglect = US%m_to_Z*1.0e-30 ; dz_neglect_edge = US%m_to_Z*1.0e-10 + elseif (GV%semi_Boussinesq) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z*1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z*1.0e-10 else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff endif if (CS%time_varying_sponges) then @@ -934,14 +964,14 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) 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) - allocate( hsrc(nz_data) ) + allocate( dz_src(nz_data) ) allocate( tmpT1d(nz_data) ) do c=1,CS%num_col ! Set i and j to the structured indices of column c. i = CS%col_i(c) ; j = CS%col_j(c) CS%Ref_val(m)%p(1:nz_data,c) = sp_val(i,j,1:nz_data) ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; hsrc(:) = 0.0 ; tmpT1d(:) = -99.9 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 ; tmpT1d(:) = -99.9 do k=1,nz_data if (mask_z(CS%col_i(c),CS%col_j(c),k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(CS%col_i(c),CS%col_j(c)) ) @@ -952,26 +982,26 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) else ! This next block should only ever be reached over land tmpT1d(k) = -99.9 endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k) > 0.) nPoints = nPoints + 1 + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) - CS%Ref_val(m)%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(CS%col_i(c),CS%col_j(c)) ) + CS%Ref_val(m)%dz(1:nz_data,c) = dz_src(1:nz_data) CS%Ref_val(m)%p(1:nz_data,c) = tmpT1d(1:nz_data) do k=2,nz_data - if (CS%Ref_val(m)%h(k,c) <= CS%varying_input_h_mask) & + if (CS%Ref_val(m)%dz(k,c) <= CS%varying_input_dz_mask) & ! some confusion here about why the masks are not correct returning from horiz_interp ! reverting to using a minimum thickness criteria CS%Ref_val(m)%p(k,c) = CS%Ref_val(m)%p(k-1,c) enddo enddo - deallocate(sp_val, mask_z, hsrc, tmpT1d) + deallocate(sp_val, mask_z, dz_src, tmpT1d) enddo endif - tmp_val1(:) = 0.0 ; h_col(:) = 0.0 + tmp_val1(:) = 0.0 ; dz_col(:) = 0.0 do m=1,CS%fldno nz_data = CS%Ref_val(m)%nz_data allocate(tmp_val2(CS%Ref_val(m)%nz_data)) @@ -984,16 +1014,22 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) damp = dt * CS%Iresttime_col(c) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val(m)%p(1:nz_data,c) - do k=1,nz - h_col(k) = h(i,j,k) - enddo + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz + dz_col(k) = GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + enddo + else + do k=1,nz + dz_col(k) = GV%H_to_Z * h(i,j,k) + enddo + endif if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%h(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val(m)%dz(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_h%p(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dz%p(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) endif !Backward Euler method if (CS%id_sp_tendency(m) > 0) tmp(i,j,1:nz) = CS%var(m)%p(i,j,1:nz) @@ -1022,15 +1058,15 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc-1, G%jsc:G%jec, :) = 0. mask_z(G%iec+1, G%jsc:G%jec, :) = 0. - call pass_var(sp_val, G%Domain) - call pass_var(mask_z, G%Domain) + call pass_var(sp_val, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(mask_z, G%Domain, To_All+Omit_Corners, halo=1) allocate(mask_u(G%isdB:G%iedB,G%jsd:G%jed,1:nz_data)) do j=G%jsc,G%jec; do I=G%iscB,G%iecB mask_u(I,j,1:nz_data) = min(mask_z(i,j,1:nz_data),mask_z(i+1,j,1:nz_data)) enddo ; enddo - allocate( hsrc(nz_data) ) + allocate( dz_src(nz_data) ) do c=1,CS%num_col_u ! Set i and j to the structured indices of column c. i = CS%col_i_u(c) ; j = CS%col_j_u(c) @@ -1043,7 +1079,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val_u%p(1:nz_data,c) = 0.0 endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; hsrc(:) = 0.0 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 do k=1,nz_data if (mask_u(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) @@ -1051,15 +1087,15 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) zBottomOfCell = -G%bathyT(i,j) else ! This next block should only ever be reached over land endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k) > 0.) nPoints = nPoints + 1 + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) - CS%Ref_val_u%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_u%dz(1:nz_data,c) = dz_src(1:nz_data) enddo - deallocate(sp_val, mask_u, mask_z, hsrc) + deallocate(sp_val, mask_u, mask_z, dz_src) 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%field, Time, G, sp_val, & @@ -1069,15 +1105,15 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) ! Initialize mask_z halos to zero before pass_var, in case of no update mask_z(G%isc:G%iec, G%jsc-1, :) = 0. mask_z(G%isc:G%iec, G%jec+1, :) = 0. - call pass_var(sp_val, G%Domain) - call pass_var(mask_z, G%Domain) + call pass_var(sp_val, G%Domain, To_All+Omit_Corners, halo=1) + call pass_var(mask_z, G%Domain, To_All+Omit_Corners, halo=1) allocate(mask_v(G%isd:G%ied,G%jsdB:G%jedB,1:nz_data)) do J=G%jscB,G%jecB; do i=G%isc,G%iec mask_v(i,J,1:nz_data) = min(mask_z(i,j,1:nz_data),mask_z(i,j+1,1:nz_data)) enddo ; enddo - !call pass_var(mask_z,G%Domain) - allocate( hsrc(nz_data) ) + + allocate( dz_src(nz_data) ) do c=1,CS%num_col_v ! Set i and j to the structured indices of column c. i = CS%col_i_v(c) ; j = CS%col_j_v(c) @@ -1090,7 +1126,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) CS%Ref_val_v%p(1:nz_data,c) = 0.0 endif ! Build the source grid - zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; hsrc(:) = 0.0 + zTopOfCell = 0. ; zBottomOfCell = 0. ; nPoints = 0 ; dz_src(:) = 0.0 do k=1,nz_data if (mask_v(i,j,k) == 1.0) then zBottomOfCell = -min( z_edges_in(k+1) - G%Z_ref, G%bathyT(i,j) ) @@ -1098,18 +1134,31 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) zBottomOfCell = -G%bathyT(i,j) else ! This next block should only ever be reached over land endif - hsrc(k) = zTopOfCell - zBottomOfCell - if (hsrc(k) > 0.) nPoints = nPoints + 1 + dz_src(k) = zTopOfCell - zBottomOfCell + if (dz_src(k) > 0.) nPoints = nPoints + 1 zTopOfCell = zBottomOfCell ! Bottom becomes top for next value of k enddo ! In case data is deeper than model - hsrc(nz_data) = hsrc(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) - CS%Ref_val_v%h(1:nz_data,c) = GV%Z_to_H*hsrc(1:nz_data) + dz_src(nz_data) = dz_src(nz_data) + ( zTopOfCell + G%bathyT(i,j) ) + CS%Ref_val_v%dz(1:nz_data,c) = dz_src(1:nz_data) enddo - deallocate(sp_val, mask_v, mask_z, hsrc) + deallocate(sp_val, mask_v, mask_z, dz_src) + endif + + ! Because we can not be certain whether there are velocity points at the processor + ! boundaries, and the thicknesses might not have been updated there, we need to + ! calculate the tracer point layer vertical extents and then do a halo update. + if ((.not.GV%Boussinesq) .and. allocated(tv%SpV_avg)) then + do k=1,nz ; do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + dz_model(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=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 + dz_model(i,j,k) = GV%H_to_Z * h(i,j,k) + enddo ; enddo ; enddo endif + call pass_var(dz_model, G%Domain, To_All+Omit_Corners, halo=1) - call pass_var(h,G%Domain) nz_data = CS%Ref_val_u%nz_data allocate(tmp_val2(nz_data)) if (CS%id_sp_u_tendency > 0) then @@ -1122,14 +1171,14 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) I1pdamp = 1.0 / (1.0 + damp) tmp_val2(1:nz_data) = CS%Ref_val_u%p(1:nz_data,c) do k=1,nz - h_col(k) = 0.5 * (h(i,j,k) + h(i+1,j,k)) + dz_col(k) = 0.5 * (dz_model(i,j,k) + dz_model(i+1,j,k)) enddo if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%h(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_u%dz(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hu%p(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzu%p(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) endif if (CS%id_sp_u_tendency > 0) tmp_u(i,j,1:nz) = CS%var_u%p(i,j,1:nz) !Backward Euler method @@ -1155,14 +1204,14 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) if (CS%time_varying_sponges) nz_data = CS%Ref_val_v%nz_data tmp_val2(1:nz_data) = CS%Ref_val_v%p(1:nz_data,c) do k=1,nz - h_col(k) = 0.5 * (h(i,j,k) + h(i,j+1,k)) + dz_col(k) = 0.5 * (dz_model(i,j,k) + dz_model(i,j+1,k)) enddo if (CS%time_varying_sponges) then - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_v%h(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_val_v%dz(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) else - call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_hv%p(1:nz_data,c), tmp_val2, & - CS%nz, h_col, tmp_val1, h_neglect, h_neglect_edge) + call remapping_core_h(CS%remap_cs, nz_data, CS%Ref_dzv%p(1:nz_data,c), tmp_val2, & + CS%nz, dz_col, tmp_val1, dz_neglect, dz_neglect_edge) endif if (CS%id_sp_v_tendency > 0) tmp_v(i,j,1:nz) = CS%var_v%p(i,j,1:nz) !Backward Euler method @@ -1179,7 +1228,7 @@ subroutine apply_ALE_sponge(h, dt, G, GV, US, CS, Time) end subroutine apply_ALE_sponge !> Rotate the ALE sponge fields from the input to the model index map. -subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) +subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, US, turns, param_file) type(ALE_sponge_CS), intent(in) :: sponge_in !< The control structure for this module with the !! original grid rotation type(ocean_grid_type), intent(in) :: G_in !< The ocean's grid structure with the original rotation. @@ -1187,6 +1236,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) !! the new grid rotation type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure with the new rotation. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type integer, intent(in) :: turns !< The number of 90-degree turns between grids type(param_file_type), intent(in) :: param_file !< A structure indicating the open file !! to parse for model parameter values. @@ -1199,8 +1249,8 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) real, dimension(:,:), allocatable :: Iresttime_in ! Restoring rate on the input sponges [T-1 ~> s-1] real, dimension(:,:), allocatable :: Iresttime ! Restoring rate on the output sponges [T-1 ~> s-1] - real, dimension(:,:,:), allocatable :: data_h_in ! Grid for the input sponges [H ~> m or kg m-2] - real, dimension(:,:,:), allocatable :: data_h ! Grid for the output sponges [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: data_dz_in ! Grid for the input sponges [Z ~> m] + real, dimension(:,:,:), allocatable :: data_dz ! Grid for the output sponges [Z ~> m] real, dimension(:,:,:), allocatable :: sp_val_in ! Target data for the input sponges [various] real, dimension(:,:,:), allocatable :: sp_val ! Target data for the output sponges [various] real, dimension(:,:,:), pointer :: sp_ptr => NULL() ! Target data for the input sponges [various] @@ -1217,36 +1267,36 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) if (fixed_sponge) then nz_data = sponge_in%nz_data - allocate(data_h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data), source=0.0) - allocate(data_h(G%isd:G%ied, G%jsd:G%jed, nz_data)) + allocate(data_dz_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz_data), source=0.0) + allocate(data_dz(G%isd:G%ied, G%jsd:G%jed, nz_data)) endif - ! Re-populate the 2D Iresttime and data_h arrays on the original grid + ! Re-populate the 2D Iresttime and data_dz arrays on the original grid do c=1,sponge_in%num_col c_i = sponge_in%col_i(c) c_j = sponge_in%col_j(c) Iresttime_in(c_i, c_j) = sponge_in%Iresttime_col(c) if (fixed_sponge) then do k = 1, nz_data - data_h(c_i, c_j, k) = sponge_in%Ref_h%p(k,c) + data_dz_in(c_i, c_j, k) = sponge_in%Ref_dz%p(k,c) enddo endif enddo call rotate_array(Iresttime_in, turns, Iresttime) if (fixed_sponge) then - call rotate_array(data_h_in, turns, data_h) + call rotate_array(data_dz_in, turns, data_dz) call initialize_ALE_sponge_fixed(Iresttime, G, GV, param_file, sponge, & - data_h, nz_data) + data_dz, nz_data, data_h_is_Z=.true.) else - call initialize_ALE_sponge_varying(Iresttime, G, GV, param_file, sponge) + call initialize_ALE_sponge_varying(Iresttime, G, GV, US, param_file, sponge) endif deallocate(Iresttime_in) deallocate(Iresttime) if (fixed_sponge) then - deallocate(data_h_in) - deallocate(data_h) + deallocate(data_dz_in) + deallocate(data_dz) endif ! Second part: Provide rotated fields for which relaxation is applied @@ -1275,7 +1325,8 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) ! NOTE: This points sp_val with the unrotated field. See note below. call set_up_ALE_sponge_field(sp_val, G, GV, sp_ptr, sponge, & - sponge_in%Ref_val(n)%name, sp_long_name=sponge_in%Ref_val(n)%long_name, sp_unit=sponge_in%Ref_val(n)%unit) + sponge_in%Ref_val(n)%name, sp_long_name=sponge_in%Ref_val(n)%long_name, & + sp_unit=sponge_in%Ref_val(n)%unit) deallocate(sp_val_in) else @@ -1289,7 +1340,7 @@ subroutine rotate_ALE_sponge(sponge_in, G_in, sponge, G, GV, turns, param_file) sponge%Ref_val(n)%nz_data = nz_data allocate(sponge%Ref_val(n)%p(nz_data, sponge_in%num_col), source=0.0) - allocate(sponge%Ref_val(n)%h(nz_data, sponge_in%num_col), source=0.0) + allocate(sponge%Ref_val(n)%dz(nz_data, sponge_in%num_col), source=0.0) ! TODO: There is currently no way to associate a generic field pointer to ! its rotated equivalent without introducing a new data structure which diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 097628c032..081f065f3e 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1093,7 +1093,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Apply ALE sponge if (CS%use_sponge .and. associated(CS%ALE_sponge_CSp)) then call cpu_clock_begin(id_clock_sponge) - call apply_ALE_sponge(h, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + call apply_ALE_sponge(h, tv, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) call cpu_clock_end(id_clock_sponge) if (CS%debug) then call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) @@ -1616,7 +1616,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! Apply ALE sponge if (CS%use_sponge .and. associated(CS%ALE_sponge_CSp)) then call cpu_clock_begin(id_clock_sponge) - call apply_ALE_sponge(h, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) + call apply_ALE_sponge(h, tv, dt, G, GV, US, CS%ALE_sponge_CSp, CS%Time) call cpu_clock_end(id_clock_sponge) if (CS%debug) then call MOM_state_chksum("apply_sponge ", u, v, h, G, GV, US, haloshift=0) From f14a681079bd563b69b7db5133f23bd0192d63de Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Jan 2024 09:26:50 -0500 Subject: [PATCH 538/629] (*)Use thickness_to_dz with BRYAN_LEWIS_DIFFUSIVITY Use thickness_to_dz to convert the layer thicknesses into the geometric depths used to set the Bryan-Lewis background diffusivities instead of multiplication by GV%H_to_m, thereby avoiding division by the Boussinesq reference density in non-Boussinesq mode. No answers are changed in any Boussinsesq configurations, but answers will change in non-Boussinesq configurations that have BRYAN_LEWIS_DIFFUSIVITY = True. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index 693b9395bd..ee04f3f195 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -13,6 +13,7 @@ module MOM_bkgnd_mixing use MOM_file_parser, only : openParameterBlock, closeParameterBlock use MOM_forcing_type, only : forcing use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_unit_scaling, only : unit_scale_type use MOM_verticalGrid, only : verticalGrid_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type @@ -338,6 +339,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, real, dimension(SZK_(GV)+1) :: Kv_col !< Viscosities at the interfaces [m2 s-1] real, dimension(SZI_(G)) :: Kd_sfc !< Surface value of the diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] real, dimension(SZI_(G)) :: depth !< Distance from surface of an interface [H ~> m or kg m-2] + real, dimension(SZI_(G),SZK_(GV)) :: dz !< Height change across layers [Z ~> m] real :: depth_c !< depth of the center of a layer [H ~> m or kg m-2] real :: I_Hmix !< inverse of fixed mixed layer thickness [H-1 ~> m-1 or m2 kg-1] real :: I_2Omega !< 1/(2 Omega) [T ~> s] @@ -364,10 +366,12 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, ! Set up the background diffusivity. if (CS%Bryan_Lewis_diffusivity) then + call thickness_to_dz(h, tv, dz, j, G, GV) + do i=is,ie depth_int(1) = 0.0 do k=2,nz+1 - depth_int(k) = depth_int(k-1) + GV%H_to_m*h(i,j,k-1) + depth_int(k) = depth_int(k-1) + US%Z_to_m*dz(i,k-1) enddo call CVMix_init_bkgnd(max_nlev=nz, & From 3f7465a57923a75fe23e6b7216ea27264ab7349d Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 28 Jan 2024 11:17:45 -0500 Subject: [PATCH 539/629] +tracer_Z_init can rescale tracers Added the new optional scale argument to tracer_Z_init to allow the units of the tracers that it initializes from a z-space file to be rescaled, similarly to what is already done in tracer_z_init_array. This also required the addition of the new missing_scale argument to the private routine read_Z_edges to specify how the missing values are rescaled. Comments were also added or modified describing 28 real variables or their units in this module. By default all answers are bitwise identical, but when this new option is exercised, answers could change at roundoff for some non-Boussinesq cases. --- src/tracer/MOM_tracer_Z_init.F90 | 89 +++++++++++++++++++------------- 1 file changed, 54 insertions(+), 35 deletions(-) diff --git a/src/tracer/MOM_tracer_Z_init.F90 b/src/tracer/MOM_tracer_Z_init.F90 index c404c560f3..2cf0ba1efe 100644 --- a/src/tracer/MOM_tracer_Z_init.F90 +++ b/src/tracer/MOM_tracer_Z_init.F90 @@ -27,50 +27,58 @@ module MOM_tracer_Z_init !> This function initializes a tracer by reading a Z-space file, returning !! .true. if this appears to have been successful, and false otherwise. -function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_val) +function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_val, scale) logical :: tracer_Z_init !< A return code indicating if the initialization has been successful 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) :: tr !< The tracer to initialize + intent(out) :: tr !< The tracer to initialize [CU ~> conc] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] - character(len=*), intent(in) :: filename !< The name of the file to read from - character(len=*), intent(in) :: tr_name !< The name of the tracer in the file - real, optional, intent(in) :: missing_val !< The missing value for the tracer - real, optional, intent(in) :: land_val !< A value to use to fill in land points - -! This include declares and sets the variable "version". -# include "version_variable.h" + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] or other + !! arbitrary units such as [Z ~> m] + character(len=*), intent(in) :: filename !< The name of the file to read from + character(len=*), intent(in) :: tr_name !< The name of the tracer in the file + real, optional, intent(in) :: missing_val !< The missing value for the tracer [CU ~> conc] + real, optional, intent(in) :: land_val !< A value to use to fill in land points [CU ~> conc] + real, optional, intent(in) :: scale !< A factor by which to scale the output tracers from the + !! their units in the file [CU conc-1 ~> 1] + ! Local variables real, allocatable, dimension(:,:,:) :: & - tr_in ! The z-space array of tracer concentrations that is read in. + tr_in ! The z-space array of tracer concentrations that is read in [CU ~> conc] real, allocatable, dimension(:) :: & z_edges, & ! The depths of the cell edges or cell centers (depending on ! the value of has_edges) in the input z* data [Z ~> m]. - tr_1d, & ! A copy of the input tracer concentrations in a column. + tr_1d, & ! A copy of the input tracer concentrations in a column [CU ~> conc] wt, & ! The fractional weight for each layer in the range between - ! k_top and k_bot, nondim. - z1, & ! z1 and z2 are the depths of the top and bottom limits of the part - z2 ! of a z-cell that contributes to a layer, relative to the cell - ! center and normalized by the cell thickness, nondim. + ! k_top and k_bot [nondim] + z1, z2 ! z1 and z2 are the depths of the top and bottom limits of the part + ! of a z-cell that contributes to a layer, relative to the cell + ! center and normalized by the cell thickness [nondim]. ! Note that -1/2 <= z1 <= z2 <= 1/2. real :: e(SZK_(GV)+1) ! The z-star interface heights [Z ~> m]. - real :: landval ! The tracer value to use in land points. + real :: landval ! The tracer value to use in land points [CU ~> conc] real :: sl_tr ! The normalized slope of the tracer - ! within the cell, in tracer units. + ! within the cell, in tracer units [CU ~> conc] real :: htot(SZI_(G)) ! The vertical sum of h [H ~> m or kg m-2]. real :: dilate ! The amount by which the thicknesses are dilated to - ! create a z-star coordinate, nondim or in m3 kg-1. - real :: missing ! The missing value for the tracer. - + ! create a z-star coordinate [Z H-1 ~> nondim or m3 kg-1] + ! or other units reflecting those of h + real :: missing ! The missing value for the tracer [CU ~> conc] + real :: scale_fac ! A factor by which to scale the output tracers from the units in the + ! input file [CU conc-1 ~> 1] + ! This include declares and sets the variable "version". +# include "version_variable.h" logical :: has_edges, use_missing, zero_surface character(len=80) :: loc_msg integer :: k_top, k_bot, k_bot_prev, k_start integer :: i, j, k, kz, is, ie, js, je, nz, nz_in + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + scale_fac = 1.0 ; if (present(scale)) then ; scale_fac = scale ; endif + landval = 0.0 ; if (present(land_val)) landval = land_val zero_surface = .false. ! Make this false for errors to be fatal. @@ -83,7 +91,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va ! Find out the number of input levels and read the depth of the edges, ! also modifying their sign convention to be monotonically decreasing. call read_Z_edges(filename, tr_name, z_edges, nz_in, has_edges, use_missing, & - missing, scale=US%m_to_Z) + missing, scale=US%m_to_Z, missing_scale=scale_fac) if (nz_in < 1) then tracer_Z_init = .false. return @@ -91,7 +99,7 @@ function tracer_Z_init(tr, h, filename, tr_name, G, GV, US, missing_val, land_va allocate(tr_in(G%isd:G%ied,G%jsd:G%jed,nz_in), source=0.0) allocate(tr_1d(nz_in), source=0.0) - call MOM_read_data(filename, tr_name, tr_in(:,:,:), G%Domain) + call MOM_read_data(filename, tr_name, tr_in(:,:,:), G%Domain, scale=scale_fac) ! Fill missing values from above? Use a "close" test to avoid problems ! from type-conversion rounoff. @@ -297,9 +305,10 @@ subroutine tracer_z_init_array(tr_in, z_edges, nk_data, e, land_fill, G, nlay, n real :: e_1d(nlay+1) ! A 1-d column of interface heights, in the same units as e [Z ~> m] or [m] real :: sl_tr ! The tracer concentration slope times the layer thickness, in tracer units [B] real :: wt(nk_data) ! The fractional weight for each layer in the range between z1 and z2 [nondim] - real :: z1(nk_data) ! z1 and z2 are the fractional depths of the top and bottom - real :: z2(nk_data) ! limits of the part of a z-cell that contributes to a layer, relative - ! to the cell center and normalized by the cell thickness [nondim]. + real :: z1(nk_data) ! The fractional depth of the top limit of the part of a z-cell that contributes to + ! a layer, relative to the cell center and normalized by the cell thickness [nondim]. + real :: z2(nk_data) ! The fractional depth of the bottom limit of the part of a z-cell that contributes to + ! a layer, relative to the cell center and normalized by the cell thickness [nondim]. ! Note that -1/2 <= z1 <= z2 <= 1/2. real :: scale_fac ! A factor by which to scale the output tracers from the input tracers [B A-1 ~> 1] integer :: k_top, k_bot, k_bot_prev, kstart @@ -380,18 +389,21 @@ end subroutine tracer_z_init_array !> This subroutine reads the vertical coordinate data for a field from a NetCDF file. !! It also might read the missing value attribute for that same field. subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & - use_missing, missing, scale) + use_missing, missing, scale, missing_scale) character(len=*), intent(in) :: filename !< The name of the file to read from. character(len=*), intent(in) :: tr_name !< The name of the tracer in the file. real, dimension(:), allocatable, & - intent(out) :: z_edges !< The depths of the vertical edges of the tracer array + intent(out) :: z_edges !< The depths of the vertical edges of the tracer array [Z ~> m] integer, intent(out) :: nz_out !< The number of vertical layers in the tracer array logical, intent(out) :: has_edges !< If true the values in z_edges are the edges of the !! tracer cells, otherwise they are the cell centers logical, intent(inout) :: use_missing !< If false on input, see whether the tracer has a !! missing value, and if so return true - real, intent(inout) :: missing !< The missing value, if one has been found - real, intent(in) :: scale !< A scaling factor for z_edges into new units. + real, intent(inout) :: missing !< The missing value, if one has been found [CU ~> conc] + real, intent(in) :: scale !< A scaling factor for z_edges into new units [Z m-1 ~> 1] + real, intent(in) :: missing_scale !< A scaling factor to use to convert the + !! tracers and their missing value from the units in + !! the file into their internal units [CU conc-1 ~> 1] ! This subroutine reads the vertical coordinate data for a field from a ! NetCDF file. It also might read the missing value attribute for that same field. @@ -419,6 +431,7 @@ subroutine read_Z_edges(filename, tr_name, z_edges, nz_out, has_edges, & if (.not.use_missing) then ! Try to find the missing value from the dataset. call read_attribute(filename, "missing_value", missing, varname=tr_name, found=use_missing, ncid_in=ncid) + if (use_missing) missing = missing * missing_scale endif ! Find out if the Z-axis has an edges attribute call read_attribute(filename, "edges", edge_name, varname=dim_names(3), found=has_edges, ncid_in=ncid) @@ -475,8 +488,12 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z real, dimension(:), intent(out) :: z2 !< Depths of the bottom limit of the part of !! a layer that contributes to a depth level, relative to the cell center and normalized !! by the cell thickness [nondim]. Note that -1/2 <= z1 < z2 <= 1/2. + ! Local variables - real :: Ih, e_c, tot_wt, I_totwt + real :: Ih ! The inverse of the vertical distance across a layer, in the inverse of the units of e [Z-1 ~> m-1] + real :: e_c ! The height of the layer center, in the units of e [Z ~> m] + real :: tot_wt ! The sum of the thicknesses contributing to a layer [Z ~> m] + real :: I_totwt ! The Adcroft reciprocal of tot_wt [Z-1 ~> m-1] integer :: k wt(:) = 0.0 ; z1(:) = 0.0 ; z2(:) = 0.0 ; k_bot = k_max @@ -494,6 +511,7 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z z1(k) = (e_c - MIN(e(K), Z_top)) * Ih z2(k) = (e_c - Z_bot) * Ih else + ! Note that in theis branch, wt temporarily has units of [Z ~> m] wt(k) = MIN(e(K),Z_top) - e(K+1) ; tot_wt = wt(k) ! These are always > 0. if (e(K) /= e(K+1)) then z1(k) = (0.5*(e(K)+e(K+1)) - MIN(e(K), Z_top)) / (e(K)-e(K+1)) @@ -515,6 +533,7 @@ subroutine find_overlap(e, Z_top, Z_bot, k_max, k_start, k_top, k_bot, wt, z1, z enddo I_totwt = 0.0 ; if (tot_wt > 0.0) I_totwt = 1.0 / tot_wt + ! This loop changes the units of wt from [Z ~> m] to [nondim]. do k=k_top,k_bot ; wt(k) = I_totwt*wt(k) ; enddo endif @@ -523,13 +542,13 @@ end subroutine find_overlap !> This subroutine determines a limited slope for val to be advected with !! a piecewise limited scheme. function find_limited_slope(val, e, k) result(slope) - real, dimension(:), intent(in) :: val !< An column the values that are being interpolated. + real, dimension(:), intent(in) :: val !< A column of the values that are being interpolated, in arbitrary units [A] real, dimension(:), intent(in) :: e !< A column's interface heights [Z ~> m] or other units. integer, intent(in) :: k !< The layer whose slope is being determined. - real :: slope !< The normalized slope in the intracell distribution of val. + real :: slope !< The normalized slope in the intracell distribution of val [A] ! Local variables - real :: amn, cmn - real :: d1, d2 + real :: amn, cmn ! Limited differences and curvatures in the values [A] + real :: d1, d2 ! Layer thicknesses, in the units of e [Z ~> m] if ((val(k)-val(k-1)) * (val(k)-val(k+1)) >= 0.0) then slope = 0.0 ! ; curvature = 0.0 From f92e4ac3117bf832d7a6f9b241e3cc084d45b238 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sun, 25 Feb 2024 15:14:33 -0500 Subject: [PATCH 540/629] Update MOM_mixed_layer_restrat.F90 (#568) * Update MOM_mixed_layer_restrat.F90 Adding and calculating diagnostic front length scale (lf_bodner) to mixed layer restratification code Co-authored-by: Kate Hedstrom Co-authored-by: Marshall Ward * Bodner diag: Fix ustar and dims Fix two issues which emerged from the Bodner length scale diagnostic after the cuberoot ANSWER_DATE was introduced. The split of the loop due to the cuberoot caused ustar to be assigned in a separate loop, leaving it uninitialized for the length scale diagnostics loop. It also had its dimensions removed. However, the whole point of the new cuberoot() function was to preserve its dimensions, so there was no need for the intermediate dimensional manipulation, and all dimensionality should be shifted to the registration. This patch removes the intermediate dimensions and also explicitly defines it as Z2/H rather than L. * Bodner diagnostic: Restore scaling to L The scaling of the Bodner lengthscale diagnostic is correctly restored to L in this patch. The Z2 H-1 constant is factored into the calculation of the lengthscale; I believe this represents a conversion from a [Z2 T-2]-like momentum flux to a [LH T-2]-like momentum flux. A generic `uflux_rescale` term was introduced to be used in both ld_bodner and wpup, to avoid a double division by SpV. The if-block for computation of ld_bodner was also moved outside of the loop, in order to facilitate vectorization. --------- Co-authored-by: Liz Drenkard Co-authored-by: Kate Hedstrom --- .../lateral/MOM_mixed_layer_restrat.F90 | 58 ++++++++++++++++--- 1 file changed, 49 insertions(+), 9 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index c10a55309b..0efe322a1d 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -120,6 +120,7 @@ module MOM_mixed_layer_restrat integer :: id_wpup = -1 integer :: id_ustar = -1 integer :: id_bflux = -1 + integer :: id_lfbod = -1 !>@} end type mixedlayer_restrat_CS @@ -807,6 +808,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d wpup ! Turbulent vertical momentum [L H T-2 ~> m2 s-2 or kg m-1 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 :: lf_bodner_diag(SZI_(G),SZJ_(G)) ! Front width as in Bodner et al., 2023 (B22), eq 24 [L ~> m] real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq ! reference density or the time-evolving surface density in non-Boussinesq ! mode [Z T-1 ~> m s-1] @@ -829,6 +831,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d real :: u_star3 ! Cube of surface friction velocity [Z3 T-3 ~> m3 s-3] real :: r_wpup ! reciprocal of vertical momentum flux [T2 L-1 H-1 ~> s2 m-2 or m s2 kg-1] real :: absf ! absolute value of f, interpolated to velocity points [T-1 ~> s-1] + real :: f_h ! Coriolis parameter at h-points [T-1 ~> s-1] + real :: f2_h ! Coriolis parameter at h-points squared [T-2 ~> s-2] + real :: absurdly_small_freq2 ! Frequency squared used to avoid division by 0 [T-2 ~> s-2] real :: grid_dsd ! combination of grid scales [L2 ~> m2] real :: h_sml ! "Little h", the active mixing depth with diurnal cycle removed [H ~> m or kg m-2] real :: h_big ! "Big H", the mixed layer depth based on a time filtered "little h" [H ~> m or kg m-2] @@ -862,6 +867,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d covTS(:) = 0.0 ! Might be in tv% in the future. Not implemented for the time being. varS(:) = 0.0 ! Ditto. + ! This value is roughly (pi / (the age of the universe) )^2. + absurdly_small_freq2 = 1e-34*US%T_to_s**2 + 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: "// & @@ -934,8 +942,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d ! This expression differs by a factor of 1. / (Rho_0 * SpV_avg) compared with the other ! expressions below, and it is invariant to the value of Rho_0 in non-Boussinesq mode. wpup(i,j) = max((cuberoot( CS%mstar * U_star_2d(i,j)**3 + & - CS%nstar * max(0., -bflux(i,j)) * BLD(i,j) ))**2, CS%min_wstar2) * & - ( US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + CS%nstar * max(0., -bflux(i,j)) * BLD(i,j) ))**2, CS%min_wstar2) & + * (US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) ! The final line above converts from [Z2 T-2 ~> m2 s-2] to [L H T-2 ~> m2 s-2 or Pa]. ! Some rescaling factors and the division by specific volume compensating for other ! factors that are in find_ustar_mech, and others effectively converting the wind @@ -952,14 +960,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] u_star3 = U_star_2d(i,j)**3 ! In [Z3 T-3 ~> m3 s-3] wpup(i,j) = max(m2_s2_to_Z2_T2 * (Z3_T3_to_m3_s3 * ( CS%mstar * u_star3 + CS%nstar * w_star3 ) )**two_thirds, & - CS%min_wstar2) * & - ( US%Z_to_L * US%Z_to_m * GV%m_to_H ) ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + CS%min_wstar2) * US%Z_to_L * GV%Z_to_H ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] enddo ; enddo else do j=js-1,je+1 ; do i=is-1,ie+1 w_star3 = max(0., -bflux(i,j)) * BLD(i,j) ! In [Z3 T-3 ~> m3 s-3] - wpup(i,j) = max( (cuberoot(CS%mstar * U_star_2d(i,j)**3 + CS%nstar * w_star3))**2, CS%min_wstar2 ) * & - ( US%Z_to_L * US%Z_to_m * GV%m_to_H ) ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] + wpup(i,j) = max( (cuberoot(CS%mstar * U_star_2d(i,j)**3 + CS%nstar * w_star3))**2, CS%min_wstar2 ) & + * US%Z_to_L * GV%Z_to_H ! In [L H T-2 ~> m2 s-2 or kg m-1 s-2] enddo ; enddo endif @@ -970,6 +977,35 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d CS%wpup_filtered(i,j) = wpup(i,j) enddo ; enddo + if (CS%id_lfbod > 0) then + do j=js-1,je+1 ; do i=is-1,ie+1 + ! Calculate front length used in B22 formula (eq 24). + w_star3 = max(0., -bflux(i,j)) * BLD(i,j) + u_star3 = U_star_2d(i,j)**3 + + ! Include an absurdly_small_freq2 to prevent division by zero. + f_h = 0.25 * ((G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J-1)) & + + (G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J-1))) + f2_h = max(f_h**2, absurdly_small_freq2) + + lf_bodner_diag(i,j) = & + 0.25 * cuberoot(CS%mstar * u_star3 + CS%nstar * w_star3)**2 & + / (f2_h * max(little_h(i,j), GV%Angstrom_H)) + enddo ; enddo + + ! Rescale from [Z2 H-1 to L] + if (allocated(tv%SpV_avg) .and. .not.(GV%Boussinesq .or. GV%semi_Boussinesq)) then + do j=js-1,je+1 ; do i=is-1,ie+1 + lf_bodner_diag(i,j) = lf_bodner_diag(i,j) & + * (US%Z_to_L * GV%RZ_to_H / tv%SpV_avg(i,j,1)) + enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + lf_bodner_diag(i,j) = lf_bodner_diag(i,j) * US%Z_to_L * GV%Z_to_H + enddo ; enddo + endif + endif + if (CS%debug) then call hchksum(little_h,'mle_Bodner: little_h', G%HI, haloshift=1, scale=GV%H_to_mks) call hchksum(big_H,'mle_Bodner: big_H', G%HI, haloshift=1, scale=GV%H_to_mks) @@ -1155,6 +1191,7 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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_lfbod > 0) call post_data(CS%id_lfbod, lf_bodner_diag, CS%diag) if (CS%id_uml > 0) then do J=js,je ; do i=is-1,ie @@ -1776,14 +1813,17 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, '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', & + 'Vertical turbulent momentum flux in Bodner mixed layer restratification parameterization', & 'm2 s-2', conversion=US%L_to_m*GV%H_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', & + 'Surface turbulent friction velocity, u*, in Bodner mixed layer restratification 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', & + 'Surface buoyancy flux, B0, in Bodner mixed layer restratification parameterization', & 'm2 s-3', conversion=(US%Z_to_m**2*US%s_to_T**3)) + CS%id_lfbod = register_diag_field('ocean_model', 'lf_bodner', diag%axesT1, Time, & + 'Front length in Bodner mixed layer restratificiation parameterization', & + 'm', conversion=US%L_to_m) endif ! If MLD_filtered is being used, we need to update halo regions after a restart From 6d7c00a837c0d038beec3a61627221a4863bc47e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 22 Feb 2024 13:11:05 -0500 Subject: [PATCH 541/629] Restore bit repro using FMA in selected runs This patch modifies select calculations of PR#1616 in order to preserve bit reproducibility when FMA optimization is enabled. We add parentheses and reorder terms in selected expressions which either direct or suppress FMAs, ensuring equivalence with the previous release. We address two specific equations in the PR. The first is associated with vertical friction coupling coupling coefficient. The diff is shown below. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear*GV%H_to_Z + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) The denominator is of the form `a*b + c*d`. A compiler may favor an FMA of the form `a*b + (c*d)`. However, the modified equation is of form which favors the `a + c*d` FMA. Each form gives different results in the final bits. We resolve this by expliciting wrapping the RHS in parentheses: a_cpl(i,K) = Kv_tot(i,K) / (h_shear + (I_amax*Kv_tot(i,K))) Although this disables the FMA, it produces the same bit-equivalent answer as the original expression. ---- The second equation for TKE due to kappa shear is shown below. - tke_src = dz_Int(K) *(((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & - (TKE(k) - q0)*TKE_decay(k)) - & + tke_src = h_Int(K) * (dz_h_Int(K)*((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & + (TKE(k) - q0)*TKE_decay(k)) - & ... The outer equation was of the form `b + c` but is promoted to `a*b + c`, transforming it to an FMA. We resolve this by suppressing this FMA optimization: tke_src = h_Int(K) * ((dz_h_Int(K) * ((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K))) - & (TKE(k) - q0)*TKE_decay(k)) - & ... ---- The following two changes are intended to be the smallest modification which preserves answers for known testing on target compilers. It does not encompass all equation changes in this PR. If needed, we could extend these changes to similar modifications of PR#1616. We do not expect to support bit reproducibility when FMAs are enabled. But this is an ongoing conversation, and the rules around FMAs should be expected to change as we learn more and agree on rules of reproducibility. --- src/parameterizations/vertical/MOM_kappa_shear.F90 | 2 +- src/parameterizations/vertical/MOM_vert_friction.F90 | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/vertical/MOM_kappa_shear.F90 b/src/parameterizations/vertical/MOM_kappa_shear.F90 index 81ab0661cc..8a1974d8ea 100644 --- a/src/parameterizations/vertical/MOM_kappa_shear.F90 +++ b/src/parameterizations/vertical/MOM_kappa_shear.F90 @@ -1618,7 +1618,7 @@ subroutine find_kappa_tke(N2, S2, kappa_in, Idz, h_Int, dz_Int, dz_h_Int, I_L2_b ! Solve for dQ(K)... aQ(k) = (0.5*(kappa(K)+kappa(K+1))+kappa0) * Idz(k) dQdz(k) = 0.5*(TKE(K) - TKE(K+1))*Idz(k) - tke_src = h_Int(K) * (dz_h_Int(K)*((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K)) - & + tke_src = h_Int(K) * ((dz_h_Int(K) * ((kappa(K) + kappa0)*S2(K) - kappa(k)*N2(K))) - & (TKE(k) - q0)*TKE_decay(k)) - & (aQ(k) * (TKE(K) - TKE(K+1)) - aQ(k-1) * (TKE(K-1) - TKE(K))) v1 = aQ(k-1) + dQdz(k-1)*dKdQ(K-1) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 8d41fcb63a..ead2cf00cf 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -2116,7 +2116,7 @@ subroutine find_coupling_coef(a_cpl, hvel, do_i, h_harm, bbl_thick, kv_bbl, z_i, endif ! Calculate the coupling coefficients from the viscosities. - a_cpl(i,K) = Kv_tot(i,K) / (h_shear + I_amax*Kv_tot(i,K)) + a_cpl(i,K) = Kv_tot(i,K) / (h_shear + (I_amax * Kv_tot(i,K))) endif ; enddo ; enddo ! i & k loops elseif (abs(CS%Kv_extra_bbl) > 0.0) then ! There is a simple enhancement of the near-bottom viscosities, but no adjustment From f2e7abff8c3604250135df93b18cb38604e64d5b Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Wed, 28 Feb 2024 13:38:36 -0500 Subject: [PATCH 542/629] MLE: Use default answer date outside of block (#570) Inside the `MLE%` ... `%MLE` parameter block, the default answer date was being read while inside the block. Since the namespaces inside blocks are not shared or inherited, this was creating a new parameter, `MLE%DEFAULT_ANSWER_DATE`, whose value differed from the global `DEFAULT_ANSWER_DATE`. This was causing unintuitive behavior of `MLE%ML_RESTRAT_ANSWER_DATE`, which ignored this global answer date. This patch reads `DEFAULT_ANSWER_DATE` outside of the block, so that `ML_RESTRAT_ANSWER_DATE` now defaults to the global value. --- src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 0efe322a1d..057943a788 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1616,6 +1616,9 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, 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, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) 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, & @@ -1657,9 +1660,6 @@ logical function mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, CS, "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, "DEFAULT_ANSWER_DATE", default_answer_date, & - "This sets the default value for the various _ANSWER_DATE parameters.", & - default=99991231) call get_param(param_file, mdl, "ML_RESTRAT_ANSWER_DATE", CS%answer_date, & "The vintage of the order of arithmetic and expressions in the mixed layer "//& "restrat calculations. Values below 20240201 recover the answers from the end "//& From 86c5ed989cb2e7b2719cf6aaaf1a562a28f89e74 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 27 Feb 2024 04:22:17 -0500 Subject: [PATCH 543/629] (*)Fix bug in h_neglect used to remap diags to rho Added explicit names to the h_neglect and h_neglect_edge arguments in a call to build_rho_column in diag_remap_update. These were problematic because these arguments were previously in the wrong positions and hence were being used for the wrong variables inside of build_rho_column. In Boussinesq mode, the results will be the same as long as there is no dimensional rescaling being applied to thicknesses, and it this were being tested it would have resulted in a dimensional consistency test failure. In non-Boussinesq mode, the values of H_subroundoff as used for this coordinate will be off by a factor of RHO_KV_CONVERT (usually 1035), but these thicknesses are so small that they do not matter unless ANGSTROM is explicitly set to zero (when no dimensional rescaling is being used). To summarize, this fixes a bug that has been around since 2017, and while this fix could slightly change some diagnostics that are remapped to density, it only does so in circumstances that are unlikely to have been realized. No answer changes were detected in the MOM6-examples regression suite, and almost certainly none ever would be in any existing use of MOM6. --- src/framework/MOM_diag_remap.F90 | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index a2ecc197bc..0e2e594403 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -326,7 +326,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), h(i,j,:), T(i,j,:), S(i,j,:), & - eqn_of_state, zInterfaces, h_neglect, h_neglect_edge) + eqn_of_state, zInterfaces, h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then ! call build_hycom1_column(remap_cs%regrid_cs, nz, & ! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) From 8f7df084dd8262aebe126db6981abb0ad9c042f1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Jan 2024 06:40:34 -0500 Subject: [PATCH 544/629] (*)non-Boussinesq Z unit update_OBC_segment_data Revised the update_OBC_segment_data code to keep the z-space input data in height units ([Z ~> m]) rather than rescaling them to thickness units. This change means that the non-Boussinesq open boundary condition calculations avoid using the Boussinesq reference density. Associated with this change, 5 internal variables in update_OBC_segment_data were renamed to reflect that they are layer vertical extents instead of thicknesses. Also added or amended comments describing the purpose and units of 25 real variables in this module and corrected a handful of lines in this module that were not adhering to the guidance in the MOM6 style guide. Answers are bitwise identical in any Boussinesq cases. However, answers will change in any non-Boussinesq cases that use open boundary conditions that use time_interp_extrnal to read in Z-space data. --- src/core/MOM_open_boundary.F90 | 250 +++++++++++++++++---------------- 1 file changed, 129 insertions(+), 121 deletions(-) diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 76ac477906..94320a30c7 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -91,28 +91,36 @@ module MOM_open_boundary 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 - !! the internal units of this field - real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces - !! and on the original vertical grid. The values for tracers should - !! have the same units as the field they are being applied to? + !! the internal units of this field. For salinity this would + !! be in units of [S ppt-1 ~> 1] + real, allocatable :: buffer_src(:,:,:) !< buffer for segment data located at cell faces and on + !! the original vertical grid in the internally scaled + !! units for the field in question, such as [L T-1 ~> m s-1] + !! for a velocity or [S ~> ppt] for salinity. integer :: nk_src !< Number of vertical levels in the source data real, allocatable :: dz_src(:,:,:) !< vertical grid cell spacing of the incoming segment - !! data, set in [Z ~> m] then scaled to [H ~> m or kg m-2] - 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 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 - !< the general 1/Lscale_OUT is multiplied by this factor for each tracer + !! data in [Z ~> m]. + real, allocatable :: buffer_dst(:,:,:) !< buffer src data remapped to the target vertical grid + !! in the internally scaled units for the field in + !! question, such as [L T-1 ~> m s-1] for a velocity or + !! [S ~> ppt] for salinity. + real :: value !< A constant value for the inflow concentration if not read + !! from file, in the internal units of a field, such as [S ~> ppt] + !! for salinity. + real :: resrv_lfac_in = 1. !< The reservoir inverse length scale factor for the inward + !! direction per field [nondim]. The general 1/Lscale_in is + !! multiplied by this factor for a specific tracer. + real :: resrv_lfac_out= 1. !< The reservoir inverse length scale factor for the outward + !! direction per field [nondim]. The general 1/Lscale_out is + !! multiplied by this factor for a specific tracer. end type OBC_segment_data_type !> Tracer on OBC segment data structure, for putting into a segment tracer registry. type, public :: OBC_segment_tracer_type real, allocatable :: t(:,:,:) !< tracer concentration array in rescaled units, !! like [S ~> ppt] for salinity. - real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows + real :: OBC_inflow_conc = 0.0 !< tracer concentration for generic inflows in rescaled units, + !! like [S ~> ppt] for salinity. character(len=32) :: name !< tracer name used for error messages type(tracer_type), pointer :: Tr => NULL() !< metadata describing the tracer real, allocatable :: tres(:,:,:) !< tracer reservoir array in rescaled units, @@ -380,7 +388,7 @@ module MOM_open_boundary !> Control structure for open boundaries that read from files. !! Probably lots to update here. type, public :: file_OBC_CS ; private - real :: tide_flow = 3.0e6 !< Placeholder for now... + real :: tide_flow = 3.0e6 !< Placeholder for now..., perhaps in [m3 s-1]? end type file_OBC_CS !> Type to carry something (what??) for the OBC registry. @@ -402,8 +410,8 @@ module MOM_open_boundary character(len=128) :: tracer_name !< tracer name character(len=128) :: tracer_src_file !< tracer source file for BC character(len=128) :: tracer_src_field !< name of the field in source file to extract BC - real :: lfac_in !< multiplicative factor for inbound tracer reservoir length scale - real :: lfac_out !< multiplicative factor for outbound tracer reservoir length scale + real :: lfac_in !< multiplicative factor for inbound tracer reservoir length scale [nondim] + real :: lfac_out !< multiplicative factor for outbound tracer reservoir length scale [nondim] end type external_tracers_segments_props integer :: id_clock_pass !< A CPU time clock @@ -811,7 +819,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) obgc_segments_props_list => OBC%obgc_segments_props !pointer to the head node do m=1,segment%num_fields - if (m .le. num_fields) then + if (m <= num_fields) then !These are tracers with segments specified in MOM6 style override files call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) else @@ -824,8 +832,8 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) segment%field(m)%resrv_lfac_in,segment%field(m)%resrv_lfac_out) !Make sure the obgc tracer is not specified in the MOM6 param file too. do mm=1,num_fields - if(trim(fields(m)) == trim(fields(mm))) then - if(is_root_pe()) & + if (trim(fields(m)) == trim(fields(mm))) then + if (is_root_pe()) & call MOM_error(FATAL,"MOM_open_boundary:initialize_segment_data(): obgc tracer " //trim(fields(m))// & " appears in OBC_SEGMENT_XXX_DATA string in MOM6 param file. This is not supported!") endif @@ -858,24 +866,24 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) call MOM_error(FATAL,'segment data are not on the supergrid') endif - siz2(1)=1 + siz2(1) = 1 if (siz(1)>1) then if (OBC%brushcutter_mode) then - siz2(1)=(siz(1)-1)/2 + siz2(1) = (siz(1)-1)/2 else - siz2(1)=siz(1) + siz2(1) = siz(1) endif endif - siz2(2)=1 + siz2(2) = 1 if (siz(2)>1) then if (OBC%brushcutter_mode) then - siz2(2)=(siz(2)-1)/2 + siz2(2) = (siz(2)-1)/2 else - siz2(2)=siz(2) + siz2(2) = siz(2) endif endif - siz2(3)=siz(3) + siz2(3) = siz(3) if (segment%is_E_or_W) then if (segment%field(m)%name == 'V') then @@ -986,7 +994,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) allocate(segment%field(m)%dz_src(isd:ied,JsdB:JedB,siz(3))) endif endif - segment%field(m)%dz_src(:,:,:)=0.0 + segment%field(m)%dz_src(:,:,:) = 0.0 segment%field(m)%nk_src=siz(3) segment%field(m)%dz_handle = init_external_field(trim(filename), trim(fieldname), & ignore_axis_atts=.true., threading=SINGLE_FILE) @@ -1746,7 +1754,8 @@ subroutine parse_segment_data_str(segment_str, idx, var, value, filename, fieldn character(len=*), intent(out) :: filename !< The name of the input file if using "file" method character(len=*), intent(out) :: fieldname !< The name of the variable in the input file if using !! "file" method - real, optional, intent(out) :: value !< A constant value if using the "value" method + real, optional, intent(out) :: value !< A constant value if using the "value" method in various + !! units but without the internal rescaling [various units] ! Local variables character(len=128) :: word1, word2, word3, method @@ -1814,8 +1823,7 @@ subroutine parse_for_tracer_reservoirs(OBC, PF, use_temperature) ! At this point, just search for TEMP and SALT as tracers 1 and 2. do m=1,num_fields - call parse_segment_data_str(trim(segstr), m, trim(fields(m)), & - value, filename, fieldname) + call parse_segment_data_str(trim(segstr), m, trim(fields(m)), value, filename, fieldname) if (trim(filename) /= 'none') then if (fields(m) == 'TEMP') then if (segment%is_E_or_W_2) then @@ -1877,8 +1885,6 @@ subroutine open_boundary_init(G, GV, US, param_file, OBC, restart_CS) type(MOM_restart_CS), intent(in) :: restart_CS !< Restart structure, data intent(inout) ! Local variables - real :: vel2_rescale ! A rescaling factor for squared velocities from the representation in - ! a restart file to the internal representation in this run. integer :: i, j, k, isd, ied, jsd, jed, nz, m integer :: IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed ; nz = GV%ke @@ -1972,9 +1978,9 @@ end subroutine open_boundary_end !> Sets the slope of bathymetry normal to an open boundary to zero. subroutine open_boundary_impose_normal_slope(OBC, G, depth) - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure - real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(dyn_horgrid_type), intent(in) :: G !< Ocean grid structure + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: depth !< Bathymetry at h-points, in [Z ~> m] or other units ! Local variables integer :: i, j, n type(OBC_segment_type), pointer :: segment => NULL() @@ -3367,11 +3373,11 @@ end subroutine open_boundary_apply_normal_flow !> Applies zero values to 3d u,v fields on OBC segments subroutine open_boundary_zero_normal_flow(OBC, G, GV, u, v) ! Arguments - type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure - type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open boundaries - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open boundaries + type(ocean_OBC_type), pointer :: OBC !< Open boundary control structure + type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), intent(inout) :: u !< u field to update on open boundaries [arbitrary] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), intent(inout) :: v !< v field to update on open boundaries [arbitrary] ! Local variables integer :: i, j, k, n type(OBC_segment_type), pointer :: segment => NULL() @@ -3528,7 +3534,7 @@ subroutine set_tracer_data(OBC, tv, h, G, GV, PF) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure type(ocean_OBC_type), target, intent(in) :: OBC !< Open boundary structure type(thermo_var_ptrs), intent(inout) :: tv !< Thermodynamics structure - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Thickness + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thicknesses [H ~> m or kg m-2] type(param_file_type), intent(in) :: PF !< Parameter file handle type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list @@ -3791,7 +3797,7 @@ subroutine open_boundary_test_extern_h(G, GV, OBC, h) if (.not. associated(OBC)) return - silly_h = GV%Z_to_H * OBC%silly_h + silly_h = GV%Z_to_H * OBC%silly_h ! This rescaling is here because GV was initialized after OBC. do n = 1, OBC%number_of_segments do k = 1, GV%ke @@ -3844,18 +3850,18 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) integer :: ishift, jshift ! offsets for staggered locations real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: dz ! Distance between the interfaces around a layer [Z ~> m] real, dimension(:,:,:), allocatable, target :: tmp_buffer ! A buffer for input data [various units] - real, dimension(:), allocatable :: h_stack ! Thicknesses at corner points [H ~> m or kg m-2] + real, dimension(:), allocatable :: dz_stack ! Distance between the interfaces at corner points [Z ~> m] integer :: is_obc2, js_obc2 integer :: i_seg_offset, j_seg_offset - real :: net_H_src ! Total thickness of the incoming flow in the source field [H ~> m or kg m-2] - real :: net_H_int ! Total thickness of the incoming flow in the model [H ~> m or kg m-2] + real :: net_dz_src ! Total vertical extent of the incoming flow in the source field [Z ~> m] + real :: net_dz_int ! Total vertical extent of the incoming flow in the model [Z ~> m] real :: scl_fac ! A scaling factor to compensate for differences in total thicknesses [nondim] real :: tidal_vel ! Interpolated tidal velocity at the OBC points [L T-1 ~> m s-1] real :: tidal_elev ! Interpolated tidal elevation at the OBC points [Z ~> m] real, allocatable :: normal_trans_bt(:,:) ! barotropic transport [H L2 T-1 ~> m3 s-1] integer :: turns ! Number of index quarter turns real :: time_delta ! Time since tidal reference date [T ~> s] - real :: h_neglect, h_neglect_edge ! Small thicknesses [H ~> m or kg m-2] + real :: dz_neglect, dz_neglect_edge ! Small thicknesses [Z ~> m] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -3868,12 +3874,12 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (OBC%add_tide_constituents) time_delta = US%s_to_T * time_type_to_real(Time - OBC%time_ref) - if (OBC%remap_answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H * 1.0e-30 ; h_neglect_edge = GV%m_to_H * 1.0e-10 + if (GV%Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = US%m_to_Z * 1.0e-30 ; dz_neglect_edge = US%m_to_Z * 1.0e-10 + elseif (GV%semi_Boussinesq .and. (OBC%remap_answer_date < 20190101)) then + dz_neglect = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-30 ; dz_neglect_edge = GV%kg_m2_to_H*GV%H_to_Z * 1.0e-10 else - h_neglect = GV%kg_m2_to_H * 1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H * 1.0e-10 + dz_neglect = GV%dZ_subroundoff ; dz_neglect_edge = GV%dZ_subroundoff endif if (OBC%number_of_segments >= 1) then @@ -3937,16 +3943,16 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) enddo endif - allocate(h_stack(GV%ke), source=0.0) + allocate(dz_stack(GV%ke), source=0.0) do m = 1,segment%num_fields !This field may not require a high frequency OBC segment update and might be allowed !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)%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) + 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) if (.not.allocated(segment%field(m)%buffer_dst)) then if (siz(3) /= segment%field(m)%nk_src) call MOM_error(FATAL,'nk_src inconsistency') if (segment%field(m)%nk_src > 1) then @@ -3990,7 +3996,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif endif - segment%field(m)%buffer_dst(:,:,:)=0.0 + segment%field(m)%buffer_dst(:,:,:) = 0.0 endif ! read source data interpolated to the current model time ! NOTE: buffer is sized for vertex points, but may be used for faces @@ -4149,6 +4155,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif endif + ! The units of ...%dz_src are no longer changed from [Z ~> m] to [H ~> m or kg m-2] here. call adjustSegmentEtaToFitBathymetry(G,GV,US,segment,m) if (segment%is_E_or_W) then @@ -4160,44 +4167,44 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) do J=max(js_obc,jsd),min(je_obc,jed-1) ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0. .and. G%mask2dCu(I,j+1)>0.) then - h_stack(:) = 0.5*(h(i+ishift,j,:) + h(i+ishift,j+1,:)) + dz_stack(:) = 0.5*(dz(i+ishift,j,:) + dz(i+ishift,j+1,:)) call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) elseif (G%mask2dCu(I,j)>0.) then - h_stack(:) = h(i+ishift,j,:) + dz_stack(:) = dz(i+ishift,j,:) call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) elseif (G%mask2dCu(I,j+1)>0.) then - h_stack(:) = h(i+ishift,j+1,:) + dz_stack(:) = dz(i+ishift,j+1,:) call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,j,:), & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) endif enddo else do j=js_obc+1,je_obc ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(I,j,:)=0.0 ! initialize remap destination buffer + segment%field(m)%buffer_dst(I,j,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCu(I,j)>0.) then - net_H_src = sum( segment%field(m)%dz_src(I,j,:) ) - net_H_int = sum( h(i+ishift,j,:) ) - scl_fac = net_H_int / net_H_src + net_dz_src = sum( segment%field(m)%dz_src(I,j,:) ) + net_dz_int = sum( dz(i+ishift,j,:) ) + scl_fac = net_dz_int / net_dz_src call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & + segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(I,j,:), & segment%field(m)%buffer_src(I,j,:), & - GV%ke, h(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & - h_neglect, h_neglect_edge) + GV%ke, dz(i+ishift,j,:), segment%field(m)%buffer_dst(I,j,:), & + dz_neglect, dz_neglect_edge) endif enddo endif @@ -4208,46 +4215,46 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) if (segment%field(m)%name == 'U' .or. segment%field(m)%name == 'DUDY') then ! Do q points for the whole segment do I=max(is_obc,isd),min(ie_obc,ied-1) - segment%field(m)%buffer_dst(I,J,:)=0.0 ! initialize remap destination buffer + segment%field(m)%buffer_dst(I,J,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCv(i,J)>0. .and. G%mask2dCv(i+1,J)>0.) then ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - h_stack(:) = 0.5*(h(i,j+jshift,:) + h(i+1,j+jshift,:)) + dz_stack(:) = 0.5*(dz(i,j+jshift,:) + dz(i+1,j+jshift,:)) call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) elseif (G%mask2dCv(i,J)>0.) then - h_stack(:) = h(i,j+jshift,:) + dz_stack(:) = dz(i,j+jshift,:) call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) elseif (G%mask2dCv(i+1,J)>0.) then - h_stack(:) = h(i+1,j+jshift,:) + dz_stack(:) = dz(i+1,j+jshift,:) call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src,segment%field(m)%dz_src(I,J,:), & + segment%field(m)%nk_src, segment%field(m)%dz_src(I,J,:), & segment%field(m)%buffer_src(I,J,:), & - GV%ke, h_stack, segment%field(m)%buffer_dst(I,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz_stack, segment%field(m)%buffer_dst(I,J,:), & + dz_neglect, dz_neglect_edge) endif enddo else do i=is_obc+1,ie_obc ! Using the h remapping approach ! Pretty sure we need to check for source/target grid consistency here - segment%field(m)%buffer_dst(i,J,:)=0.0 ! initialize remap destination buffer + segment%field(m)%buffer_dst(i,J,:) = 0.0 ! initialize remap destination buffer if (G%mask2dCv(i,J)>0.) then - net_H_src = sum( segment%field(m)%dz_src(i,J,:) ) - net_H_int = sum( h(i,j+jshift,:) ) - scl_fac = net_H_int / net_H_src + net_dz_src = sum( segment%field(m)%dz_src(i,J,:) ) + net_dz_int = sum( dz(i,j+jshift,:) ) + scl_fac = net_dz_int / net_dz_src call remapping_core_h(OBC%remap_CS, & - segment%field(m)%nk_src, scl_fac*segment%field(m)%dz_src(i,J,:), & + segment%field(m)%nk_src, scl_fac* segment%field(m)%dz_src(i,J,:), & segment%field(m)%buffer_src(i,J,:), & - GV%ke, h(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & - h_neglect, h_neglect_edge) + GV%ke, dz(i,j+jshift,:), segment%field(m)%buffer_dst(i,J,:), & + dz_neglect, dz_neglect_edge) endif enddo endif @@ -4496,7 +4503,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif elseif (trim(segment%field(m)%genre) == 'obgc') then nt=get_tracer_index(segment,trim(segment%field(m)%name)) - if(nt .lt. 0) then + if (nt < 0) then call MOM_error(FATAL,"update_OBC_segment_data: Did not find tracer "//trim(segment%field(m)%name)) endif if (allocated(segment%field(m)%buffer_dst)) then @@ -4516,7 +4523,7 @@ subroutine update_OBC_segment_data(G, GV, US, OBC, tv, h, Time) endif enddo ! end field loop - deallocate(h_stack) + deallocate(dz_stack) deallocate(normal_trans_bt) enddo ! end segment loop @@ -4698,16 +4705,19 @@ subroutine register_segment_tracer(tr_ptr, ntr_index, param_file, GV, segment, & type(OBC_segment_type), intent(inout) :: segment !< current segment data structure real, optional, intent(in) :: OBC_scalar !< If present, use scalar value for segment tracer !! inflow concentration, including any rescaling to - !! put the tracer concentration into its internal units. + !! put the tracer concentration into its internal units, + !! like [S ~> ppt] for salinity. logical, optional, intent(in) :: OBC_array !< If true, use array values for segment tracer !! inflow concentration. real, optional, intent(in) :: scale !< A scaling factor that should be used with any - !! data that is read in, to convert it to the internal - !! units of this tracer. + !! data that is read in to convert it to the internal + !! units of this tracer, in units like [S ppt-1 ~> 1] + !! for salinity. integer, optional, intent(in) :: fd_index !< index of segment tracer in the input field ! Local variables - real :: rescale ! A multiplicative correction to the scaling factor. + real :: rescale ! A multiplicatively corrected scaling factor, in units like [S ppt-1 ~> 1] for + ! salinity, or other various units depending on what rescaling has occurred previously. integer :: ntseg, m, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB character(len=256) :: mesg ! Message for error messages. @@ -4824,8 +4834,8 @@ subroutine set_obgc_segments_props(OBC,tr_name,obc_src_file_name,obc_src_field_n character(len=*), intent(in) :: tr_name !< Tracer name character(len=*), intent(in) :: obc_src_file_name !< OBC source file name character(len=*), intent(in) :: obc_src_field_name !< name of the field in the source file - real, intent(in) :: lfac_in !< factors for tracer reservoir length scales - real, intent(in) :: lfac_out !< factors for tracer reservoir length scales + real, intent(in) :: lfac_in !< factors for tracer reservoir inbound length scales [nondim] + real, intent(in) :: lfac_out !< factors for tracer reservoir outbound length scales [nondim] type(external_tracers_segments_props),pointer :: node_ptr => NULL() !pointer to type that keeps ! the tracer segment properties @@ -4848,8 +4858,8 @@ subroutine get_obgc_segments_props(node, tr_name,obc_src_file_name,obc_src_field character(len=*), intent(out) :: tr_name !< Tracer name character(len=*), intent(out) :: obc_src_file_name !< OBC source file name character(len=*), intent(out) :: obc_src_field_name !< name of the field in the source file - real, intent(out) :: lfac_in !< multiplicative factor for inbound reservoir length scale - real, intent(out) :: lfac_out !< multiplicative factor for outbound reservoir length scale + real, intent(out) :: lfac_in !< multiplicative factor for inbound reservoir length scale [nondim] + real, intent(out) :: lfac_out !< multiplicative factor for outbound reservoir length scale [nondim] tr_name = trim(node%tracer_name) obc_src_file_name = trim(node%tracer_src_file) obc_src_field_name = trim(node%tracer_src_field) @@ -4890,13 +4900,14 @@ subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(ocean_OBC_type), pointer :: OBC !< Open boundary structure - real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field - character(len=*), intent(in) :: tr_name!< Tracer name + real, dimension(:,:,:), pointer :: tr_ptr !< Pointer to tracer field in scaled concentration + !! units, like [S ~> ppt] for salinity. + character(len=*), intent(in) :: tr_name !< Tracer name ! Local variables integer :: isd, ied, IsdB, IedB, jsd, jed, JsdB, JedB, n, nz, nt integer :: i, j, k type(OBC_segment_type), pointer :: segment => NULL() ! pointer to segment type list - real :: I_scale + real :: I_scale ! A factor that unscales the internal units of a tracer, like [ppt S-1 ~> 1] for salinity if (.not. associated(OBC)) return call pass_var(tr_ptr, G%Domain) @@ -4905,7 +4916,7 @@ subroutine fill_obgc_segments(G, GV, OBC, tr_ptr, tr_name) segment => OBC%segment(n) if (.not. segment%on_pe) cycle nt=get_tracer_index(segment,tr_name) - if(nt .lt. 0) then + if (nt < 0) then call MOM_error(FATAL,"fill_obgc_segments: Did not find tracer "// tr_name) endif isd = segment%HI%isd ; ied = segment%HI%ied @@ -5414,7 +5425,7 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index fd_id = segment%tr_reg%Tr(m)%fd_index - if(fd_id == -1) then + if (fd_id == -1) then resrv_lfac_out = 1.0 resrv_lfac_in = 1.0 else @@ -5458,7 +5469,7 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) do m=1,segment%tr_Reg%ntseg ntr_id = segment%tr_reg%Tr(m)%ntr_index fd_id = segment%tr_reg%Tr(m)%fd_index - if(fd_id == -1) then + if (fd_id == -1) then resrv_lfac_out = 1.0 resrv_lfac_in = 1.0 else @@ -5500,7 +5511,8 @@ subroutine remap_OBC_fields(G, GV, h_old, h_new, OBC, PCM_cell) ! Local variables type(OBC_segment_type), pointer :: segment => NULL() ! A pointer to the various segments, used just for shorthand. - real :: tr_column(GV%ke) ! A column of updated tracer concentrations [CU ~> Conc] + real :: tr_column(GV%ke) ! A column of updated tracer concentrations in internally scaled units. + ! For salinity the units would be [S ~> ppt]. real :: r_norm_col(GV%ke) ! A column of updated radiation rates, in grid points per timestep [nondim] real :: rxy_col(GV%ke) ! A column of updated radiation rates for oblique OBCs [L2 T-2 ~> m2 s-2] real :: h1(GV%ke) ! A column of source grid layer thicknesses [H ~> m or kg m-2] @@ -5706,14 +5718,14 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) allocate(eta(is:ie,js:je,nz+1)) contractions=0; dilations=0 do j=js,je ; do i=is,ie - eta(i,j,1)=0.0 ! segment data are assumed to be located on a static grid + eta(i,j,1) = 0.0 ! segment data are assumed to be located on a static grid ! For remapping calls, the entire column will be dilated ! by a factor equal to the ratio of the sum of the geopotential referenced ! source data thicknesses, and the current model thicknesses. This could be ! an issue to be addressed, for instance if we are placing open boundaries ! under ice shelf cavities. do k=2,nz+1 - eta(i,j,k)=eta(i,j,k-1)-segment%field(fld)%dz_src(i,j,k-1) + eta(i,j,k) = eta(i,j,k-1) - segment%field(fld)%dz_src(i,j,k-1) enddo ! The normal slope at the boundary is zero by a ! previous call to open_boundary_impose_normal_slope @@ -5741,7 +5753,7 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) dilations = dilations + 1 ! expand bottom-most cell only eta(i,j,nz+1) = -segment%dZtot(i,j) - segment%field(fld)%dz_src(i,j,nz)= eta(i,j,nz)-eta(i,j,nz+1) + segment%field(fld)%dz_src(i,j,nz) = eta(i,j,nz) - eta(i,j,nz+1) ! if (eta(i,j,1) <= eta(i,j,nz+1)) then ! do k=1,nz ; segment%field(fld)%dz_src(i,j,k) = (eta(i,j,1) + G%bathyT(i,j)) / real(nz) ; enddo ! else @@ -5750,10 +5762,6 @@ subroutine adjustSegmentEtaToFitBathymetry(G, GV, US, segment,fld) ! endif !do k=nz,2,-1 ; eta(i,j,K) = eta(i,j,K+1) + segment%field(fld)%dz_src(i,j,k) ; enddo endif - ! Now convert thicknesses to units of H. - do k=1,nz - segment%field(fld)%dz_src(i,j,k) = segment%field(fld)%dz_src(i,j,k)*GV%Z_to_H - enddo enddo ; enddo ! can not do communication call here since only PEs on the current segment are here From 39368f04da0286d72ce7d3fc454ee61dea21f1fa Mon Sep 17 00:00:00 2001 From: Gustavo Marques Date: Thu, 29 Feb 2024 11:36:09 -0700 Subject: [PATCH 545/629] Remove extra & from u/v_smooth --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 825e1f91c9..9b1d81348e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -353,9 +353,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, 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] real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: & - u_smooth, & ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + u_smooth ! Zonal velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & - v_smooth, & ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] + v_smooth ! Meridional velocity, smoothed with a spatial low-pass filter [L T-1 ~> m s-1] real :: AhSm ! Smagorinsky biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLth ! 2D Leith biharmonic viscosity [L4 T-1 ~> m4 s-1] real :: AhLthy ! 2D Leith+E biharmonic viscosity [L4 T-1 ~> m4 s-1] From d0e9c25a08db5ddf1e13f0b875f26259095e3d31 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Jan 2024 11:28:21 -0500 Subject: [PATCH 546/629] *Corrected CFC diagnostics and non-Bous CFC fluxes Removed the duplicative multiplication by the Boussinesq density and related unit conversion factors in the calculation of the diagnosed mole concentration of the "cfc11" and "cfc12" diagnostics. This unit rescaling is duplicative of the conversion factors in the register_diag_field calls for these diagnostics (at about line 263). This will change these two diagnostics by a factor of RHO_0. This bug arose from separate and independent changes coming from GFDL and NCAR to add the same missing rescaling factor, and it might have gone undetected because of the vast range of valid values for CFC concentrations or because all of our regression testing uses calendar dates that precede the invention and first release of CFCs in the 1930s. Although this commit will correct the code that is on the dev/gfdl branch, care will have to be taken when merging in modified versions of this file from other branches that might have also corrected this bug to avoid reintroducing it (perhaps in reverse). Also replaced the expression for the CFC flux rescaling factor for use with KPP_NonLocalTransport with GV%RZ_to_H, which is equivalent to the previous expression in Boussinesq mode but avoids a multiplication and division by the Boussinesq reference density in non-Boussinesq mode. All Boussinesq answers are identical, but some non-Boussinesq CFCs could be altered in the last bits. This PR will change diagnostics of CFC concentrations by about 3 orders of magnitude. The internal representation of the CFCs is bitwise identical in all Boussinesq cases, but they may change at roundoff in non-Boussinesq cases that use KPP. --- src/tracer/MOM_CFC_cap.F90 | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 16506b41c3..489948a63c 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -361,7 +361,6 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Local variables real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] - real :: flux_scale ! A dimensional rescaling factor for fluxes [H R-1 Z-1 ~> m3 kg-1 or nondim] integer :: i, j, k, is, ie, js, je, nz, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -371,13 +370,11 @@ subroutine CFC_cap_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, C ! Compute KPP nonlocal term if necessary if (present(KPP_CSp)) then if (associated(KPP_CSp) .and. present(nonLocalTrans)) then - flux_scale = GV%Z_to_H / GV%rho0 - do m=1,NTR call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, & CS%CFC_data(m)%sfc_flux(:,:), dt, CS%diag, & CS%CFC_data(m)%tr_ptr, CS%CFC_data(m)%conc(:,:,:), & - flux_scale=flux_scale) + flux_scale=GV%RZ_to_H) enddo endif endif From fd5696ba07d81c9841c7710de4dd7553ca22ee84 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 29 Feb 2024 12:05:59 -0500 Subject: [PATCH 547/629] Pinning package requirements for readthedocs Minor version updates to multiple packages used in the generation of the documentation introduce dependencies needing Sphinx >= 5.0, which breaks the sphinx extensions we use in documenting the MOM6 APIs. I have added versions for all the packages needed to keep things working with Sphinx4 for now, but we really do need to find a way to work with the newer versions. More pinningaof of requirements for readthedocs More pinning of requirements for readthedocs --- docs/requirements.txt | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/docs/requirements.txt b/docs/requirements.txt index ff627c61c7..b38dbc34b7 100644 --- a/docs/requirements.txt +++ b/docs/requirements.txt @@ -10,3 +10,9 @@ six future # Old Sphinx requires an old Jinja2 jinja2<3.1 +sphinxcontrib_applehelp<1.0.8 +sphinxcontrib_devhelp<1.0.6 +sphinxcontrib_htmlhelp<2.0.5 +sphinxcontrib_qthelp<1.0.7 +sphinxcontrib_serializinghtml<1.0.7 +alabaster<0.7.14 From f9da6733155d60b152ae9df35b028a093b341ad2 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 16 Jan 2024 16:21:40 -0500 Subject: [PATCH 548/629] Create BUILD and WORK directory macros This patch introduces two new macros, BUILD and WORK, to permit relocation of the build/ and work/ directories. It also makes the following smaller changes: * deps/ is now defined by the DEPS macro. If unset, deps/ is placed in the BUILD directory. * results/ is moved into WORK. * Compiler flags which track directories now use $(abspath ...) to allow for arbitrary paths. * GitHub CI paths were adjusted to support these new settings. * DO_* flags are now used as on/off with ifdef testing, rather than checking for `true` values. * mkmf macros have been removed from the coupled test config. * The default FMS infra has been changed to FMS2 in all components, including the configure.ac outside of .testing. This work will enable testing of multiple FMS libraries in our CI. --- .github/actions/testing-setup/action.yml | 2 +- .testing/Makefile | 456 ++++++++++++----------- ac/configure.ac | 4 +- 3 files changed, 244 insertions(+), 218 deletions(-) diff --git a/.github/actions/testing-setup/action.yml b/.github/actions/testing-setup/action.yml index a15dd6d0a2..60499d4be1 100644 --- a/.github/actions/testing-setup/action.yml +++ b/.github/actions/testing-setup/action.yml @@ -28,7 +28,7 @@ runs: run: | echo "::group::Compile FMS library" cd .testing - REPORT_ERROR_LOGS=true make deps/lib/libFMS.a -s -j + REPORT_ERROR_LOGS=true make build/deps/lib/libFMS.a -s -j echo "::endgroup::" - name: Compile MOM6 in symmetric memory mode diff --git a/.testing/Makefile b/.testing/Makefile index f7101a3463..a1461fe7ab 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -46,10 +46,10 @@ # LDFLAGS_USER User-defined linker flags (used for all MOM/FMS builds) # # Experiment Configuration: -# BUILDS Executables to be built by `make` or `make all` +# EXECS Executables to be built by `make` or `make all` # CONFIGS Model configurations to test (default: `tc*`) -# TESTS Tests to run # DIMS Dimensional scaling tests +# TESTS Tests to run # # Regression repository ("target") configuration: # MOM_TARGET_SLUG URL slug (minus domain) of the target repo @@ -57,19 +57,19 @@ # MOM_TARGET_LOCAL_BRANCH Target branch name # (NOTE: These would typically be configured by a CI.) # -# Paths for stages: -# WORKSPACE Location to place work/ and results/ directories (i.e. where to run the model) -# -#---- +# Output paths: +# BUILD Compiled executables and libraries +# DEPS Compiled dependencies +# WORK Test model output # TODO: POSIX shell compatibility SHELL = bash -# No implicit rules -.SUFFIXES: +# No implicit rules, suffixes, or variables +MAKEFLAGS += -rR -# No implicit variables -MAKEFLAGS += -R +# Determine the MOM6 autoconf srcdir +AC_SRCDIR := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))../ac # User-defined configuration -include config.mk @@ -104,10 +104,7 @@ FCFLAGS_FMS ?= $(FCFLAGS_DEBUG) LDFLAGS_COVERAGE ?= --coverage LDFLAGS_USER ?= -# Set to `true` to require identical results from DEBUG and REPRO builds -# NOTE: Many compilers (Intel, GCC on ARM64) do not produce identical results -# across DEBUG and REPRO builds (as defined below), so we disable on -# default. +# Set to verify identical DEBUG and REPRO results DO_REPRO_TESTS ?= # Enable profiling @@ -116,9 +113,12 @@ DO_PROFILE ?= # Enable code coverage runs DO_COVERAGE ?= -# Enable code coverage runs +# Enable unit tests DO_UNIT_TESTS ?= +# Check for regressions with target branch +DO_REGRESSION_TESTS ?= + # Report failure if coverage report is not uploaded REQUIRE_COVERAGE_UPLOAD ?= @@ -128,52 +128,69 @@ REPORT_ERROR_LOGS ?= # Time measurement (configurable by the CI) TIME ?= time +# Legacy external work directory +#WORKSPACE ?= +WORKSPACE ?= . + +# Set directories for build/ and work/ +#BUILD ?= $(WORKSPACE)build +#DEPS ?= $(BUILD)/deps +#WORK ?= $(WORKSPACE)work +BUILD ?= $(WORKSPACE)/build +DEPS ?= $(BUILD)/deps +WORK ?= $(WORKSPACE)/work # Experiment configuration -BUILDS ?= symmetric/MOM6 asymmetric/MOM6 openmp/MOM6 +EXECS ?= symmetric/MOM6 asymmetric/MOM6 openmp/MOM6 CONFIGS ?= $(wildcard tc*) -TESTS ?= grid layout rotate restart openmp nan $(foreach d,$(DIMS),dim.$(d)) DIMS ?= t l h z q r +TESTS ?= grid layout rotate restart openmp nan $(foreach d,$(DIMS),dim.$(d)) + +# Unit test executables +UNIT_EXECS ?= \ + $(basename $(notdir $(wildcard ../config_src/drivers/unit_tests/*.F90))) + +# Timing test executables +TIMING_EXECS ?= \ + $(basename $(notdir $(wildcard ../config_src/drivers/timing_tests/*.F90))) -# Default is to place work/ and results/ in current directory -WORKSPACE ?= . #--- # Test configuration -# REPRO tests enable reproducibility with optimization, and often do not match -# the DEBUG results in older GCCs and vendor compilers, so we can optionally -# disable them. -ifeq ($(DO_REPRO_TESTS), true) - BUILDS += repro/MOM6 +# Set if either DO_COVERAGE or DO_UNIT_TESTS is set +run_unit_tests = + +# REPRO and DEBUG equivalence +ifdef DO_REPRO_TESTS + EXECS += repro/MOM6 TESTS += repro endif # Profiling -ifeq ($(DO_PROFILE), true) - BUILDS += opt/MOM6 opt_target/MOM6 +ifdef DO_PROFILE + EXECS += opt/MOM6 opt_target/MOM6 endif # Coverage -ifeq ($(DO_COVERAGE), true) - BUILDS += cov/MOM6 +ifdef DO_COVERAGE + EXECS += cov/MOM6 + run_unit_execs = yes endif -# Unit testing (or coverage) -UNIT_EXECS ?= $(basename $(notdir $(wildcard ../config_src/drivers/unit_tests/*.F90) ) ) -TIMING_EXECS ?= $(basename $(notdir $(wildcard ../config_src/drivers/timing_tests/*.F90) ) ) -ifneq (X$(DO_COVERAGE)$(DO_UNIT_TESTS)X, XX) - BUILDS += $(foreach e, $(UNIT_EXECS), unit/$(e)) +# Unit test executables +ifdef DO_UNIT_TESTS + run_unit_tests = yes endif -ifeq ($(DO_PROFILE), false) - BUILDS += opt/MOM6 opt_target/MOM6 +# If either coverage or unit tests are enabled, build the unit test execs +ifdef run_unit_tests + EXECS += $(foreach e, $(UNIT_EXECS), unit/$(e)) endif - -DO_REGRESSION_TESTS ?= -ifeq ($(DO_REGRESSION_TESTS), true) - BUILDS += target/MOM6 +# Regression testing +ifdef DO_REGRESSION_TESTS + EXECS += target/MOM6 TESTS += regression MOM_TARGET_SLUG ?= NOAA-GFDL/MOM6 @@ -182,13 +199,14 @@ ifeq ($(DO_REGRESSION_TESTS), true) MOM_TARGET_LOCAL_BRANCH ?= dev/gfdl MOM_TARGET_BRANCH := origin/$(MOM_TARGET_LOCAL_BRANCH) - TARGET_CODEBASE = build/target_codebase + TARGET_CODEBASE = $(BUILD)/target_codebase else MOM_TARGET_URL = MOM_TARGET_BRANCH = TARGET_CODEBASE = endif + # List of source files to link this Makefile's dependencies to model Makefiles # Assumes a depth of two, and the following extensions: F90 inc c h # (1): Root directory @@ -202,31 +220,30 @@ MOM_SOURCE = \ $(wildcard ../config_src/ext*/*/*.F90) TARGET_SOURCE = \ - $(call SOURCE,build/target_codebase/src) \ - $(wildcard build/target_codebase/config_src/drivers/solo_driver/*.F90) \ - $(wildcard build/target_codebase/config_src/ext*/*.F90) + $(call SOURCE,$(BUILD)/target_codebase/src) \ + $(wildcard $(BUILD)/target_codebase/config_src/drivers/solo_driver/*.F90) \ + $(wildcard $(BUILD)target_codebase/config_src/ext*/*.F90) -# NOTE: Current default framework is FMS1, but this could change. -ifeq ($(FRAMEWORK), fms2) - MOM_SOURCE +=$(wildcard ../config_src/infra/FMS2/*.F90) - TARGET_SOURCE += $(wildcard build/target_codebase/config_src/infra/FMS2/*.F90) -else +ifeq ($(FRAMEWORK), fms1) MOM_SOURCE += $(wildcard ../config_src/infra/FMS1/*.F90) - TARGET_SOURCE += $(wildcard build/target_codebase/config_src/infra/FMS1/*.F90) + TARGET_SOURCE += $(wildcard $(BUILD)/target_codebase/config_src/infra/FMS1/*.F90) +else + MOM_SOURCE +=$(wildcard ../config_src/infra/FMS2/*.F90) + TARGET_SOURCE += $(wildcard $(BUILD)/target_codebase/config_src/infra/FMS2/*.F90) endif -FMS_SOURCE = $(call SOURCE,deps/fms/src) +FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) -#--- -# Rules + +## Rules .PHONY: all build.regressions build.prof -all: $(foreach b,$(BUILDS),build/$(b)) -build.regressions: $(foreach b,symmetric target,build/$(b)/MOM6) -build.prof: $(foreach b,opt opt_target,build/$(b)/MOM6) +all: $(foreach b,$(EXECS),$(BUILD)/$(b)) +build.regressions: $(foreach b,symmetric target,$(BUILD)/$(b)/MOM6) +build.prof: $(foreach b,opt opt_target,$(BUILD)/$(b)/MOM6) # Executable -.PRECIOUS: $(foreach b,$(BUILDS),build/$(b)) +.PRECIOUS: $(foreach b,$(EXECS),$(BUILD)/$(b)) # Compiler flags @@ -234,9 +251,9 @@ build.prof: $(foreach b,opt opt_target,build/$(b)/MOM6) # .testing dependencies # TODO: We should probably build TARGET with the FMS that it was configured # to use. But for now we use the same FMS over all builds. -FCFLAGS_DEPS = -I../../deps/include -LDFLAGS_DEPS = -L../../deps/lib -PATH_DEPS = PATH="${PATH}:../../deps/bin" +FCFLAGS_DEPS = -I$(abspath $(DEPS)/include) +LDFLAGS_DEPS = -L$(abspath $(DEPS)/lib) +PATH_DEPS = PATH="${PATH}:$(abspath $(DEPS)/bin)" # Define the build targets in terms of the traditional DEBUG/REPRO/etc labels @@ -254,82 +271,96 @@ COV_LDFLAGS := LDFLAGS="$(LDFLAGS_COVERAGE) $(LDFLAGS_DEPS) $(LDFLAGS_USER)" # Environment variable configuration MOM_ENV := $(PATH_FMS) -build/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/asymmetric/Makefile: MOM_ENV += $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ - MOM_MEMORY=../../../config_src/memory/dynamic_nonsymmetric/MOM_memory.h -build/repro/Makefile: MOM_ENV += $(REPRO_FCFLAGS) $(MOM_LDFLAGS) -build/openmp/Makefile: MOM_ENV += $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) -build/target/Makefile: MOM_ENV += $(TARGET_FCFLAGS) $(MOM_LDFLAGS) -build/opt/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/opt_target/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) -build/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) -build/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) -build/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) -build/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/symmetric/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/asymmetric/Makefile: MOM_ENV += $(ASYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) \ + MOM_MEMORY=$(AC_SRCDIR)/../config_src/memory/dynamic_nonsymmetric/MOM_memory.h +$(BUILD)/repro/Makefile: MOM_ENV += $(REPRO_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/openmp/Makefile: MOM_ENV += $(OPENMP_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/target/Makefile: MOM_ENV += $(TARGET_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/opt/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/opt_target/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/coupled/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/nuopc/Makefile: MOM_ENV += $(SYMMETRIC_FCFLAGS) $(MOM_LDFLAGS) +$(BUILD)/cov/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +$(BUILD)/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) +$(BUILD)/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) # Configure script flags MOM_ACFLAGS := --with-framework=$(FRAMEWORK) -build/openmp/Makefile: MOM_ACFLAGS += --enable-openmp -build/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap -build/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap -build/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests -build/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests - -# Fetch regression target source code -build/target/Makefile: | $(TARGET_CODEBASE) -build/opt_target/Makefile: | $(TARGET_CODEBASE) - - -# Define source code dependencies -build/target_codebase/configure: $(TARGET_SOURCE) +$(BUILD)/openmp/Makefile: MOM_ACFLAGS += --enable-openmp +$(BUILD)/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap +$(BUILD)/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap +$(BUILD)/unit/Makefile: MOM_ACFLAGS += --with-driver=unit_tests +$(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests # Build executables -build/unit/test_%: build/unit/Makefile FORCE +$(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j -build/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) -build/timing/time_%: build/timing/Makefile FORCE +$(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) +$(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j -build/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) -build/%/MOM6: build/%/Makefile FORCE +$(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) +$(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j -FORCE: ; +FORCE: -# Use autoconf to construct the Makefile for each target -.PRECIOUS: build/%/Makefile -build/%/Makefile: ../ac/configure ../ac/Makefile.in deps/lib/libFMS.a - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../../ac/configure $(MOM_ACFLAGS) \ - || (cat config.log && false) +## Use autoconf to construct the Makefile for each target +# TODO: This could all be moved to a top-level MOM6 Makefile +.PRECIOUS: $(BUILD)/%/Makefile +.PRECIOUS: $(BUILD)/%/Makefile.in +.PRECIOUS: $(BUILD)/%/configure +.PRECIOUS: $(BUILD)/%/config.status +.PRECIOUS: $(BUILD)/%/configure.ac +.PRECIOUS: $(BUILD)/%/m4/ +$(BUILD)/%/Makefile: $(BUILD)/%/Makefile.in $(BUILD)/%/config.status + cd $(@D) && ./config.status -../ac/configure: ../ac/configure.ac ../ac/m4 - autoreconf -i $< +$(BUILD)/%/config.status: $(BUILD)/%/configure $(DEPS)/lib/libFMS.a + cd $(@D) && $(MOM_ENV) ./configure -n --srcdir=$(AC_SRCDIR) $(MOM_ACFLAGS) \ + || (cat config.log && false) +$(BUILD)/%/Makefile.in: ../ac/Makefile.in | $(BUILD)/%/ + cp ../ac/Makefile.in $(@D) + +$(BUILD)/%/configure: $(BUILD)/%/configure.ac $(BUILD)/%/m4/ + autoreconf -if $(@D) + +$(BUILD)/%/configure.ac: ../ac/configure.ac | $(BUILD)/%/ + cp ../ac/configure.ac $(@D) + +$(BUILD)/%/m4/: ../ac/m4/ | $(BUILD)/%/ + cp -r ../ac/m4 $(@D) + +ALL_EXECS = symmetric asymmetric repro openmp target opt opt_target coupled \ + nuopc cov unit timing +$(foreach b,$(ALL_EXECS),$(BUILD)/$(b)/): + mkdir -p $@ # Fetch the regression target codebase -build/target/Makefile build/opt_target/Makefile: \ - $(TARGET_CODEBASE)/ac/configure deps/lib/libFMS.a - mkdir -p $(@D) - cd $(@D) \ - && $(MOM_ENV) ../../$(TARGET_CODEBASE)/ac/configure $(MOM_ACFLAGS) \ + +$(BUILD)/target/config.status: $(BUILD)/target/configure $(DEPS)/lib/libFMS.a + cd $(@D) && $(MOM_ENV) ./configure -n \ + --srcdir=$(abspath $(BUILD))/target_codebase/ac $(MOM_ACFLAGS) \ || (cat config.log && false) +$(BUILD)/target/Makefile.in: | $(TARGET_CODEBASE) $(BUILD)/target/ + cp $(TARGET_CODEBASE)/ac/Makefile.in $(@D) -$(TARGET_CODEBASE)/ac/configure: $(TARGET_CODEBASE) - autoreconf -i $/dev/null)" || rm -rf $(WORKSPACE)/results/$(1) +.PRECIOUS: $(foreach b,$(3),$(WORK)/$(1)/$(b)/ocean.stats) +$(1).$(2): $(foreach b,$(3),$(WORK)/$(1)/$(b)/ocean.stats) + @test "$$(shell ls -A $(WORK)/results/$(1) 2>/dev/null)" || rm -rf $(WORK)/results/$(1) @cmp $$^ || !( \ - mkdir -p $(WORKSPACE)/results/$(1); \ - (diff $$^ | tee $(WORKSPACE)/results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$(1); \ + (diff $$^ | tee $(WORK)/results/$(1)/ocean.stats.$(2).diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $(1).$(2) have changed." \ ) @echo -e "$(PASS): Solutions $(1).$(2) agree." -.PRECIOUS: $(foreach b,$(3),$(WORKSPACE)/work/$(1)/$(b)/chksum_diag) -$(1).$(2).diag: $(foreach b,$(3),$(WORKSPACE)/work/$(1)/$(b)/chksum_diag) +.PRECIOUS: $(foreach b,$(3),$(WORK)/$(1)/$(b)/chksum_diag) +$(1).$(2).diag: $(foreach b,$(3),$(WORK)/$(1)/$(b)/chksum_diag) @cmp $$^ || !( \ - mkdir -p $(WORKSPACE)/results/$(1); \ - (diff $$^ | tee $(WORKSPACE)/results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$(1); \ + (diff $$^ | tee $(WORK)/results/$(1)/chksum_diag.$(2).diff | head -n 20) ; \ echo -e "$(FAIL): Diagnostics $(1).$(2).diag have changed." \ ) @echo -e "$(PASS): Diagnostics $(1).$(2).diag agree." @@ -473,17 +497,17 @@ $(foreach d,$(DIMS),$(eval $(call CMP_RULE,$(1),dim.$(d),symmetric dim.$(d)))) endef $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) -# Custom comparison rules +# Custom comparison rules # Restart tests only compare the final stat record -.PRECIOUS: $(foreach b,symmetric restart target,$(WORKSPACE)/work/%/$(b)/ocean.stats) -%.restart: $(foreach b,symmetric restart,$(WORKSPACE)/work/%/$(b)/ocean.stats) - @test "$(shell ls -A $(WORKSPACE)/results/$* 2>/dev/null)" || rm -rf $(WORKSPACE)/results/$* +.PRECIOUS: $(foreach b,symmetric restart target,$(WORK)/%/$(b)/ocean.stats) +%.restart: $(foreach b,symmetric restart,$(WORK)/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORK)/results/$* 2>/dev/null)" || rm -rf $(WORK)/results/$* @cmp $(foreach f,$^,<(tr -s ' ' < $(f) | cut -d ' ' -f3- | tail -n 1)) \ || !( \ - mkdir -p $(WORKSPACE)/results/$*; \ - (diff $^ | tee $(WORKSPACE)/results/$*/chksum_diag.restart.diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/chksum_diag.restart.diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $*.restart have changed." \ ) @echo -e "$(PASS): Solutions $*.restart agree." @@ -491,21 +515,22 @@ $(foreach c,$(CONFIGS),$(eval $(call CONFIG_DIM_RULE,$(c)))) # TODO: chksum_diag parsing of restart files # stats rule is unchanged, but we cannot use CMP_RULE to generate it. -%.regression: $(foreach b,symmetric target,$(WORKSPACE)/work/%/$(b)/ocean.stats) - @test "$(shell ls -A $(WORKSPACE)/results/$* 2>/dev/null)" || rm -rf $(WORKSPACE)/results/$* +%.regression: $(foreach b,symmetric target,$(WORK)/%/$(b)/ocean.stats) + @test "$(shell ls -A $(WORK)/results/$* 2>/dev/null)" || rm -rf $(WORK)/results/$* @cmp $^ || !( \ - mkdir -p $(WORKSPACE)/results/$*; \ - (diff $^ | tee $(WORKSPACE)/results/$*/ocean.stats.regression.diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/ocean.stats.regression.diff | head -n 20) ; \ echo -e "$(FAIL): Solutions $*.regression have changed." \ ) @echo -e "$(PASS): Solutions $*.regression agree." # Regression testing only checks for changes in existing diagnostics -%.regression.diag: $(foreach b,symmetric target,$(WORKSPACE)/work/%/$(b)/chksum_diag) +.PRECIOUS: $(WORK)/%/target/chksum_diag +%.regression.diag: $(foreach b,symmetric target,$(WORK)/%/$(b)/chksum_diag) @! diff $^ | grep "^[<>]" | grep "^>" > /dev/null \ || ! (\ - mkdir -p $(WORKSPACE)/results/$*; \ - (diff $^ | tee $(WORKSPACE)/results/$*/chksum_diag.regression.diff | head -n 20) ; \ + mkdir -p $(WORK)/results/$*; \ + (diff $^ | tee $(WORK)/results/$*/chksum_diag.regression.diff | head -n 20) ; \ echo -e "$(FAIL): Diagnostics $*.regression.diag have changed." \ ) @cmp $^ || ( \ @@ -534,7 +559,7 @@ tc4/configure: tc4/configure.ac #--- # Test run output files -# Rule to build $(WORKSPACE)/work//{ocean.stats,chksum_diag}. +# Rule to build $(WORK)//{ocean.stats,chksum_diag}. # $(1): Test configuration name # $(2): Executable type # $(3): Enable coverage flag @@ -543,15 +568,14 @@ tc4/configure: tc4/configure.ac # $(6): Number of MPI ranks define STAT_RULE -$(WORKSPACE)/work/%/$(1)/ocean.stats $(WORKSPACE)/work/%/$(1)/chksum_diag: build/$(2)/MOM6 | preproc +$(WORK)/%/$(1)/ocean.stats $(WORK)/%/$(1)/chksum_diag: $(BUILD)/$(2)/MOM6 | preproc @echo "Running test $$*.$(1)..." mkdir -p $$(@D) cp -RL $$*/* $$(@D) - mkdir -p $$(@D)/RESTART echo -e "$(4)" > $$(@D)/MOM_override - rm -f $(WORKSPACE)/results/$$*/std.$(1).{out,err} + rm -f $(WORK)/results/$$*/std.$(1).{out,err} cd $$(@D) \ - && $(TIME) $(5) $(MPIRUN) -n $(6) $(abspath $$<) 2> std.err > std.out \ + && $(TIME) $(5) $(MPIRUN) -n $(6) $$(abspath $$<) 2> std.err > std.out \ || !( \ mkdir -p ../../../results/$$*/ ; \ cat std.out | tee ../../../results/$$*/std.$(1).out | tail -n 40 ; \ @@ -561,8 +585,8 @@ $(WORKSPACE)/work/%/$(1)/ocean.stats $(WORKSPACE)/work/%/$(1)/chksum_diag: build ) @echo -e "$(DONE): $$*.$(1); no runtime errors." if [ $(3) ]; then \ - mkdir -p $(WORKSPACE)/results/$$* ; \ - cd build/$(2) ; \ + mkdir -p $(WORK)/results/$$* ; \ + cd $(BUILD)/$(2) ; \ gcov -b *.gcda > gcov.$$*.$(1).out ; \ find -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; ; \ fi @@ -585,12 +609,12 @@ codecov: .PHONY: report.cov report.cov: run.cov codecov - ./codecov $(CODECOV_TOKEN_ARG) -R build/cov -Z -f "*.gcov" \ - > build/cov/codecov.out \ - 2> build/cov/codecov.err \ + ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/cov -Z -f "*.gcov" \ + > $(BUILD)/cov/codecov.out \ + 2> $(BUILD)/cov/codecov.err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ || { \ - cat build/cov/codecov.err ; \ + cat $(BUILD)/cov/codecov.err ; \ echo -e "${RED}Failed to upload report.${RESET}" ; \ if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ } @@ -620,7 +644,7 @@ $(eval $(call STAT_RULE,cov,cov,true,,,1)) # 2. Convert DAYMAX from TIMEUNIT to seconds # 3. Apply seconds to `ocean_solo_nml` inside input.nml. # NOTE: Assumes that runtime set by DAYMAX, will fail if set by input.nml -$(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc +$(WORK)/%/restart/ocean.stats: $(BUILD)/symmetric/MOM6 | preproc rm -rf $(@D) mkdir -p $(@D) cp -RL $*/* $(@D) @@ -634,7 +658,7 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc && halfperiod=$$(awk -v t=$${daymax} -v dt=$${timeunit} 'BEGIN {printf "%.f", 0.5*t*dt}') \ && printf "\n&ocean_solo_nml\n seconds = $${halfperiod}\n/\n" >> input.nml # Remove any previous archived output - rm -f $(WORKSPACE)/results/$*/std.restart{1,2}.{out,err} + rm -f $(WORK)/results/$*/std.restart{1,2}.{out,err} # Run the first half-period cd $(@D) && $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> std1.err > std1.out \ || !( \ @@ -660,7 +684,7 @@ $(WORKSPACE)/work/%/restart/ocean.stats: build/symmetric/MOM6 | preproc # Not a true rule; only call this after `make test` to summarize test results. .PHONY: test.summary test.summary: - @./tools/report_test_results.sh $(WORKSPACE)/results + @./tools/report_test_results.sh $(WORK)/results #--- @@ -668,48 +692,50 @@ test.summary: # NOTE: Using file parser gcov report as a proxy for test completion .PHONY: run.cov.unit -run.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov +run.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov .PHONY: build.unit -build.unit: $(foreach f, $(UNIT_EXECS), build/unit/$(f)) +build.unit: $(foreach f, $(UNIT_EXECS), $(BUILD)/unit/$(f)) .PHONY: run.unit run.unit: $(foreach f, $(UNIT_EXECS), work/unit/$(f).out) .PHONY: build.timing -build.timing: $(foreach f, $(TIMING_EXECS), build/timing/$(f)) +build.timing: $(foreach f, $(TIMING_EXECS), $(BUILD)/timing/$(f)) .PHONY: run.timing run.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).out) .PHONY: show.timing show.timing: $(foreach f, $(TIMING_EXECS), work/timing/$(f).show) -$(WORKSPACE)/work/timing/%.show: +$(WORK)/timing/%.show: ./tools/disp_timing.py $(@:.show=.out) + # Invoke the above unit/timing rules for a "target" code # Invoke with appropriate macros defines, i.e. -# make build.timing_target MOM_TARGET_URL=... MOM_TARGET_BRANCH=... TARGET_CODEBASE=build/target_codebase -# make run.timing_target TARGET_CODEBASE=build/target_codebase +# make build.timing_target MOM_TARGET_URL=... MOM_TARGET_BRANCH=... TARGET_CODEBASE=$(BUILD)/target_codebase +# make run.timing_target TARGET_CODEBASE=$(BUILD)/target_codebase TIMING_TARGET_EXECS ?= $(basename $(notdir $(wildcard $(TARGET_CODEBASE)/config_src/drivers/timing_tests/*.F90) ) ) .PHONY: build.timing_target -build.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/build/timing/$(f)) +build.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/$(BUILD)/timing/$(f)) .PHONY: run.timing_target run.timing_target: $(foreach f, $(TIMING_TARGET_EXECS), $(TARGET_CODEBASE)/.testing/work/timing/$(f).out) .PHONY: compare.timing compare.timing: $(foreach f, $(filter $(TIMING_EXECS),$(TIMING_TARGET_EXECS)), work/timing/$(f).compare) -$(WORKSPACE)/work/timing/%.compare: $(TARGET_CODEBASE) +$(WORK)/timing/%.compare: $(TARGET_CODEBASE) ./tools/disp_timing.py -r $(TARGET_CODEBASE)/.testing/$(@:.compare=.out) $(@:.compare=.out) $(TARGET_CODEBASE)/.testing/%: | $(TARGET_CODEBASE) cd $(TARGET_CODEBASE)/.testing && make $* + # General rule to run a unit test executable -# Pattern is to run build/unit/executable and direct output to executable.out -$(WORKSPACE)/work/unit/%.out: build/unit/% +# Pattern is to run $(BUILD)/unit/executable and direct output to executable.out +$(WORK)/unit/%.out: $(BUILD)/unit/% @mkdir -p $(@D) cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> >(tee $*.err) > $*.out -$(WORKSPACE)/work/unit/test_MOM_file_parser.out: build/unit/test_MOM_file_parser +$(WORK)/unit/test_MOM_file_parser.out: $(BUILD)/unit/test_MOM_file_parser if [ $(REPORT_COVERAGE) ]; then \ - find build/unit -name *.gcda -exec rm -f '{}' \; ; \ + find $(BUILD)/unit -name *.gcda -exec rm -f '{}' \; ; \ fi mkdir -p $(@D) cd $(@D) \ @@ -727,31 +753,31 @@ $(WORKSPACE)/work/unit/test_MOM_file_parser.out: build/unit/test_MOM_file_parser ) # NOTE: .gcov actually depends on .gcda, but .gcda is produced with std.out -# TODO: Replace $(WORKSPACE)/work/unit/std.out with *.gcda? -build/unit/MOM_file_parser_tests.F90.gcov: $(WORKSPACE)/work/unit/test_MOM_file_parser.out +# TODO: Replace $(WORK)/unit/std.out with *.gcda? +$(BUILD)/unit/MOM_file_parser_tests.F90.gcov: $(WORK)/unit/test_MOM_file_parser.out cd $(@D) \ && gcov -b *.gcda > gcov.unit.out find $(@D) -name "*.gcov" -exec sed -i -r 's/^( *[0-9]*)\*:/ \1:/g' {} \; .PHONY: report.cov.unit -report.cov.unit: build/unit/MOM_file_parser_tests.F90.gcov codecov - ./codecov $(CODECOV_TOKEN_ARG) -R build/unit -f "*.gcov" -Z -n "Unit tests" \ - > build/unit/codecov.out \ - 2> build/unit/codecov.err \ +report.cov.unit: $(BUILD)/unit/MOM_file_parser_tests.F90.gcov codecov + ./codecov $(CODECOV_TOKEN_ARG) -R $(BUILD)/unit -f "*.gcov" -Z -n "Unit tests" \ + > $(BUILD)/unit/codecov.out \ + 2> $(BUILD)/unit/codecov.err \ && echo -e "${MAGENTA}Report uploaded to codecov.${RESET}" \ || { \ - cat build/unit/codecov.err ; \ + cat $(BUILD)/unit/codecov.err ; \ echo -e "${RED}Failed to upload report.${RESET}" ; \ if [ "$(REQUIRE_COVERAGE_UPLOAD)" = true ] ; then false ; fi ; \ } -$(WORKSPACE)/work/timing/%.out: build/timing/% FORCE +$(WORK)/timing/%.out: $(BUILD)/timing/% FORCE @mkdir -p $(@D) @echo Running $< in $(@D) @cd $(@D) ; $(TIME) $(MPIRUN) -n 1 $(abspath $<) 2> $*.err > $*.out -#--- -# Profiling based on FMS clocks + +## Profiling based on FMS clocks PCONFIGS = p0 @@ -759,17 +785,17 @@ PCONFIGS = p0 profile: $(foreach p,$(PCONFIGS), prof.$(p)) .PHONY: prof.p0 -prof.p0: $(WORKSPACE)/work/p0/opt/clocks.json $(WORKSPACE)/work/p0/opt_target/clocks.json +prof.p0: $(WORK)/p0/opt/clocks.json $(WORK)/p0/opt_target/clocks.json python tools/compare_clocks.py $^ -$(WORKSPACE)/work/p0/%/clocks.json: $(WORKSPACE)/work/p0/%/std.out +$(WORK)/p0/%/clocks.json: $(WORK)/p0/%/std.out 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 +$(WORK)/p0/opt/std.out: $(BUILD)/opt/MOM6 +$(WORK)/p0/opt_target/std.out: $(BUILD)/opt_target/MOM6 -$(WORKSPACE)/work/p0/%/std.out: +$(WORK)/p0/%/std.out: mkdir -p $(@D) cp -RL p0/* $(@D) mkdir -p $(@D)/RESTART @@ -778,8 +804,7 @@ $(WORKSPACE)/work/p0/%/std.out: && $(MPIRUN) -n 1 $(abspath $<) 2> std.err > std.out -#--- -# Profiling based on perf output +## Profiling based on perf output # TODO: This expects the -e flag, can I handle it in the command? PERF_EVENTS ?= @@ -788,16 +813,16 @@ PERF_EVENTS ?= perf: $(foreach p,$(PCONFIGS), perf.$(p)) .PHONY: prof.p0 -perf.p0: $(WORKSPACE)/work/p0/opt/profile.json $(WORKSPACE)/work/p0/opt_target/profile.json +perf.p0: $(WORK)/p0/opt/profile.json $(WORK)/p0/opt_target/profile.json python tools/compare_perf.py $^ -$(WORKSPACE)/work/p0/%/profile.json: $(WORKSPACE)/work/p0/%/perf.data +$(WORK)/p0/%/profile.json: $(WORK)/p0/%/perf.data python tools/parse_perf.py -f $< > $@ -$(WORKSPACE)/work/p0/opt/perf.data: build/opt/MOM6 -$(WORKSPACE)/work/p0/opt_target/perf.data: build/opt_target/MOM6 +$(WORK)/p0/opt/perf.data: $(BUILD)/opt/MOM6 +$(WORK)/p0/opt_target/perf.data: $(BUILD)/opt_target/MOM6 -$(WORKSPACE)/work/p0/%/perf.data: +$(WORK)/p0/%/perf.data: mkdir -p $(@D) cp -RL p0/* $(@D) mkdir -p $(@D)/RESTART @@ -810,25 +835,26 @@ $(WORKSPACE)/work/p0/%/perf.data: || cat std.perf.err -#---- +## Cleanup # NOTE: These tests assert that we are in the .testing directory. .PHONY: clean clean: clean.build clean.stats - @[ $$(basename $$(pwd)) = .testing ] - rm -rf deps + rm -rf $(BUILD) .PHONY: clean.build clean.build: @[ $$(basename $$(pwd)) = .testing ] - rm -rf build + for b in $(ALL_EXECS); do \ + rm -rf $(BUILD)/$${b}; \ + done .PHONY: clean.stats clean.stats: @[ $$(basename $$(pwd)) = .testing ] - rm -rf $(WORKSPACE)/work $(WORKSPACE)/results + rm -rf $(WORK) .PHONY: clean.preproc diff --git a/ac/configure.ac b/ac/configure.ac index 9d87240506..c774c39129 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -82,13 +82,13 @@ AS_IF([test "x$with_driver" != "x"], # Select the model framework (default: FMS1) # NOTE: We can phase this out after the FMS1 I/O has been removed from FMS and # replace with a detection test. For now, it is a user-defined switch. -MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 +MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2 AC_ARG_WITH([framework], AS_HELP_STRING([--with-framework=fms1|fms2], [Select the model framework])) AS_CASE(["$with_framework"], [fms1], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1], [fms2], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2], - [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1] + [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2] ) From 2ae638504b5eb9c1d492a18fa8c4ab471f17153a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 22 Dec 2023 09:34:36 -0500 Subject: [PATCH 549/629] Refactor set_viscous_BBL channel drag calculations Refactored set_viscous_BBL to separate out the routines setting the open interface lengths used for the channel drag, shortening a 1070 line long routine to 915 lines and reducing the scope of a number of temporary variables. A number of logical branch points have been moved outside of the innermost do loops. This refactoring will also make it easier to provide alternatives to some of the solvers that do not use the trigonometric functions to solve for the roots of a cubic expression and avoiding the issues noted at NOAA-GFDL/MOM6/issues/483. All answers are bitwise identical and public interfaces are unchanged. --- .../vertical/MOM_set_viscosity.F90 | 511 +++++++++++------- 1 file changed, 322 insertions(+), 189 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index b207b1ff1c..bf0db51a44 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -20,6 +20,7 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_interface_heights, only : thickness_to_dz +! use MOM_intrinsic_functions, only : cuberoot use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E @@ -258,40 +259,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: crv ! crv is the curvature of the bottom depth across a ! cell, times the cell width squared [Z ~> m]. real :: crv_3 ! crv/3 [Z ~> m]. - real :: C24_crv ! 24/crv [Z-1 ~> m-1]. real :: slope ! The absolute value of the bottom depth slope across ! a cell times the cell width [Z ~> m]. - real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. - real :: a2x48_apb3, Iapb, Ibma_2 ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] - ! All of the following "volumes" have units of vertical heights because they are normalized - ! by the full horizontal area of a velocity cell. real :: Vol_bbl_chan ! The volume of the bottom boundary layer as used in the channel ! drag parameterization, normalized by the full horizontal area ! of the velocity cell [Z ~> m]. - real :: Vol_open ! The cell volume above which it is open [Z ~> m]. - real :: Vol_direct ! With less than Vol_direct [Z ~> m], there is a direct - ! solution of a cubic equation for L. - real :: Vol_2_reg ! The cell volume above which there are two separate - ! open areas that must be integrated [Z ~> m]. - real :: vol ! The volume below the interface whose normalized - ! width is being sought [Z ~> m]. - real :: vol_below ! The volume below the interface below the one that - ! is currently under consideration [Z ~> m]. - real :: Vol_err ! The error in the volume with the latest estimate of - ! L, or the error for the interface below [Z ~> m]. - real :: Vol_quit ! The volume error below which to quit iterating [Z ~> m]. - real :: Vol_tol ! A volume error tolerance [Z ~> m]. + real :: vol_below(SZK_(GV)+1) ! The volume below each interface, normalized by the full + ! horizontal area of a velocity cell [Z ~> m]. real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface [nondim]. - real :: L_direct ! The value of L above volume Vol_direct [nondim]. - real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. - real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [Z ~> m] - real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [Z ~> m] - real :: Vol_0 ! A deeper volume with known width L0 [Z ~> m]. - real :: L0 ! The value of L above volume Vol_0 [nondim]. - real :: dVol ! vol - Vol_0 [Z ~> m]. - real :: dV_dL2 ! The partial derivative of volume with L squared - ! evaluated at L=L0 [Z ~> m]. real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: dz_neglect ! A vertical distance that is so small it is usually lost @@ -315,14 +291,9 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] real :: C2pi_3 ! An irrational constant, 2/3 pi. [nondim] real :: tmp ! A temporary variable, sometimes in [Z ~> m] - real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] - real :: curv_tol ! Numerator of curvature cubed, used to estimate - ! accuracy of a single L(:) Newton iteration [Z5 ~> m5] - logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state integer :: i, j, k, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, m, n, K2, nkmb, nkml - integer :: itt, maxitt=20 type(ocean_OBC_type), pointer :: OBC => NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -332,7 +303,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) dz_neglect = GV%dZ_subroundoff Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) - Vol_quit = (0.9*GV%Angstrom_Z + dz_neglect) C2pi_3 = 8.0*atan(1.0)/3.0 if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& @@ -442,8 +412,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G,C2pi_3, & !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & - !$OMP OBC,maxitt,D_u,D_v,mask_u,mask_v,pbv) & - !$OMP firstprivate(Vol_quit) + !$OMP OBC,D_u,D_v,mask_u,mask_v,pbv) do j=Jsq,Jeq ; do m=1,2 if (m==1) then @@ -865,12 +834,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%body_force_drag) bbl_thick = dz_bbl_drag(i) if (CS%Channel_drag) then - ! The drag within the bottommost Vol_bbl_chan is applied as a part of - ! an enhanced bottom viscosity, while above this the drag is applied - ! directly to the layers in question as a Rayleigh drag term. - ! Restrict the volume over which the channel drag is applied. - if (CS%Chan_drag_max_vol >= 0.0) Vol_bbl_chan = min(Vol_bbl_chan, CS%Chan_drag_max_vol) + vol_below(nz+1) = 0.0 + do K=nz,1,-1 + vol_below(K) = vol_below(K+1) + dz_vel(i,k) + enddo !### The harmonic mean edge depths here are not invariant to offsets! if (m==1) then @@ -887,162 +855,33 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Dm = 2.0 * D_vel * tmp / (D_vel + tmp) endif if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif - crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 slope = Dp - Dm + ! If the curvature is small enough, there is no reason not to assume ! a uniformly sloping or flat bottom. if (abs(crv) < 1e-2*(slope + CS%BBL_thick_min)) crv = 0.0 - ! Each cell extends from x=-1/2 to 1/2, and has a topography - ! given by D(x) = crv*x^2 + slope*x + D - crv/12. - - ! Calculate the volume above which the entire cell is open and the - ! other volumes at which the equation that is solved for L changes. - if (crv > 0.0) then - if (slope >= crv) then - Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open - else - tmp = slope/crv - Vol_open = 0.25*slope*tmp + C1_12*crv - Vol_2_reg = 0.5*tmp**2 * (crv - C1_3*slope) - endif - ! Define some combinations of crv & slope for later use. - C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) - apb_4a = (slope+crv)/(4.0*crv) ; a2x48_apb3 = (48.0*(crv*crv))*(Iapb**3) - ax2_3apb = 2.0*C1_3*crv*Iapb - elseif (crv == 0.0) then - Vol_open = 0.5*slope - if (slope > 0) Iapb = 1.0/slope - else ! crv < 0.0 - Vol_open = D_vel - Dm - if (slope >= -crv) then - Iapb = 1.0e30*US%Z_to_m ; if (slope+crv /= 0.0) Iapb = 1.0/(crv+slope) - Vol_direct = 0.0 ; L_direct = 0.0 ; C24_crv = 0.0 - else - C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) - L_direct = 1.0 + slope/crv ! L_direct < 1 because crv < 0 - Vol_direct = -C1_6*crv*L_direct**3 - endif - Ibma_2 = 2.0 / (slope - crv) - endif - L(nz+1) = 0.0 ; vol = 0.0 ; Vol_err = 0.0 ; BBL_visc_frac = 0.0 - ! Determine the normalized open length at each interface. - do K=nz,1,-1 - vol_below = vol - - vol = vol + dz_vel(i,k) - h_vel_pos = h_vel(i,k) + h_neglect - - if (vol >= Vol_open) then ; L(K) = 1.0 - elseif (crv == 0) then ! The bottom has no curvature. - L(K) = sqrt(2.0*vol*Iapb) - elseif (crv > 0) then - ! There may be a minimum depth, and there are - ! analytic expressions for L for all cases. - if (vol < Vol_2_reg) then - ! In this case, there is a contiguous open region and - ! vol = 0.5*L^2*(slope + crv/3*(3-4L)). - if (a2x48_apb3*vol < 1e-8) then ! Could be 1e-7? - ! There is a very good approximation here for massless layers. - L0 = sqrt(2.0*vol*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) - else - L(K) = apb_4a * (1.0 - & - 2.0 * cos(C1_3*acos(a2x48_apb3*vol - 1.0) - C2pi_3)) - endif - ! To check the answers. - ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol - else ! There are two separate open regions. - ! vol = slope^2/4crv + crv/12 - (crv/12)*(1-L)^2*(1+2L) - ! At the deepest volume, L = slope/crv, at the top L = 1. - !L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_crv*(Vol_open - vol)) - C2pi_3) - tmp_val_m1_to_p1 = 1.0 - C24_crv*(Vol_open - vol) - tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) - L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) - ! To check the answers. - ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol - endif - else ! a < 0. - if (vol <= Vol_direct) then - ! Both edges of the cell are bounded by walls. - L(K) = (-0.25*C24_crv*vol)**C1_3 - else - ! x_R is at 1/2 but x_L is in the interior & L is found by solving - ! vol = 0.5*L^2*(slope + crv/3*(3-4L)) - - ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + crv_3*(3.0-4.0*L(K+1))) - vol_below - ! Change to ... - ! if (min(vol_below + Vol_err, vol) <= Vol_direct) then ? - if (vol_below + Vol_err <= Vol_direct) then - L0 = L_direct ; Vol_0 = Vol_direct - else - L0 = L(K+1) ; Vol_0 = vol_below + Vol_err - ! Change to Vol_0 = min(vol_below + Vol_err, vol) ? - endif - - ! Try a relatively simple solution that usually works well - ! for massless layers. - dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = (vol-Vol_0) - ! dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = max(vol-Vol_0, 0.0) - - use_L0 = .false. - do_one_L_iter = .false. - if (CS%answer_date < 20190101) then - curv_tol = GV%Angstrom_Z*dV_dL2**2 & - * (0.25 * dV_dL2 * GV%Angstrom_Z - crv * L0 * dVol) - do_one_L_iter = (crv * crv * dVol**3) < curv_tol - else - ! The following code is more robust when GV%Angstrom_H=0, but - ! it changes answers. - use_L0 = (dVol <= 0.) - - Vol_tol = max(0.5 * GV%Angstrom_Z + dz_neglect, 1e-14 * vol) - Vol_quit = max(0.9 * GV%Angstrom_Z + dz_neglect, 1e-14 * vol) + ! Determine the normalized open length (L) at each interface. + if (crv == 0.0) then + call find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) + elseif (crv > 0.0) then + call find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) + else ! crv < 0.0 + call find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) + endif ! end of crv<0 cases. - curv_tol = Vol_tol * dV_dL2**2 & - * (dV_dL2 * Vol_tol - 2.0 * crv * L0 * dVol) - do_one_L_iter = (crv * crv * dVol**3) < curv_tol - endif + ! Determine the Rayliegh drag contributions. - if (use_L0) then - L(K) = L0 - Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol - elseif (do_one_L_iter) then - ! One iteration of Newton's method should give an estimate - ! that is accurate to within Vol_tol. - L(K) = sqrt(L0*L0 + dVol / dV_dL2) - Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol - else - if (dV_dL2*(1.0-L0*L0) < dVol + & - dV_dL2 * (Vol_open - Vol)*Ibma_2) then - L_max = sqrt(1.0 - (Vol_open - Vol)*Ibma_2) - else - L_max = sqrt(L0*L0 + dVol / dV_dL2) - endif - L_min = sqrt(L0*L0 + dVol / (0.5*(slope+crv) - crv*L_max)) + ! The drag within the bottommost Vol_bbl_chan is applied as a part of an enhanced bottom + ! viscosity, while above this the drag is applied directly to the layers in question as a + ! Rayleigh drag term. - Vol_err_min = 0.5*(L_min**2)*(slope + crv_3*(3.0-4.0*L_min)) - vol - Vol_err_max = 0.5*(L_max**2)*(slope + crv_3*(3.0-4.0*L_max)) - vol - ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then - if (abs(Vol_err_min) <= Vol_quit) then - L(K) = L_min ; Vol_err = Vol_err_min - else - L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & - (Vol_err_max - Vol_err_min)) - do itt=1,maxitt - Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol - if (abs(Vol_err) <= Vol_quit) exit - ! Take a Newton's method iteration. This equation has proven - ! robust enough not to need bracketing. - L(K) = L(K) - Vol_err / (L(K)* (slope + crv - 2.0*crv*L(K))) - ! This would be a Newton's method iteration for L^2: - ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+crv) - crv*L(K))) - enddo - endif ! end of iterative solver - endif ! end of 1-boundary alternatives. - endif ! end of a<0 cases. - endif + ! Restrict the volume over which the channel drag is applied from the previously determined valu.e + if (CS%Chan_drag_max_vol >= 0.0) Vol_bbl_chan = min(Vol_bbl_chan, CS%Chan_drag_max_vol) + BBL_visc_frac = 0.0 + do K=nz,1,-1 !modify L(K) for porous barrier parameterization if (m==1) then ; L(K) = L(K)*pbv%por_layer_widthU(I,j,K) else ; L(K) = L(K)*pbv%por_layer_widthV(i,J,K); endif @@ -1050,8 +889,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! Determine the drag contributing to the bottom boundary layer ! and the Rayleigh drag that acts on each layer. if (L(K) > L(K+1)) then - if (vol_below < Vol_bbl_chan) then - BBL_frac = (1.0-vol_below/Vol_bbl_chan)**2 + if (vol_below(K+1) < Vol_bbl_chan) then + BBL_frac = (1.0-vol_below(K+1)/Vol_bbl_chan)**2 BBL_visc_frac = BBL_visc_frac + BBL_frac*(L(K) - L(K+1)) else BBL_frac = 0.0 @@ -1063,6 +902,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) cdrag_conv = cdrag_L_to_H endif + h_vel_pos = h_vel(i,k) + h_neglect if (m==1) then ; Cell_width = G%dy_Cu(I,j)*pbv%por_face_areaU(I,j,k) else ; Cell_width = G%dx_Cv(i,J)*pbv%por_face_areaV(i,J,k) ; endif gam = 1.0 - L(K+1)/L(K) @@ -1085,7 +925,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif - enddo ! k loop to determine L(K). + enddo ! k loop to determine visc%Ray_[uv]. ! Set the near-bottom viscosity to a value which will give ! the correct stress when the shear occurs over bbl_thick. @@ -1202,6 +1042,299 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) end subroutine set_viscous_BBL +!> Determine the normalized open length of each interface, given the edge depths and normalized +!! volumes below each interface. +subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: slope ! The absolute value of the bottom depth slope across a cell times the cell width [Z ~> m]. + real :: I_slope ! The inverse of the normalized slope [Z-1 ~> m-1] + real :: Vol_open ! The cell volume above which it is open [Z ~> m]. + integer :: K, nz + + nz = GV%ke + + slope = abs(Dp - Dm) + if (slope == 0.0) then + L(1:nz) = 1.0 ; L(nz+1) = 0.0 + else + Vol_open = 0.5*slope + I_slope = 1.0 / slope + + L(nz+1) = 0.0 + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ; L(K) = 1.0 + else + ! With a uniformly sloping bottom, the calculation of L(K) is the solution of a simple quadratic equation. + L(K) = sqrt(2.0*vol_below(K)*I_slope) + endif + enddo + endif + +end subroutine find_L_open_uniform_slope + +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) using +!! analytic expressions. In this case there can be two separate open regions. +subroutine find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: C2pi_3 !< An irrational constant, 2/3 pi [nondim] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. + real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. + real :: a2x48_apb3, Iapb ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + real :: L0 ! A linear estimate of L approprate for tiny volumes [nondim]. + real :: slope_crv ! The slope divided by the curvature [nondim] + real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] + real, parameter :: C1_3 = 1.0/3.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + integer :: K, nz + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + if (crv < 0.0) call MOM_error(FATAL, "find_L_open_concave should only be called with a positive curvature.") + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + endif + ! Define some combinations of crv & slope for later use. + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + apb_4a = (slope+crv)/(4.0*crv) ; a2x48_apb3 = (48.0*(crv*crv))*(Iapb**3) + ax2_3apb = 2.0*C1_3*crv*Iapb + + L(nz+1) = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ! The whole cell is open. + L(K) = 1.0 + elseif (vol_below(K) < Vol_2_reg) then + ! In this case, there is a contiguous open region and + ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)). + if (a2x48_apb3*vol_below(K) < 1e-8) then ! Could be 1e-7? + ! There is a very good approximation here for massless layers. + L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) + else + L(K) = apb_4a * (1.0 - & + 2.0 * cos(C1_3*acos(a2x48_apb3*vol_below(K) - 1.0) - C2pi_3)) + endif + ! To check the answers. + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else ! There are two separate open regions. + ! vol_below(K) = slope^2/4crv + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + ! L(K) = 0.5 - cos(C1_3*acos(1.0 - C24_crv*(Vol_open - vol_below(K))) - C2pi_3) + tmp_val_m1_to_p1 = 1.0 - C24_crv*(Vol_open - vol_below(K)) + tmp_val_m1_to_p1 = max(-1., min(1., tmp_val_m1_to_p1)) + L(K) = 0.5 - cos(C1_3*acos(tmp_val_m1_to_p1) - C2pi_3) + ! To check the answers. + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol_below(K) + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine find_L_open_concave_analytic + + +!> Determine the normalized open length of each interface for convex bathymetry (from the ocean perspective) using +!! Newton's method iterations. In this case there is a single open region with the minimum depth +!! at one edge of the cell. +subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(set_visc_CS), intent(in) :: CS !< The control structure returned by a previous + !! call to set_visc_init. + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + ! All of the following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_err ! The error in the volume with the latest estimate of + ! L, or the error for the interface below [Z ~> m]. + real :: Vol_quit ! The volume error below which to quit iterating [Z ~> m]. + real :: Vol_tol ! A volume error tolerance [Z ~> m]. + real :: Vol_open ! The cell volume above which the face is fully open [Z ~> m]. + real :: Vol_direct ! With less than Vol_direct [Z ~> m], there is a direct + ! solution of a cubic equation for L. + real :: Vol_err_max ! The volume error for the upper bound on the correct value for L [Z ~> m] + real :: Vol_err_min ! The volume error for the lower bound on the correct value for L [Z ~> m] + real :: Vol_0 ! A deeper volume with known width L0 [Z ~> m]. + real :: dVol ! vol - Vol_0 [Z ~> m]. + real :: dV_dL2 ! The partial derivative of volume with L squared + ! evaluated at L=L0 [Z ~> m]. + real :: L_direct ! The value of L above volume Vol_direct [nondim]. + real :: L_max, L_min ! Upper and lower bounds on the correct value for L [nondim]. + real :: L0 ! The value of L above volume Vol_0 [nondim]. + real :: Iapb, Ibma_2 ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] + real :: C24_crv ! 24/crv [Z-1 ~> m-1]. + real :: curv_tol ! Numerator of curvature cubed, used to estimate + ! accuracy of a single L(:) Newton iteration [Z5 ~> m5] + real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0 ! Rational constants [nondim] + logical :: use_L0, do_one_L_iter ! Control flags for L(:) Newton iteration + integer :: K, nz, itt, maxitt=20 + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + if (crv > 0.0) call MOM_error(FATAL, "find_L_open_convex should only be called with a negative curvature.") + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there is a direct solution. + Vol_open = D_vel - Dm + if (slope >= -crv) then + Iapb = 1.0e30*US%Z_to_m ; if (slope+crv /= 0.0) Iapb = 1.0/(crv+slope) + Vol_direct = 0.0 ; L_direct = 0.0 ; C24_crv = 0.0 + else + C24_crv = 24.0/crv ; Iapb = 1.0/(crv+slope) + L_direct = 1.0 + slope/crv ! L_direct < 1 because crv < 0 + Vol_direct = -C1_6*crv*L_direct**3 + endif + Ibma_2 = 2.0 / (slope - crv) + + if (CS%answer_date < 20190101) Vol_quit = (0.9*GV%Angstrom_Z + GV%dZ_subroundoff) + + L(nz+1) = 0.0 ; Vol_err = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then + L(K) = 1.0 + elseif (vol_below(K) <= Vol_direct) then + ! Both edges of the cell are bounded by walls. + ! if (CS%answer_date < 20240101)) then + L(K) = (-0.25*C24_crv*vol_below(K))**C1_3 + ! else + ! L(K) = cuberoot(-0.25*C24_crv*vol_below(K)) + ! endif + else + ! x_R is at 1/2 but x_L is in the interior & L is found by iteratively solving + ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)) + + ! Vol_err = 0.5*(L(K+1)*L(K+1))*(slope + crv_3*(3.0-4.0*L(K+1))) - vol_below(K+1) + ! Change to ... + ! if (min(vol_below(K+1) + Vol_err, vol_below(K)) <= Vol_direct) then ? + if (vol_below(K+1) + Vol_err <= Vol_direct) then + L0 = L_direct ; Vol_0 = Vol_direct + else + L0 = L(K+1) ; Vol_0 = vol_below(K+1) + Vol_err + ! Change to Vol_0 = min(vol_below(K+1) + Vol_err, vol_below(K)) ? + endif + + ! Try a relatively simple solution that usually works well + ! for massless layers. + dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = (vol_below(K)-Vol_0) + ! dV_dL2 = 0.5*(slope+crv) - crv*L0 ; dVol = max(vol_below(K)-Vol_0, 0.0) + + use_L0 = .false. + do_one_L_iter = .false. + if (CS%answer_date < 20190101) then + curv_tol = GV%Angstrom_Z*dV_dL2**2 & + * (0.25 * dV_dL2 * GV%Angstrom_Z - crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol + else + ! The following code is more robust when GV%Angstrom_H=0, but + ! it changes answers. + use_L0 = (dVol <= 0.) + + Vol_tol = max(0.5 * GV%Angstrom_Z + GV%dZ_subroundoff, 1e-14 * vol_below(K)) + Vol_quit = max(0.9 * GV%Angstrom_Z + GV%dZ_subroundoff, 1e-14 * vol_below(K)) + + curv_tol = Vol_tol * dV_dL2**2 & + * (dV_dL2 * Vol_tol - 2.0 * crv * L0 * dVol) + do_one_L_iter = (crv * crv * dVol**3) < curv_tol + endif + + if (use_L0) then + L(K) = L0 + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + elseif (do_one_L_iter) then + ! One iteration of Newton's method should give an estimate + ! that is accurate to within Vol_tol. + L(K) = sqrt(L0*L0 + dVol / dV_dL2) + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else + if (dV_dL2*(1.0-L0*L0) < dVol + & + dV_dL2 * (Vol_open - vol_below(K))*Ibma_2) then + L_max = sqrt(1.0 - (Vol_open - vol_below(K))*Ibma_2) + else + L_max = sqrt(L0*L0 + dVol / dV_dL2) + endif + L_min = sqrt(L0*L0 + dVol / (0.5*(slope+crv) - crv*L_max)) + + Vol_err_min = 0.5*(L_min**2)*(slope + crv_3*(3.0-4.0*L_min)) - vol_below(K) + Vol_err_max = 0.5*(L_max**2)*(slope + crv_3*(3.0-4.0*L_max)) - vol_below(K) + ! if ((abs(Vol_err_min) <= Vol_quit) .or. (Vol_err_min >= Vol_err_max)) then + if (abs(Vol_err_min) <= Vol_quit) then + L(K) = L_min ; Vol_err = Vol_err_min + else + L(K) = sqrt((L_min**2*Vol_err_max - L_max**2*Vol_err_min) / & + (Vol_err_max - Vol_err_min)) + do itt=1,maxitt + Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + if (abs(Vol_err) <= Vol_quit) exit + ! Take a Newton's method iteration. This equation has proven + ! robust enough not to need bracketing. + L(K) = L(K) - Vol_err / (L(K)* (slope + crv - 2.0*crv*L(K))) + ! This would be a Newton's method iteration for L^2: + ! L(K) = sqrt(L(K)*L(K) - Vol_err / (0.5*(slope+crv) - crv*L(K))) + enddo + endif ! end of iterative solver + endif ! end of 1-boundary alternatives. + endif ! end of 0, 1- and 2- boundary cases. + enddo ! k loop to determine L(K) in the convex case + +end subroutine find_L_open_convex + !> This subroutine finds a thickness-weighted value of v at the u-points. function set_v_at_u(v, h, G, GV, i, j, k, mask2dCv, OBC) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure From da02ffc601ff62a8ab800eb1f759a5105780d071 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 29 Dec 2023 23:23:56 -0500 Subject: [PATCH 550/629] +Add find_L_open_concave_iterative Added the new routine find_L_open_concave_iterative to use iterative Newton's method approaches with appropriate limits to solve the cubic equation for the fractional open face lengths at interfaces that are used by the CHANNEL_DRAG code. These solutions are analogous to those given by the previous expressions that are now in find_L_open_concave_trigonometric, and the two differ at close to roundoff, but the new method is completely independent of the transcendental function library, thereby addressing dev/gfdl MOM6 issue #483. This new routine is called when the new runtime parameter TRIG_CHANNEL_DRAG_WIDTHS is set to false, but by default the previous answers are recovered. By default all answers are bitwise identical, but there is a new runtime parameter in some MOM_parameter_doc files. --- .../vertical/MOM_set_viscosity.F90 | 389 +++++++++++++++++- 1 file changed, 370 insertions(+), 19 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index bf0db51a44..b25d660957 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -20,7 +20,7 @@ module MOM_set_visc use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_interface_heights, only : thickness_to_dz -! use MOM_intrinsic_functions, only : cuberoot +use MOM_intrinsic_functions, only : cuberoot use MOM_io, only : slasher, MOM_read_data, vardesc, var_desc use MOM_kappa_shear, only : kappa_shear_is_used, kappa_shear_at_vertex use MOM_open_boundary, only : ocean_OBC_type, OBC_segment_type, OBC_NONE, OBC_DIRECTION_E @@ -101,6 +101,8 @@ module MOM_set_visc real :: omega_frac !< When setting the decay scale for turbulence, use this !! fraction of the absolute rotation rate blended with the local !! value of f, as sqrt((1-of)*f^2 + of*4*omega^2) [nondim] + logical :: concave_trigonometric_L !< If true, use trigonometric expressions to determine the + !! fractional open interface lengths for concave topography. integer :: answer_date !< The vintage of the order of arithmetic and expressions in the set !! viscosity calculations. Values below 20190101 recover the answers !! from the end of 2018, while higher values use updated and more robust @@ -208,11 +210,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! from lateral lengths to layer thicknesses [H L-1 ~> nondim or kg m-3]. real :: cdrag_sqrt_H_RL ! Square root of the drag coefficient, times a unit conversion factor from ! density times lateral lengths to layer thicknesses [H L-1 R-1 ~> m3 kg-1 or nondim] - real :: cdrag_L_to_H ! The drag coeffient times conversion factors from lateral + real :: cdrag_L_to_H ! The drag coefficient times conversion factors from lateral ! distance to thickness units [H L-1 ~> nondim or kg m-3] - real :: cdrag_RL_to_H ! The drag coeffient times conversion factors from density times lateral + real :: cdrag_RL_to_H ! The drag coefficient times conversion factors from density times lateral ! distance to thickness units [H L-1 R-1 ~> m3 kg-1 or nondim] - real :: cdrag_conv ! The drag coeffient times a combination of static conversion factors and in + real :: cdrag_conv ! The drag coefficient times a combination of static conversion factors and in ! situ density or Boussinesq reference density [H L-1 ~> nondim or kg m-3] real :: oldfn ! The integrated energy required to ! entrain up to the bottom of the layer, @@ -268,6 +270,11 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! horizontal area of a velocity cell [Z ~> m]. real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface [nondim]. + real :: L_trig(SZK_(GV)+1) ! The fraction of the full cell width that is open at + ! the depth of each interface from trigonometric expressions [nondim]. + real :: dL_trig_itt(SZK_(GV)+1) ! The difference between estimates of the fraction of the full cell + ! width that is open at the depth of each interface [nondim]. + real :: max_dL_trig_itt ! The largest difference between L and L_trig, for debugging [nondim] real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: dz_neglect ! A vertical distance that is so small it is usually lost @@ -866,18 +873,32 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (crv == 0.0) then call find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) elseif (crv > 0.0) then - call find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) + if (CS%concave_trigonometric_L) then + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) + else + call find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) + if (CS%debug) then + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L_trig, GV) + max_dL_trig_itt = 0.0 + do K=1,nz+1 + dL_trig_itt(K) = L_trig(K) - L(K) + if (abs(dL_trig_itt(K)) > abs(max_dL_trig_itt)) max_dL_trig_itt = dL_trig_itt(K) + enddo + if (abs(max_dL_trig_itt) > 1.0e-12) & + K = nz+1 ! This is here to use with a debugger only. + endif + endif else ! crv < 0.0 call find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) endif ! end of crv<0 cases. - ! Determine the Rayliegh drag contributions. + ! Determine the Rayleigh drag contributions. ! The drag within the bottommost Vol_bbl_chan is applied as a part of an enhanced bottom ! viscosity, while above this the drag is applied directly to the layers in question as a ! Rayleigh drag term. - ! Restrict the volume over which the channel drag is applied from the previously determined valu.e + ! Restrict the volume over which the channel drag is applied from the previously determined value. if (CS%Chan_drag_max_vol >= 0.0) Vol_bbl_chan = min(Vol_bbl_chan, CS%Chan_drag_max_vol) BBL_visc_frac = 0.0 @@ -1082,9 +1103,9 @@ subroutine find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) end subroutine find_L_open_uniform_slope -!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) using -!! analytic expressions. In this case there can be two separate open regions. -subroutine find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) +!! using trigonometric expressions. In this case there can be two separate open regions. +subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by !! the full horizontal area of a velocity cell [Z ~> m] @@ -1111,7 +1132,7 @@ subroutine find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) real :: C24_crv ! 24/crv [Z-1 ~> m-1]. real :: apb_4a, ax2_3apb ! Various nondimensional ratios of crv and slope [nondim]. real :: a2x48_apb3, Iapb ! Combinations of crv (a) and slope (b) [Z-1 ~> m-1] - real :: L0 ! A linear estimate of L approprate for tiny volumes [nondim]. + real :: L0 ! A linear estimate of L appropriate for tiny volumes [nondim]. real :: slope_crv ! The slope divided by the curvature [nondim] real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] real, parameter :: C1_3 = 1.0/3.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] @@ -1122,7 +1143,7 @@ subroutine find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) ! Each cell extends from x=-1/2 to 1/2, and has a topography ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 - if (crv < 0.0) call MOM_error(FATAL, "find_L_open_concave should only be called with a positive curvature.") + if (crv <= 0.0) call MOM_error(FATAL, "find_L_open_concave should only be called with a positive curvature.") slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the @@ -1168,12 +1189,337 @@ subroutine find_L_open_concave_analytic(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) endif enddo ! k loop to determine L(K) in the concave case -end subroutine find_L_open_concave_analytic +end subroutine find_L_open_concave_trigonometric + + + +!> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) using +!! iterative methods to solve the relevant cubic equations. In this case there can be two separate open regions. +subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: L_2_reg ! The value of L when vol_below is Vol_2_reg [nondim] + real :: vol_inflect_1 ! The volume at which there is an inflection point in the expression + ! relating L to vol_err when there is a single open region [Z ~> m] + real :: vol_inflect_2 ! The volume at which there is an inflection point in the expression + ! relating L to vol_err when there are two open regions [Z ~> m] + + real :: L_inflect_1 ! The value of L that sits at an inflection point in the expression + ! relating L to vol_err when there is a single open region [nondim] + real :: L_inflect_2 ! The value of L that sits at an inflection point in the expression + ! relating L to vol_err when there is are two open regions [nondim] + real :: L_max, L_min ! Maximum and minimum bounds on the solution for L for an interface [nondim] + real :: vol_err ! The difference between the volume below an interface for a given value + ! of L and the target value [Z ~> m] + real :: dVol_dL ! The partial derivative of the volume below with L [Z ~> m] + real :: vol_err_max ! The value of vol_err when L is L_max [Z ~> m] + + ! The following combinations of slope and crv are reused across layers, and hence are pre-calculated + ! for efficiency. All are non-negative. + real :: Icrvpslope ! The inverse of the sum of crv and slope [Z-1 ~> m-1] + real :: slope_crv ! The slope divided by the curvature [nondim] + ! These are only used if the slope exceeds or matches the curvature. + real :: smc ! The slope minus the curvature [Z ~> m] + real :: C3c_m_s ! 3 times the curvature minus the slope [Z ~> m] + real :: I_3c_m_s ! The inverse of 3 times the curvature minus the slope [Z-1 ~> m-1] + ! These are only used if the curvature exceeds the slope. + real :: C4_crv ! The inverse of a quarter of the curvature [Z-1 ~> m-1] + real :: sxcms_c ! The slope times the difference between the curvature and slope + ! divided by the curvature [Z ~> m] + real :: slope2_4crv ! A quarter of the slope squared divided by the curvature [Z ~> m] + real :: I_3s_m_c ! The inverse of 3 times the slope minus the curvature [Z-1 ~> m-1] + real :: C3s_m_c ! 3 times the slope minus the curvature [Z ~> m] + + real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim] + integer :: K, nz, itt + integer, parameter :: max_itt = 10 + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + if (crv <= 0.0) call MOM_error(FATAL, "find_L_open_concave should only be called with a positive curvature.") + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + L_2_reg = 1.0 + if (crv + slope >= 4.0*crv) then + L_inflect_1 = 1.0 ; Vol_inflect_1 = Vol_open + else + slope_crv = slope / crv + L_inflect_1 = 0.25 + 0.25*slope_crv + vol_inflect_1 = 0.25*C1_12 * ((slope_crv + 1.0)**2 * (slope + crv)) + endif + ! Precalculate some combinations of crv & slope for later use. + smc = slope - crv + C3c_m_s = 3.0*crv - slope + if (C3c_m_s > 2.0*smc) I_3c_m_s = 1.0 / C3c_m_s + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + L_2_reg = slope_crv + + ! The inflection point is useful to know because below the inflection point + ! Newton's method converges monotonically from above and conversely above it. + ! These are the inflection point values of L and vol_below with a single open segment. + vol_inflect_1 = 0.25*C1_12 * ((slope_crv + 1.0)**2 * (slope + crv)) + L_inflect_1 = 0.25 + 0.25*slope_crv + ! These are the inflection point values of L and vol_below when there are two open segments. + ! Vol_inflect_2 = Vol_open - 0.125 * crv_3, which is equivalent to: + vol_inflect_2 = 0.25*slope*slope_crv + 0.125*crv_3 + L_inflect_2 = 0.5 + ! Precalculate some combinations of crv & slope for later use. + C4_crv = 4.0 / crv + slope2_4crv = 0.25 * slope * slope_crv + sxcms_c = slope_crv*(crv - slope) + C3s_m_c = 3.0*slope - crv + if (C3s_m_c > 2.0*sxcms_c) I_3s_m_c = 1.0 / C3s_m_c + endif + ! Define some combinations of crv & slope for later use. + Icrvpslope = 1.0 / (crv+slope) + + L(nz+1) = 0.0 + ! Determine the normalized open length (L) at each interface. + do K=nz,1,-1 + if (vol_below(K) >= Vol_open) then ! The whole cell is open. + L(K) = 1.0 + elseif (vol_below(K) < Vol_2_reg) then + ! In this case, there is a single contiguous open region from x=1/2-L to 1/2. + ! Changing the horizontal variable in the expression from D(x) to D(L) gives: + ! x(L) = 1/2 - L + ! D(L) = crv*(0.5 - L)^2 + slope*(0.5 - L) + D_vel - crv/12 + ! D(L) = crv*L^2 - crv*L + crv/4 + slope*(1/2 - L) + D_vel - crv/12 + ! D(L) = crv*L^2 - (slope+crv)*L + slope/2 + D_vel + crv/6 + ! D(0) = slope/2 + D_vel + crv/6 = (Dp - Dm)/2 + D_vel + (Dp + Dm - 2*D_vel)/2 = Dp + ! D(1) = crv - slope - crv + slope/2 + Dvel + crv/6 = D_vel - slope/2 + crv/6 = Dm + ! + ! vol_below = integral(y = 0 to L) D(y) dy - L * D(L) + ! = crv/3*L^3 - (slope+crv)/2*L^2 + (slope/2 + D_vel + crv/6)*L - + ! (crv*L^2 - (slope+crv)*L + slope/2 + D_vel + crv/6) * L + ! = -2/3 * crv * L^3 + 1/2 * (slope+crv) * L^2 + ! vol_below(K) = 0.5*L(K)**2*(slope + crv_3*(3-4*L(K))) + ! L(K) is between L(K+1) and slope_crv. + L_max = min(L_2_reg, 1.0) + if (vol_below(K) <= vol_inflect_1) L_max = min(L_max, L_inflect_1) + + L_min = L(K+1) + if (vol_below(K) >= vol_inflect_1) L_min = max(L_min, L_inflect_1) + + ! Ignoring the cubic term gives an under-estimate but is very accurate for near bottom + ! layers, so use this as a potential floor. + if (2.0*vol_below(K)*Icrvpslope > L_min**2) L_min = sqrt(2.0*vol_below(K)*Icrvpslope) + + ! Start with L_min in most cases. + L(k) = L_min + + if (vol_below(K) <= vol_inflect_1) then + ! Starting with L_min below L_inflect_1, only the first overshooting iteration of Newton's + ! method needs bounding. + L(k) = L_min + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (L(K)*dVol_dL > vol_err + L_max*dVol_dL) then + L(K) = L_max + else + L(K) = L(K) - (vol_err / dVol_dL) + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + else ! (vol_below(K) > vol_inflect_1) + ! Iteration from below converges monotonically, but we need to deal with the case where we are + ! close to the peak of the topography and Newton's method mimics the convergence of bisection. + + ! Evaluate the error when L(K) = L_min as a possible first guess. + L(k) = L_min + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + + ! These two upper estimates deal with the possibility that this point may be near + ! the upper extrema, where the error term might be approximately parabolic and + ! Newton's method would converge slowly like simple bisection. + if (slope < crv) then + ! if ((L_2_reg - L_min)*(3.0*slope - crv) > 2.0*slope_crv*(crv-slope)) then + if ((L_2_reg - L_min)*C3s_m_c > 2.0*sxcms_c) then + ! There is a decent upper estimate of L from the approximate quadratic equation found + ! by examining the error expressions at L ~= L_2_reg and ignoring the cubic term. + L_max = (slope_crv*(2.0*slope) - sqrt(sxcms_c**2 + & + 2.0*C3s_m_c*(Vol_2_reg - vol_below(K))) ) * I_3s_m_c + ! The line above is equivalent to: + ! L_max = (slope_crv*(2.0*slope) - sqrt(slope_crv**2*(crv-slope)**2 + & + ! 2.0*(3.0*slope - crv)*(Vol_2_reg - vol_below(K))) ) / & + ! (3.0*slope - crv) + else + L_max = slope_crv + endif + else ! (slope >= crv) + if ((1.0 - L_min)*C3c_m_s > 2.0*smc) then + ! There is a decent upper estimate of L from the approximate quadratic equation found + ! by examining the error expressions at L ~= 1 and ignoring the cubic term. + L_max = ( 2.0*crv - sqrt(smc**2 + 2.0*C3c_m_s * (Vol_open - vol_below(K))) ) * I_3c_m_s + ! The line above is equivalent to: + ! L_max = ( 2.0*crv - sqrt((slope - crv)**2 + 2.0*(3.0*crv - slope) * (Vol_open - vol_below(K))) ) / & + ! (3.0*crv - slope) + else + L_max = 1.0 + endif + endif + Vol_err_max = 0.5*L_max**2 * (slope + crv*(1.0 - 4.0*C1_3*L_max)) - vol_below(K) + if (Vol_err_max < 0.0) call MOM_error(FATAL, & + "Vol_err_max should never be negative in find_L_open_concave_iterative.") + if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then + ! Start with 1 bounded Newton's method step from L_max + dVol_dL = L_max * (slope + crv*(1.0 - 2.0*L_max)) + L(K) = max(L_min, L_max - (vol_err_max / dVol_dL) ) + ! else ! Could use the fact that Vol_err is known to take an iteration? + endif + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + vol_err = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + dVol_dL = L(K) * (slope + crv*(1.0 - 2.0*L(k))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif -!> Determine the normalized open length of each interface for convex bathymetry (from the ocean perspective) using -!! Newton's method iterations. In this case there is a single open region with the minimum depth -!! at one edge of the cell. + endif + + ! To check the answers. + ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) + else ! There are two separate open regions. + ! vol_below(K) = slope^2/(4*crv) + crv/12 - (crv/12)*(1-L)^2*(1+2L) + ! At the deepest volume, L = slope/crv, at the top L = 1. + + ! To check the answers. + ! Vol_err = Vol_open - 0.25*crv_3*(1.0+2.0*L(K)) * (1.0-L(K))**2 - vol_below(K) + ! or equivalently: + ! Vol_err = Vol_open - 0.25*crv_3*(3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 - vol_below(K) + ! ! Note that: Vol_open = 0.25*slope*slope_crv + C1_12*crv + ! Vol_err = 0.25*slope*slope_crv + 0.25*crv_3*( 1.0 - (1.0 + 2.0*L(K)) * (1.0-L(K))**2 ) - vol_below(K) + ! Vol_err = 0.25*crv_3*L(K)**2*( 3.0 - 2.0*L(K) ) + 0.25*slope*slope_crv - vol_below(K) + + ! Derivation of the L_max limit below: + ! Vol_open - vol_below(K) = 0.25*crv_3*(3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 + ! (3.0-2.0*(1.0-L(K))) * (1.0-L(K))**2 = (Vol_open - vol_below(K)) / (0.25*crv_3) + ! When 1-L(K) << 1: + ! 3.0 * (1.0-L_max)**2 = (Vol_open - vol_below(K)) / (0.25*crv_3) + ! (1.0-L_max)**2 = (Vol_open - vol_below(K)) / (0.25*crv) + + ! Derivation of the L_min limit below: + ! Vol_err = 0.25*crv_3*L(K)**2*( 3.0 - 2.0*L(K) ) + 0.25*slope*slope_crv - vol_below(K) + ! crv*L(K)**2*( 1.0 - 2.0*C1_3*L(K) ) = 4.0*vol_below(K) - slope*slope_crv + ! When L(K) << 1: + ! crv*L_min**2 = 4.0*vol_below(K) - slope*slope_crv + ! L_min = sqrt((4.0*vol_below(K) - slope*slope_crv)/crv) + ! Noting that L(K) >= slope_crv, when L(K)-slope_crv << 1: + ! (crv + 2.0*C1_3*slope)*L_min**2 = 4.0*vol_below(K) - slope*slope_crv + ! L_min = sqrt((4.0*vol_below(K) - slope*slope_crv)/(crv + 2.0*C1_3*slope)) + + if (vol_below(K) <= Vol_inflect_2) then + ! Newton's Method would converge monotonically from above, but overshoot from below. + L_min = max(L(K+1), L_2_reg) ! L_2_reg = slope_crv + ! This under-estimate of L(K) is accurate for L ~= slope_crv: + if ((4.0*vol_below(K) - slope*slope_crv) > (crv + 2.0*C1_3*slope)*L_min**2) & + L_min = max(L_min, sqrt((4.0*vol_below(K) - slope*slope_crv) / (crv + 2.0*C1_3*slope))) + L_max = 0.5 ! = L_inflect_2 + + ! Starting with L_min below L_inflect_2, only the first overshooting iteration of Newton's + ! method needs bounding. + L(k) = L_min + Vol_err = crv_3*L(K)**2*( 0.75 - 0.5*L(K) ) + (slope2_4crv - vol_below(K)) + + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L_min is already the best solution. + if (vol_err < 0.0) then + dVol_dL = 0.5*crv * (L(K) * (1.0 - L(K))) + if (L(K)*dVol_dL >= vol_err + L_max*dVol_dL) then + L(K) = L_max + else + L(K) = L(K) - (vol_err / dVol_dL) + endif + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + Vol_err = crv_3 * (L(K)**2 * (0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + dVol_dL = 0.5*crv * (L(K)*(1.0 - L(K))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + else ! (vol_below(K) > Vol_inflect_2) + ! Newton's Method would converge monotonically from below, but overshoots from above, and + ! we may need to deal with the case where we are close to the peak of the topography. + L_min = max(L(K+1), 0.5) + L(k) = L_min + + Vol_err = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + ! If vol_err is 0 or positive (perhaps due to roundoff in L(K+1)), L(k) is already the best solution. + if (Vol_err < 0.0) then + ! This over-estimate of L(K) is accurate for L ~= 1: + L_max = 1.0 - sqrt( (Vol_open - vol_below(K)) * C4_crv ) + Vol_err_max = crv_3 * (L_max**2 * ( 0.75 - 0.5*L_max)) + (slope2_4crv - vol_below(K)) + if (Vol_err_max < 0.0) call MOM_error(FATAL, & + "Vol_err_max should never be negative in find_L_open_concave_iterative.") + if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then + ! Start with 1 bounded Newton's method step from L_max + dVol_dL = 0.5*crv * (L_max * (1.0 - L_max)) + L(K) = max(L_min, L_max - (vol_err_max / dVol_dL) ) + ! else ! Could use the fact that Vol_err is known to take an iteration? + endif + + ! Subsequent iterations of Newton's method do not need bounds. + do itt=1,max_itt + Vol_err = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + dVol_dL = 0.5*crv * (L(K) * (1.0 - L(K))) + if (abs(vol_err) < max(1.0e-15*L(K), 1.0e-25)*dVol_dL) exit + L(K) = L(K) - (vol_err / dVol_dL) + enddo + endif + endif + + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine find_L_open_concave_iterative + +!> Determine the normalized open length of each interface for convex bathymetry (from the ocean +!! perspective) using Newton's method iterations. In this case there is a single open region +!! with the minimum depth at one edge of the cell. subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by @@ -1226,7 +1572,7 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) ! Each cell extends from x=-1/2 to 1/2, and has a topography ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 - if (crv > 0.0) call MOM_error(FATAL, "find_L_open_convex should only be called with a negative curvature.") + if (crv >= 0.0) call MOM_error(FATAL, "find_L_open_convex should only be called with a negative curvature.") slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the @@ -1252,7 +1598,7 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) elseif (vol_below(K) <= Vol_direct) then ! Both edges of the cell are bounded by walls. ! if (CS%answer_date < 20240101)) then - L(K) = (-0.25*C24_crv*vol_below(K))**C1_3 + L(K) = (-0.25*C24_crv*vol_below(K))**C1_3 ! else ! L(K) = cuberoot(-0.25*C24_crv*vol_below(K)) ! endif @@ -2592,8 +2938,13 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS "default is to use the same value as SMAG_LAP_CONST if "//& "it is defined, or 0.15 if it is not. The value used is "//& "also 0.15 if the specified value is negative.", & - units="nondim", default=cSmag_chan_dflt) + units="nondim", default=cSmag_chan_dflt, do_not_log=.not.CS%Channel_drag) if (CS%c_Smag < 0.0) CS%c_Smag = 0.15 + + call get_param(param_file, mdl, "TRIG_CHANNEL_DRAG_WIDTHS", CS%concave_trigonometric_L, & + "If true, use trigonometric expressions to determine the fractional open "//& + "interface lengths for concave topography.", & + default=.true., do_not_log=.not.CS%Channel_drag) endif Chan_max_thick_dflt = -1.0*US%m_to_Z From e1ea75847e97b4dc2a2dd375d4826afe493b70c0 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 15 Jan 2024 16:02:41 -0500 Subject: [PATCH 551/629] Add the debugging routine test_L_open_concave Added the new debugging or testing subroutine test_L_open_concave along with extra calls when DEBUG = True that can be used to demonstrate that the iterative solver in find_L_open_concave_iterative is substantially more accurate but mathematically equivalent to the solver in find_L_open_concave_trigonometric. This extra code is only called in debugging mode, and it probably should be deleted in a separate commit after find_L_open_concave_iterative has been accepted onto the dev/gfdl branch of MOM6. All answers are bitwise identical and no output or input is changed. --- .../vertical/MOM_set_viscosity.F90 | 112 +++++++++++++++++- 1 file changed, 109 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index b25d660957..1778b8d870 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -270,11 +270,19 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! horizontal area of a velocity cell [Z ~> m]. real :: L(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface [nondim]. + ! The next 9 variables are only used for debugging. real :: L_trig(SZK_(GV)+1) ! The fraction of the full cell width that is open at ! the depth of each interface from trigonometric expressions [nondim]. + real :: vol_err_trig(SZK_(GV)+1) ! The error in the volume below based on L_trig [Z ~> m] + real :: vol_err_iter(SZK_(GV)+1) ! The error in the volume below based on L_iter [Z ~> m] + real :: norm_err_trig(SZK_(GV)+1) ! vol_err_trig normalized by vol_below [nondim] + real :: norm_err_iter(SZK_(GV)+1) ! vol_err_iter normalized by vol_below [nondim] real :: dL_trig_itt(SZK_(GV)+1) ! The difference between estimates of the fraction of the full cell ! width that is open at the depth of each interface [nondim]. real :: max_dL_trig_itt ! The largest difference between L and L_trig, for debugging [nondim] + real :: max_norm_err_trig ! The largest magnitude value of norm_err_trig in a column [nondim] + real :: max_norm_err_iter ! The largest magnitude value of norm_err_iter in a column [nondim] + real :: h_neglect ! A thickness that is so small it is usually lost ! in roundoff and can be neglected [H ~> m or kg m-2]. real :: dz_neglect ! A vertical distance that is so small it is usually lost @@ -878,14 +886,29 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) else call find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) if (CS%debug) then + ! The tests in this block reveal that the iterative and trigonometric solutions are + ! mathematically equiavalent, but in some cases the iterative solution is consistent + ! at roundoff, but that the trigonmetric solutions have errors that can be several + ! orders of magnitude larger in some cases. call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L_trig, GV) - max_dL_trig_itt = 0.0 + call test_L_open_concave(vol_below, D_vel, Dp, Dm, L_trig, vol_err_trig, GV) + call test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err_iter, GV) + max_dL_trig_itt = 0.0 ; max_norm_err_trig = 0.0 ; max_norm_err_iter = 0.0 + norm_err_trig(:) = 0.0 ; norm_err_iter(:) = 0.0 do K=1,nz+1 dL_trig_itt(K) = L_trig(K) - L(K) if (abs(dL_trig_itt(K)) > abs(max_dL_trig_itt)) max_dL_trig_itt = dL_trig_itt(K) + norm_err_trig(K) = vol_err_trig(K) / (vol_below(K) + dz_neglect) + norm_err_iter(K) = vol_err_iter(K) / (vol_below(K) + dz_neglect) + if (abs(norm_err_trig(K)) > abs(max_norm_err_trig)) max_norm_err_trig = norm_err_trig(K) + if (abs(norm_err_iter(K)) > abs(max_norm_err_iter)) max_norm_err_iter = norm_err_iter(K) enddo - if (abs(max_dL_trig_itt) > 1.0e-12) & - K = nz+1 ! This is here to use with a debugger only. + if (abs(max_dL_trig_itt) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + if (abs(max_norm_err_trig) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. + if (abs(max_norm_err_iter) > 1.0e-13) & + K = nz+1 ! This is here only to use as a break point for a debugger. endif endif else ! crv < 0.0 @@ -1517,6 +1540,89 @@ subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) end subroutine find_L_open_concave_iterative + + +!> Test the validity the normalized open lengths of each interface for concave bathymetry (from the ocean perspective) +!! by evaluating and returing the relevant cubic equations. +subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV) + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by + !! the full horizontal area of a velocity cell [Z ~> m] + real, intent(in) :: D_vel !< The average bottom depth at a velocity point [Z ~> m] + real, intent(in) :: Dp !< The larger of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, intent(in) :: Dm !< The smaller of the two depths at the edge + !! of a velocity cell [Z ~> m] + real, dimension(SZK_(GV)+1), intent(in) :: L !< The fraction of the full cell width that is open at + !! the depth of each interface [nondim] + real, dimension(SZK_(GV)+1), intent(out) :: vol_err !< The difference between vol_below and the + !! value obtained from using L in the cubic equation [Z ~> m] + + ! Local variables + real :: crv ! crv is the curvature of the bottom depth across a + ! cell, times the cell width squared [Z ~> m]. + real :: crv_3 ! crv/3 [Z ~> m]. + real :: slope ! The absolute value of the bottom depth slope across + ! a cell times the cell width [Z ~> m]. + + ! The following "volumes" have units of vertical heights because they are normalized + ! by the full horizontal area of a velocity cell. + real :: Vol_open ! The cell volume above which the face is fully is open [Z ~> m]. + real :: Vol_2_reg ! The cell volume above which there are two separate + ! open areas that must be integrated [Z ~> m]. + real :: L_2_reg ! The value of L when vol_below is Vol_2_reg [nondim] + + ! The following combinations of slope and crv are reused across layers, and hence are pre-calculated + ! for efficiency. All are non-negative. + real :: slope_crv ! The slope divided by the curvature [nondim] + ! These are only used if the curvature exceeds the slope. + real :: slope2_4crv ! A quarter of the slope squared divided by the curvature [Z ~> m] + + real, parameter :: C1_3 = 1.0 / 3.0, C1_12 = 1.0 / 12.0 ! Rational constants [nondim] + integer :: K, nz + + nz = GV%ke + + ! Each cell extends from x=-1/2 to 1/2, and has a topography + ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. + + crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + if (crv <= 0.0) call MOM_error(FATAL, "test_L_open_concave should only be called with a positive curvature.") + slope = Dp - Dm + + ! Calculate the volume above which the entire cell is open and the volume at which the + ! equation that is solved for L changes because there are two separate open regions. + if (slope >= crv) then + Vol_open = D_vel - Dm ; Vol_2_reg = Vol_open + L_2_reg = 1.0 + if (crv + slope >= 4.0*crv) then + slope_crv = 1.0 + else + slope_crv = slope / crv + endif + else + slope_crv = slope / crv + Vol_open = 0.25*slope*slope_crv + C1_12*crv + Vol_2_reg = 0.5*slope_crv**2 * (crv - C1_3*slope) + L_2_reg = slope_crv + endif + slope2_4crv = 0.25 * slope * slope_crv + + ! Determine the volume error based on the normalized open length (L) at each interface. + Vol_err(nz+1) = 0.0 + do K=nz,1,-1 + if (L(K) >= 1.0) then + Vol_err(K) = max(Vol_open - vol_below(K), 0.0) + elseif (L(K) <= L_2_reg) then + vol_err(K) = 0.5*L(K)**2 * (slope + crv*(1.0 - 4.0*C1_3*L(K))) - vol_below(K) + else ! There are two separate open regions. + Vol_err(K) = crv_3 * (L(K)**2 * ( 0.75 - 0.5*L(K))) + (slope2_4crv - vol_below(K)) + endif + enddo ! k loop to determine L(K) in the concave case + +end subroutine test_L_open_concave + + !> Determine the normalized open length of each interface for convex bathymetry (from the ocean !! perspective) using Newton's method iterations. In this case there is a single open region !! with the minimum depth at one edge of the cell. From 714d2da17ed29d34f73e88513192acb9439e1061 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Mar 2024 07:10:00 -0500 Subject: [PATCH 552/629] Minor refactoring in set_viscous_BBL Carried out minor refactoring in set_viscous_BBL as suggested by the reviews of this PR, including the elimination of some unnecessary error handling and the replacement of C2pi_3 as an argument to find_L_open_concave_trigonometric with an internal parameter. All answers are bitwise identical and there are no changes to publicly visible interfaces. --- .../vertical/MOM_set_viscosity.F90 | 29 +++++++------------ 1 file changed, 11 insertions(+), 18 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 1778b8d870..60298f9226 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -260,7 +260,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: Dp, Dm ! The depths at the edges of a velocity cell [Z ~> m]. real :: crv ! crv is the curvature of the bottom depth across a ! cell, times the cell width squared [Z ~> m]. - real :: crv_3 ! crv/3 [Z ~> m]. real :: slope ! The absolute value of the bottom depth slope across ! a cell times the cell width [Z ~> m]. real :: Vol_bbl_chan ! The volume of the bottom boundary layer as used in the channel @@ -304,7 +303,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: h_sum ! The sum of the thicknesses of the layers below the one being ! worked on [H ~> m or kg m-2]. real, parameter :: C1_3 = 1.0/3.0, C1_6 = 1.0/6.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] - real :: C2pi_3 ! An irrational constant, 2/3 pi. [nondim] real :: tmp ! A temporary variable, sometimes in [Z ~> m] logical :: use_BBL_EOS, do_i(SZIB_(G)) integer, dimension(2) :: EOSdom ! The computational domain for the equation of state @@ -318,7 +316,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) dz_neglect = GV%dZ_subroundoff Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) - C2pi_3 = 8.0*atan(1.0)/3.0 if (.not.CS%initialized) call MOM_error(FATAL,"MOM_set_viscosity(BBL): "//& "Module must be initialized before it is used.") @@ -424,7 +421,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (allocated(visc%Ray_v)) visc%Ray_v(:,:,:) = 0.0 !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, & - !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G,C2pi_3, & + !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G, & !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & !$OMP OBC,D_u,D_v,mask_u,mask_v,pbv) @@ -870,7 +867,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) Dm = 2.0 * D_vel * tmp / (D_vel + tmp) endif if (Dm > Dp) then ; tmp = Dp ; Dp = Dm ; Dm = tmp ; endif - crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + crv = 3.0*(Dp + Dm - 2.0*D_vel) slope = Dp - Dm ! If the curvature is small enough, there is no reason not to assume @@ -882,15 +879,15 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) call find_L_open_uniform_slope(vol_below, Dp, Dm, L, GV) elseif (crv > 0.0) then if (CS%concave_trigonometric_L) then - call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) else call find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) if (CS%debug) then ! The tests in this block reveal that the iterative and trigonometric solutions are - ! mathematically equiavalent, but in some cases the iterative solution is consistent + ! mathematically equivalent, but in some cases the iterative solution is consistent ! at roundoff, but that the trigonmetric solutions have errors that can be several ! orders of magnitude larger in some cases. - call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L_trig, GV) + call find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L_trig, GV) call test_L_open_concave(vol_below, D_vel, Dp, Dm, L_trig, vol_err_trig, GV) call test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err_iter, GV) max_dL_trig_itt = 0.0 ; max_norm_err_trig = 0.0 ; max_norm_err_iter = 0.0 @@ -1128,7 +1125,7 @@ end subroutine find_L_open_uniform_slope !> Determine the normalized open length of each interface for concave bathymetry (from the ocean perspective) !! using trigonometric expressions. In this case there can be two separate open regions. -subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L, GV) +subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZK_(GV)+1), intent(in) :: vol_below !< The volume below each interface, normalized by !! the full horizontal area of a velocity cell [Z ~> m] @@ -1137,7 +1134,6 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L !! of a velocity cell [Z ~> m] real, intent(in) :: Dm !< The smaller of the two depths at the edge !! of a velocity cell [Z ~> m] - real, intent(in) :: C2pi_3 !< An irrational constant, 2/3 pi [nondim] real, dimension(SZK_(GV)+1), intent(out) :: L !< The fraction of the full cell width that is open at !! the depth of each interface [nondim] @@ -1159,6 +1155,7 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L real :: slope_crv ! The slope divided by the curvature [nondim] real :: tmp_val_m1_to_p1 ! A temporary variable [nondim] real, parameter :: C1_3 = 1.0/3.0, C1_12 = 1.0/12.0 ! Rational constants [nondim] + real, parameter :: C2pi_3 = 8.0*atan(1.0)/3.0 ! An irrational constant, 2/3 pi. [nondim] integer :: K, nz nz = GV%ke @@ -1166,7 +1163,6 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, C2pi_3, L ! Each cell extends from x=-1/2 to 1/2, and has a topography ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 - if (crv <= 0.0) call MOM_error(FATAL, "find_L_open_concave should only be called with a positive curvature.") slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the @@ -1284,7 +1280,6 @@ subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 - if (crv <= 0.0) call MOM_error(FATAL, "find_L_open_concave should only be called with a positive curvature.") slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the @@ -1424,8 +1419,8 @@ subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) endif endif Vol_err_max = 0.5*L_max**2 * (slope + crv*(1.0 - 4.0*C1_3*L_max)) - vol_below(K) - if (Vol_err_max < 0.0) call MOM_error(FATAL, & - "Vol_err_max should never be negative in find_L_open_concave_iterative.") + ! if (Vol_err_max < 0.0) call MOM_error(FATAL, & + ! "Vol_err_max should never be negative in find_L_open_concave_iterative.") if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then ! Start with 1 bounded Newton's method step from L_max dVol_dL = L_max * (slope + crv*(1.0 - 2.0*L_max)) @@ -1516,8 +1511,8 @@ subroutine find_L_open_concave_iterative(vol_below, D_vel, Dp, Dm, L, GV) ! This over-estimate of L(K) is accurate for L ~= 1: L_max = 1.0 - sqrt( (Vol_open - vol_below(K)) * C4_crv ) Vol_err_max = crv_3 * (L_max**2 * ( 0.75 - 0.5*L_max)) + (slope2_4crv - vol_below(K)) - if (Vol_err_max < 0.0) call MOM_error(FATAL, & - "Vol_err_max should never be negative in find_L_open_concave_iterative.") + ! if (Vol_err_max < 0.0) call MOM_error(FATAL, & + ! "Vol_err_max should never be negative in find_L_open_concave_iterative.") if ((Vol_err_max < abs(Vol_err)) .and. (L_max < 1.0)) then ! Start with 1 bounded Newton's method step from L_max dVol_dL = 0.5*crv * (L_max * (1.0 - L_max)) @@ -1587,7 +1582,6 @@ subroutine test_L_open_concave(vol_below, D_vel, Dp, Dm, L, vol_err, GV) ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 - if (crv <= 0.0) call MOM_error(FATAL, "test_L_open_concave should only be called with a positive curvature.") slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the @@ -1678,7 +1672,6 @@ subroutine find_L_open_convex(vol_below, D_vel, Dp, Dm, L, GV, US, CS) ! Each cell extends from x=-1/2 to 1/2, and has a topography ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 - if (crv >= 0.0) call MOM_error(FATAL, "find_L_open_convex should only be called with a negative curvature.") slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the From 6153d97ad5d6ed0c81e95382710cac313ef64973 Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Sat, 9 Mar 2024 10:50:07 -0500 Subject: [PATCH 553/629] Compute dz in the halo for OBC segments It was blowing up with "forrtl: error (65): floating invalid" when accessing dz in the halo at the boundary, but just sometimes. My default layout is trouble while my testing layout of 48 cores is not. --- src/core/MOM.F90 | 5 ++++- src/tracer/MOM_tracer_advect.F90 | 3 ++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9d64b9bf17..53f20bb10b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1436,8 +1436,11 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (CS%debug) call MOM_tracer_chksum("Post-diffuse ", CS%tracer_Reg, G) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") - call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & + if (associated(CS%OBC)) then + call pass_vector(CS%uhtr, CS%vhtr, G%Domain) + call update_segment_tracer_reservoirs(G, GV, CS%uhtr, CS%vhtr, h, CS%OBC, & CS%t_dyn_rel_adv, CS%tracer_Reg) + endif call cpu_clock_end(id_clock_tracer) ; call cpu_clock_end(id_clock_thermo) call cpu_clock_begin(id_clock_other) ; call cpu_clock_begin(id_clock_diagnostics) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index efe6397de0..ef2c3125cd 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -123,7 +123,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first x_first = (MOD(G%first_direction,2) == 0) ! increase stencil size for Colella & Woodward PPM - if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 +! if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 + if (CS%usePPM) stencil = 3 ntr = Reg%ntr Idt = 1.0 / dt From 0ff03aea4badc0634d0f024e96d1385255724e29 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 6 Feb 2024 16:32:58 -0500 Subject: [PATCH 554/629] +Fix myStats global indexing segmentation faults Revised the interfaces to the myStats routine in the horizontal_regridding module to avoid segmentation faults due to inconsistent horizontal indices and array extents in global indexing mode. Rather than passing in absolute array extents to work on, an ocean grid type is now passed as an argument to myStats, with the new optional full_halo argument used to capture the case where the tracer statistics are being taken over the full data domain. The most frequently encountered problems occurred when the hard-coded debug variable in the horiz_interp_and_extrap_tracer routines are changed from false to true. When global indexing is not used, this revised work exactly as before, but when it is used with global indexing, it avoids segmentation faults that were preventing the model from running in some cases with all debugging enabled. --- src/framework/MOM_horizontal_regridding.F90 | 44 +++++++++++-------- .../MOM_tracer_initialization_from_Z.F90 | 2 +- 2 files changed, 26 insertions(+), 20 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 34d0b73cb9..205dd6d7be 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -44,27 +44,32 @@ module MOM_horizontal_regridding contains !> Write to the terminal some basic statistics about the k-th level of an array -subroutine myStats(array, missing, is, ie, js, je, k, mesg, scale) - real, dimension(:,:), intent(in) :: array !< input array in arbitrary units [A ~> a] - real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] - integer, intent(in) :: is !< Start index in i - integer, intent(in) :: ie !< End index in i - integer, intent(in) :: js !< Start index in j - integer, intent(in) :: je !< End index in j - integer, intent(in) :: k !< Level to calculate statistics for - character(len=*), intent(in) :: mesg !< Label to use in message - real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] +subroutine myStats(array, missing, G, k, mesg, scale, full_halo) + type(ocean_grid_type), intent(in) :: G !< Ocean grid type + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: array !< input array in arbitrary units [A ~> a] + real, intent(in) :: missing !< missing value in arbitrary units [A ~> a] + integer, intent(in) :: k !< Level to calculate statistics for + character(len=*), intent(in) :: mesg !< Label to use in message + real, optional, intent(in) :: scale !< A scaling factor for output [a A-1 ~> 1] + logical, optional, intent(in) :: full_halo !< If present and true, test values on the whole + !! array rather than just the computational domain. ! Local variables real :: minA ! Minimum value in the array in the arbitrary units of the input array [A ~> a] real :: maxA ! Maximum value in the array in the arbitrary units of the input array [A ~> a] real :: scl ! A factor for undoing any scaling of the array statistics for output [a A-1 ~> 1] - integer :: i,j + integer :: i, j, is, ie, js, je logical :: found character(len=120) :: lMesg scl = 1.0 ; if (present(scale)) scl = scale minA = 9.E24 / scl ; maxA = -9.E24 / scl ; found = .false. + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + if (present(full_halo)) then ; if (full_halo) then + is = G%isd ; ie = G%ied ; js = G%jsd ; je = G%jed + endif ; endif + do j=js,je ; do i=is,ie if (array(i,j) /= array(i,j)) stop 'Nan!' if (abs(array(i,j)-missing) > 1.e-6*abs(missing)) then @@ -309,7 +314,7 @@ 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 + 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 @@ -332,7 +337,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr real :: npole ! The number of points contributing to the pole value [nondim] real :: missing_val_in ! The missing value in the input field [a] real :: roundoff ! The magnitude of roundoff, usually ~2e-16 [nondim] - real :: add_offset, scale_factor ! File-specific conversion factors. + real :: add_offset, scale_factor ! File-specific conversion factors [a] or [nondim] integer :: ans_date ! The vintage of the expressions and order of arithmetic to use logical :: found_attr logical :: add_np @@ -545,7 +550,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr endif if (debug) then - call myStats(tr_inp, missing_value, 1, id, 1, jd, k, 'Tracer from file', scale=I_scale) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) endif call run_horiz_interp(Interp, tr_inp, tr_out(is:ie,js:je), missing_value=missing_value) @@ -568,11 +573,12 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr (mask_out(i,j) < 1.0)) & fill(i,j) = 1.0 enddo ; enddo + call pass_var(fill, G%Domain) call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -589,7 +595,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr call fill_miss_2d(tr_outf, good2, fill2, tr_prev, G, dtr_iter_stop, answer_date=ans_date) if (debug) then - call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()', scale=I_scale) + call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) @@ -850,7 +856,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & endif if (debug) then - call myStats(tr_inp, missing_value, 1, id, 1, jd, k, 'Tracer from file', scale=I_scale) + call myStats(tr_inp, missing_value, G, k, 'Tracer from file', scale=I_scale, full_halo=.true.) endif tr_out(:,:) = 0.0 @@ -878,7 +884,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & call pass_var(good, G%Domain) if (debug) then - call myStats(tr_out, missing_value, is, ie, js, je, k, 'variable from horiz_interp()', scale=I_scale) + call myStats(tr_out, missing_value, G, k, 'variable from horiz_interp()', scale=I_scale) endif ! Horizontally homogenize data to produce perfectly "flat" initial conditions @@ -897,7 +903,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & ! if (debug) then ! call hchksum(tr_outf, 'field from fill_miss_2d ', G%HI, scale=I_scale) -! call myStats(tr_outf, missing_value, is, ie, js, je, k, 'field from fill_miss_2d()', scale=I_scale) +! call myStats(tr_outf, missing_value, G, k, 'field from fill_miss_2d()', scale=I_scale) ! endif tr_z(:,:,k) = tr_outf(:,:) * G%mask2dT(:,:) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index 5a172b5d97..d28a925c03 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -217,7 +217,7 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ deallocate( h1 ) do k=1,nz - call myStats(tr(:,:,k), missing_value, is, ie, js, je, k, 'Tracer from ALE()') + call myStats(tr(:,:,k), missing_value, G, k, 'Tracer from ALE()') enddo call cpu_clock_end(id_clock_ALE) endif ! useALEremapping From 0bd4c160b2d42564effe11918134f597dfb05634 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 7 Feb 2024 20:46:41 -0500 Subject: [PATCH 555/629] (*)Fix apply_topography_edits_from_file indexing Corrected bugs in the horizontal indexing in apply_topography_edits_from_file that led to differing answers depending on the value of GLOBAL_INDEXING. This change gives identical results when GLOBAL_INDEXING is used, as can be seen by noting that G%idg_offset = G%isd_global + G%isd and that without global indexing G%isd = 1, but with global indexing the new expressions give the same answers as without them. Because global indexing is not typically used, answers are not changed for any cases in the MOM6-examples test suite. --- src/initialization/MOM_shared_initialization.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/initialization/MOM_shared_initialization.F90 b/src/initialization/MOM_shared_initialization.F90 index 46d0448699..821232b80d 100644 --- a/src/initialization/MOM_shared_initialization.F90 +++ b/src/initialization/MOM_shared_initialization.F90 @@ -256,8 +256,8 @@ subroutine apply_topography_edits_from_file(D, G, param_file, US) call close_file_to_read(ncid, topo_edits_file) do n = 1, n_edits - i = ig(n) - G%isd_global + 2 ! +1 for python indexing and +1 for ig-isd_global+1 - j = jg(n) - G%jsd_global + 2 + i = ig(n) - G%idg_offset + 1 ! +1 for python indexing + j = jg(n) - G%jdg_offset + 1 if (i>=G%isc .and. i<=G%iec .and. j>=G%jsc .and. j<=G%jec) then if (new_depth(n) /= mask_depth) then write(stdout,'(a,3i5,f8.2,a,f8.2,2i4)') & From 9e78615cb396250120bde2a6e6bb4426cd58bbbd Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 4 Feb 2024 09:08:35 -0500 Subject: [PATCH 556/629] Earlier initialization thickness halo updates Moved the post-initialization halo updates for thicknesses and temperatures and salinities in initialize_MOM to occur immediately after the last point where they are modified and before the remapped diagnostic grids are set up. This does not change any existing answers but it will enable the future use of the thermo_var_ptr type in calls to thickness_to_dz when setting up remapped diagnostics, and perhaps elsewhere in the initialization of other auxiliary variables. All answers are bitwise identical. --- src/core/MOM.F90 | 43 ++++++++++++++++++++++++------------------- 1 file changed, 24 insertions(+), 19 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 53f20bb10b..2bf2b11b1a 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3117,6 +3117,29 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif if ( CS%use_ALE_algorithm ) call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) + ! The basic state variables have now been fully initialized, so update their halos and + ! calculate any derived thermodynmics quantities. + + !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM + call cpu_clock_begin(id_clock_pass_init) + dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) + call create_group_pass(pass_uv_T_S_h, CS%u, CS%v, G%Domain, halo=dynamics_stencil) + if (use_temperature) then + call create_group_pass(pass_uv_T_S_h, CS%tv%T, G%Domain, halo=dynamics_stencil) + call create_group_pass(pass_uv_T_S_h, CS%tv%S, G%Domain, halo=dynamics_stencil) + endif + call create_group_pass(pass_uv_T_S_h, CS%h, G%Domain, halo=dynamics_stencil) + + call do_group_pass(pass_uv_T_S_h, G%Domain) + if (associated(CS%tv%p_surf)) call pass_var(CS%tv%p_surf, G%Domain, halo=dynamics_stencil) + call cpu_clock_end(id_clock_pass_init) + + ! 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, debug=CS%debug) + endif + + diag => CS%diag ! Initialize the diag mediator. call diag_mediator_init(G, GV, US, GV%ke, param_file, diag, doc_file_dir=dirs%output_directory) @@ -3137,7 +3160,6 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Whenever thickness/T/S changes let the diag manager know, target grids ! for vertical remapping may need to be regenerated. - ! FIXME: are h, T, S updated at the same time? Review these for T, S updates. call diag_update_remap_grids(diag) ! Setup the diagnostic grid storage types @@ -3287,30 +3309,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & call ALE_register_diags(Time, G, GV, US, diag, CS%ALE_CSp) endif - !--- set up group pass for u,v,T,S and h. pass_uv_T_S_h also is used in step_MOM + ! Do any necessary halo updates on any auxiliary variables that have been initialized. call cpu_clock_begin(id_clock_pass_init) - dynamics_stencil = min(3, G%Domain%nihalo, G%Domain%njhalo) - call create_group_pass(pass_uv_T_S_h, CS%u, CS%v, G%Domain, halo=dynamics_stencil) - if (use_temperature) then - call create_group_pass(pass_uv_T_S_h, CS%tv%T, G%Domain, halo=dynamics_stencil) - call create_group_pass(pass_uv_T_S_h, CS%tv%S, G%Domain, halo=dynamics_stencil) - endif - call create_group_pass(pass_uv_T_S_h, CS%h, G%Domain, halo=dynamics_stencil) - - call do_group_pass(pass_uv_T_S_h, G%Domain) - - ! Update derived thermodynamic quantities. - if (associated(CS%tv%p_surf)) call pass_var(CS%tv%p_surf, G%Domain, halo=dynamics_stencil) - if (allocated(CS%tv%SpV_avg)) then - call calc_derived_thermo(CS%tv, CS%h, G, GV, US, halo=dynamics_stencil, debug=CS%debug) - endif - if (associated(CS%visc%Kv_shear)) & call pass_var(CS%visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) if (associated(CS%visc%Kv_slow)) & call pass_var(CS%visc%Kv_slow, G%Domain, To_All+Omit_Corners, halo=1) - call cpu_clock_end(id_clock_pass_init) ! This subroutine initializes any tracer packages. From 1ae2a3a35ecf9d26a0b4550850d310a9440d6c38 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 5 Feb 2024 07:57:17 -0500 Subject: [PATCH 557/629] +(*)Refactor MOM_diag_remap for global indices Refactored MOM_diag_remap to work with global indices and to move logical branches outside of do loops. This was done by adding internal routines that set the loop indices consistently with the NE c-grid convention used throughout the MOM6 code and converting the optionally associated mask pointer into an optional argument. It also simplifies the logic of many of the expressions within the remapping code. There is also a new element, Z_based_coord, in the diag_remap_ctrl type, to indicate whether the remapping is working in thickness or height units, but for now it is always set to false. The function set_h_neglect or set_dz_neglect is used to set the negligible thicknesses used for remapping in diag_remap_update and diag_remap_do_remap, depending on whether the remapping is being done in thickness or vertical height coordinates. Diag_remap_init has a new vertical_grid_type argument, and diag_remap_do_remap has a new unit_scale_type argument. For REMAPPING_ANSWER_DATES later than 20240201, diag_remap_updated does an explicit sum to determine the total water column thickness, rather than using sum function, which is indeterminate of the order of the sums. For some compilers, this could change the vertical grids used for remapping diagnostics at roundoff, but no such change was detected for any of the compilers used with the MOM6 regression test suite. All answers and diagnostics in cases that worked before are bitwise identical, but there are new arguments to two publicly visible interfaces. --- src/framework/MOM_diag_mediator.F90 | 4 +- src/framework/MOM_diag_remap.F90 | 720 +++++++++++++++++----------- 2 files changed, 439 insertions(+), 285 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 2c71a93e42..61bfa93046 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -1583,7 +1583,7 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, diag_cs%GV, h_diag, staggered_in_x, staggered_in_y, & + diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, staggered_in_x, staggered_in_y, & diag%axes%mask3d, field, remapped_field) if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then @@ -3207,7 +3207,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) allocate(diag_cs%diag_remap_cs(diag_cs%num_diag_coords)) ! Initialize each diagnostic vertical coordinate do i=1, diag_cs%num_diag_coords - call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answer_date=remap_answer_date) + call diag_remap_init(diag_cs%diag_remap_cs(i), diag_coords(i), answer_date=remap_answer_date, GV=GV) enddo deallocate(diag_coords) endif diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index 0e2e594403..cd9e22aae2 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -15,42 +15,14 @@ !! the diagnostic is written out. -! NOTE: In the following functions, the fields are passed using 1-based -! indexing, which requires special handling within the grid index loops. +! NOTE: In the following functions, the fields are initially passed using 1-based +! indexing, which are then passed to separate private internal routines that shift +! the indexing to use the same indexing conventions used elsewhere in the MOM6 code. ! -! * diag_remap_do_remap -! * vertically_reintegrate_diag_field -! * vertically_interpolate_diag_field -! * horizontally_average_diag_field -! -! Symmetric grids add an additional row of western and southern points to u- -! and v-grids. Non-symmetric grids are 1-based and symmetric grids are -! zero-based, allowing the same expressions to be used when accessing the -! fields. But if u- or v-points become 1-indexed, as in these functions, then -! the stencils must be re-assessed. -! -! For interpolation between h and u grids, we use the following relations: -! -! h->u: f_u(ig) = 0.5 * (f_h( ig ) + f_h(ig+1)) -! f_u(i1) = 0.5 * (f_h(i1-1) + f_h( i1 )) -! -! u->h: f_h(ig) = 0.5 * (f_u(ig-1) + f_u( ig )) -! f_h(i1) = 0.5 * (f_u( i1 ) + f_u(i1+1)) -! -! where ig is the grid index and i1 is the 1-based index. That is, a 1-based -! u-point is ahead of its matching h-point in non-symmetric mode, but behind -! its matching h-point in non-symmetric mode. -! -! We can combine these expressions by applying to ig a -1 shift on u-grids and -! a +1 shift on h-grids in symmetric mode. -! -! We do not adjust the h-point indices, since they are assumed to be 1-based. -! This is only correct when global indexing is disabled. If global indexing is -! enabled, then all indices will need to be defined relative to the data -! domain. -! -! Finally, note that the mask input fields are pointers to arrays which are -! zero-indexed, and do not need any corrections over grid index loops. +! * diag_remap_do_remap, which calls do_remap +! * vertically_reintegrate_diag_field, which calls vertically_reintegrate_field +! * vertically_interpolate_diag_field, which calls vertically_interpolate_field +! * horizontally_average_diag_field, which calls horizontally_average_field module MOM_diag_remap @@ -70,10 +42,9 @@ module MOM_diag_remap use MOM_EOS, only : EOS_type use MOM_remapping, only : remapping_CS, initialize_remapping, remapping_core_h use MOM_remapping, only : interpolate_column, reintegrate_column -use MOM_regridding, only : regridding_CS, initialize_regridding -use MOM_regridding, only : end_regridding +use MOM_regridding, only : regridding_CS, initialize_regridding, end_regridding use MOM_regridding, only : set_regrid_params, get_regrid_size -use MOM_regridding, only : getCoordinateInterfaces +use MOM_regridding, only : getCoordinateInterfaces, set_h_neglect, set_dz_neglect use MOM_regridding, only : get_zlike_CS, get_sigma_CS, get_rho_CS use regrid_consts, only : coordinateMode use coord_zlike, only : build_zstar_column @@ -83,6 +54,8 @@ module MOM_diag_remap implicit none ; private +#include "MOM_memory.h" + public diag_remap_ctrl public diag_remap_init, diag_remap_end, diag_remap_update, diag_remap_do_remap public diag_remap_configure_axes, diag_remap_axes_configured @@ -104,14 +77,19 @@ module MOM_diag_remap logical :: used = .false. !< Whether this coordinate actually gets used. integer :: vertical_coord = 0 !< The vertical coordinate that we remap to character(len=10) :: vertical_coord_name ='' !< The coordinate name as understood by ALE + logical :: Z_based_coord = .false. !< If true, this coordinate is based on remapping of + !! geometric distances across layers (in [Z ~> m]) rather + !! than layer thicknesses (in [H ~> m or kg m-2]). This + !! distinction only matters in non-Boussinesq mode. character(len=16) :: diag_coord_name = '' !< A name for the purpose of run-time parameters character(len=8) :: diag_module_suffix = '' !< The suffix for the module to appear in diag_table type(remapping_CS) :: remap_cs !< Remapping control structure use for this axes type(regridding_CS) :: regrid_cs !< Regridding control structure that defines the coordinates for this axes integer :: nz = 0 !< Number of vertical levels used for remapping - real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses [H ~> m or kg m-2] - real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses for extensive - !! variables [H ~> m or kg m-2] + real, dimension(:,:,:), allocatable :: h !< Remap grid thicknesses in [H ~> m or kg m-2] or + !! vertical extents in [Z ~> m], depending on the setting of Z_based_coord. + real, dimension(:,:,:), allocatable :: h_extensive !< Remap grid thicknesses in [H ~> m or kg m-2] or + !! vertical extents in [Z ~> m] for remapping extensive variables integer :: interface_axes_id = 0 !< Vertical axes id for remapping at interfaces integer :: layer_axes_id = 0 !< Vertical axes id for remapping on layers integer :: answer_date !< The vintage of the order of arithmetic and expressions @@ -124,7 +102,7 @@ module MOM_diag_remap contains !> Initialize a diagnostic remapping type with the given vertical coordinate. -subroutine diag_remap_init(remap_cs, coord_tuple, answer_date) +subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME @@ -132,11 +110,19 @@ subroutine diag_remap_init(remap_cs, coord_tuple, answer_date) !! to use for remapping. Values below 20190101 recover !! the answers from 2018, while higher values use more !! robust forms of the same remapping expressions. + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure, used here to evaluate + !! whether the model is in non-Boussinesq mode. remap_cs%diag_module_suffix = trim(extractWord(coord_tuple, 1)) remap_cs%diag_coord_name = trim(extractWord(coord_tuple, 2)) remap_cs%vertical_coord_name = trim(extractWord(coord_tuple, 3)) remap_cs%vertical_coord = coordinateMode(remap_cs%vertical_coord_name) + remap_cs%Z_based_coord = .false. + ! if ( & ! (.not.(GV%Boussinesq .or. GV%semi_Boussinesq)) .and. & + ! ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + ! (remap_cs%vertical_coord == coordinateMode('SIGMA'))) ) & + ! remap_cs%Z_based_coord = .true. + remap_cs%configured = .false. remap_cs%initialized = .false. remap_cs%used = .false. @@ -274,31 +260,46 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe type(ocean_grid_type), pointer :: G !< The ocean's 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(:,:,:), intent(in) :: h !< New thickness [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: T !< New temperatures [C ~> degC] - real, dimension(:,:,:), intent(in) :: S !< New salinities [S ~> ppt] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: h !< New thickness in [H ~> m or kg m-2] or [Z ~> m], depending + !! on the value of remap_cs%Z_based_coord + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: T !< New temperatures [C ~> degC] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & + intent(in) :: S !< New salinities [S ~> ppt] type(EOS_type), intent(in) :: eqn_of_state !< A pointer to the equation of state - real, dimension(:,:,:), intent(inout) :: h_target !< The new diagnostic thicknesses [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G),remap_cs%nz), & + intent(inout) :: h_target !< The new diagnostic thicknesses in [H ~> m or kg m-2] + !! or [Z ~> m], depending on the value of remap_cs%Z_based_coord ! Local variables - real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] - integer :: i, j, k, nz - - ! Note that coordinateMode('LAYER') is never 'configured' so will - ! always return here. - if (.not. remap_cs%configured) then - return - endif - - if (remap_cs%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + real, dimension(remap_cs%nz + 1) :: zInterfaces ! Interface positions [H ~> m or kg m-2] or [Z ~> m] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: bottom_depth(SZI_(G),SZJ_(G)) ! The depth of the bathymetry in [H ~> m or kg m-2] or [Z ~> m] + real :: h_tot(SZI_(G),SZJ_(G)) ! The total thickness of the water column [H ~> m or kg m-2] or [Z ~> m] + real :: Z_unit_scale ! A conversion factor from Z-units the internal work units in this routine, + ! in units of [H Z-1 ~> 1 or kg m-3] or [nondim], depending on remap_cs%Z_based_coord. + integer :: i, j, k, is, ie, js, je, nz + + ! Note that coordinateMode('LAYER') is never 'configured' so will always return here. + if (.not. remap_cs%configured) return + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec + + ! Set the bottom depth and negligible thicknesses used in the coordinate remapping in the right units. + if (remap_cs%Z_based_coord) then + h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) + Z_unit_scale = 1.0 + do j=js-1,je+1 ; do i=is-1,ie+1 + bottom_depth(i,j) = G%bathyT(i,j) + G%Z_ref + enddo ; enddo else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) + Z_unit_scale = GV%Z_to_H + do j=js-1,je+1 ; do i=is-1,ie+1 + bottom_depth(i,j) = GV%Z_to_H * (G%bathyT(i,j) + G%Z_ref) + enddo ; enddo endif - nz = remap_cs%nz if (.not. remap_cs%initialized) then ! Initialize remapping and regridding on the first call @@ -307,145 +308,203 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe remap_cs%initialized = .true. endif + ! Calculate the total thickness of the water column, if it is needed, + if ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + (remap_cs%vertical_coord == coordinateMode('SIGMA'))) then + if (remap_CS%answer_date >= 20240201) then + ! Avoid using sum to have a specific order for the vertical sums. + ! For some compilers, the explicit expression gives the same answers as the sum function. + h_tot(:,:) = 0.0 + do k=1,GV%ke ; do j=js-1,je+1 ; do i=is-1,ie+1 + h_tot(i,j) = h_tot(i,j) + h(i,j,k) + enddo ; enddo ; enddo + else + do j=js-1,je+1 ; do i=is-1,ie+1 + h_tot(i,j) = sum(h(i,j,:)) + enddo ; enddo + endif + endif + ! Calculate remapping thicknesses for different target grids based on ! nominal/target interface locations. This happens for every call on the ! assumption that h, T, S has changed. - do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 - if (G%mask2dT(i,j)==0.) then - h_target(i,j,:) = 0. - cycle - endif + h_target(:,:,:) = 0.0 - if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then + nz = remap_cs%nz + if (remap_cs%vertical_coord == coordinateMode('ZSTAR')) then + do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with the last 4 arguments all in units of [Z ~> m] or [H ~> kg m-2]. call build_zstar_column(get_zlike_CS(remap_cs%regrid_cs), & - GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), & - zInterfaces, zScale=GV%Z_to_H) - elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + bottom_depth(i,j), h_tot(i,j), zInterfaces, zScale=Z_unit_scale) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('SIGMA')) then + do j=js-1, je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with the last 3 arguments all in units of [Z ~> m] or [H ~> kg m-2]. call build_sigma_column(get_sigma_CS(remap_cs%regrid_cs), & - GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + bottom_depth(i,j), h_tot(i,j), zInterfaces) + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('RHO')) then + do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then + ! This function call can work with 5 arguments in units of [Z ~> m] or [H ~> kg m-2]. call build_rho_column(get_rho_CS(remap_cs%regrid_cs), GV%ke, & - GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), h(i,j,:), T(i,j,:), S(i,j,:), & + bottom_depth(i,j), h(i,j,:), T(i,j,:), S(i,j,:), & eqn_of_state, zInterfaces, h_neglect=h_neglect, h_neglect_edge=h_neglect_edge) - elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then -! call build_hycom1_column(remap_cs%regrid_cs, nz, & -! GV%Z_to_H*(G%bathyT(i,j)+G%Z_ref), sum(h(i,j,:)), zInterfaces) - call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") - endif - do k = 1,nz - h_target(i,j,k) = zInterfaces(k) - zInterfaces(k+1) - enddo - enddo ; enddo + do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo + endif ; enddo ; enddo + elseif (remap_cs%vertical_coord == coordinateMode('HYCOM1')) then + call MOM_error(FATAL,"diag_remap_update: HYCOM1 coordinate not coded for diagnostics yet!") +! do j=js-1,je+1 ; do i=is-1,ie+1 ; if (G%mask2dT(i,j) > 0.0) then +! call build_hycom1_column(remap_cs%regrid_cs, nz, & +! bottom_depth(i,j), h_tot(i,j), zInterfaces) +! do k=1,nz ; h_target(i,j,k) = zInterfaces(K) - zInterfaces(K+1) ; enddo +! endif ; enddo ; enddo + endif end subroutine diag_remap_update !> Remap diagnostic field to alternative vertical grid. -subroutine diag_remap_do_remap(remap_cs, G, GV, h, staggered_in_x, staggered_in_y, & +subroutine diag_remap_do_remap(remap_cs, G, GV, US, h, staggered_in_x, staggered_in_y, & mask, field, remapped_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] - logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points - logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] - real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped [A] - real, dimension(:,:,:), intent(inout) :: remapped_field !< Field remapped to new coordinate [A] + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_CS%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. + real, dimension(:,:,:), intent(in) :: field(:,:,:) !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(out) :: remapped_field !< Field remapped to new coordinate [A] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] - real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] - real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] - integer :: nz_src, nz_dest - integer :: i, j !< Grid index - integer :: i1, j1 !< 1-based index - integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices - integer :: shift !< Symmetric offset for 1-based indexing + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field call assert(remap_cs%initialized, 'diag_remap_do_remap: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3), & 'diag_remap_do_remap: Remap field and thickness z-axes do not match.') - if (remap_cs%answer_date >= 20190101) then - h_neglect = GV%H_subroundoff ; h_neglect_edge = GV%H_subroundoff - elseif (GV%Boussinesq) then - h_neglect = GV%m_to_H*1.0e-30 ; h_neglect_edge = GV%m_to_H*1.0e-10 + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field, mask(:,:,1)) else - h_neglect = GV%kg_m2_to_H*1.0e-30 ; h_neglect_edge = GV%kg_m2_to_H*1.0e-10 + call do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field) + endif + +end subroutine diag_remap_do_remap + +!> The internal routine to remap a diagnostic field to an alternative vertical grid. +subroutine do_remap(remap_cs, G, GV, US, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, remapped_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_CS%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: remapped_field !< Field remapped to new coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j ! Grid index + + if (remap_cs%Z_based_coord) then + h_neglect = set_dz_neglect(GV, US, remap_cs%answer_date, h_neglect_edge) + else + h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) endif nz_src = size(field,3) nz_dest = remap_cs%nz remapped_field(:,:,:) = 0. - ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0 ; if (G%symmetric) shift = 1 - if (staggered_in_x .and. .not. staggered_in_y) then ! U-points - do j=G%jsc, G%jec - do I=G%iscB, G%iecB - I1 = I - G%isdB + 1 - i_lo = I1 - shift; i_hi = i_lo + 1 - if (associated(mask)) then - if (mask(I,j,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) - call remapping_core_h(remap_cs%remap_cs, & - nz_src, h_src(:), field(I1,j,:), & - nz_dest, h_dest(:), remapped_field(I1,j,:), & - h_neglect, h_neglect_edge) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & + nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(I,j,:), & + nz_dest, h_dest(:), remapped_field(I,j,:), h_neglect, h_neglect_edge) + enddo ; enddo + endif elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points - do J=G%jscB, G%jecB - J1 = J - G%jsdB + 1 - j_lo = J1 - shift; j_hi = j_lo + 1 - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,J,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) - call remapping_core_h(remap_cs%remap_cs, & - nz_src, h_src(:), field(i,J1,:), & - nz_dest, h_dest(:), remapped_field(i,J1,:), & - h_neglect, h_neglect_edge) - enddo - enddo + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & + nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + endif ; enddo ; enddo + else + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call remapping_core_h(remap_cs%remap_cs, nz_src, h_src(:), field(i,J,:), & + nz_dest, h_dest(:), remapped_field(i,J,:), h_neglect, h_neglect_edge) + enddo ; enddo + endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then ! H-points - do j=G%jsc, G%jec - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle - endif - h_src(:) = h(i,j,:) - h_dest(:) = remap_cs%h(i,j,:) - call remapping_core_h(remap_cs%remap_cs, & - nz_src, h_src(:), field(i,j,:), & - nz_dest, h_dest(:), remapped_field(i,j,:), & + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.) then + call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & h_neglect, h_neglect_edge) - enddo - enddo + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call remapping_core_h(remap_cs%remap_cs, nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), remapped_field(i,j,:), & + h_neglect, h_neglect_edge) + enddo ; enddo + endif else call assert(.false., 'diag_remap_do_remap: Unsupported axis combination') endif -end subroutine diag_remap_do_remap +end subroutine do_remap !> Calculate masks for target grid subroutine diag_remap_calc_hmask(remap_cs, G, mask) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(out) :: mask !< h-point mask for target grid [nondim] + real, dimension(G%isd:,G%jsd:,:), & + intent(out) :: mask !< h-point mask for target grid [nondim] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] integer :: i, j, k logical :: mask_vanished_layers - real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] - real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] + real :: h_tot ! Sum of all thicknesses [H ~> m or kg m-2] or [Z ~> m] + real :: h_err ! An estimate of a negligible thickness [H ~> m or kg m-2] or [Z ~> m] call assert(remap_cs%initialized, 'diag_remap_calc_hmask: remap_cs not initialized.') @@ -453,7 +512,7 @@ subroutine diag_remap_calc_hmask(remap_cs, G, mask) mask_vanished_layers = (remap_cs%vertical_coord == coordinateMode('ZSTAR')) mask(:,:,:) = 0. - do j=G%jsc-1, G%jec+1 ; do i=G%isc-1, G%iec+1 + do j=G%jsc-1,G%jec+1 ; do i=G%isc-1,G%iec+1 if (G%mask2dT(i,j)>0.) then if (mask_vanished_layers) then h_dest(:) = remap_cs%h(i,j,:) @@ -482,166 +541,239 @@ end subroutine diag_remap_calc_hmask !> Vertically re-grid an already vertically-integrated diagnostic field to alternative vertical grid. subroutine vertically_reintegrate_diag_field(remap_cs, G, h, h_target, staggered_in_x, staggered_in_y, & mask, field, reintegrated_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] - real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] - logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points - logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] - real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] - real, dimension(:,:,:), intent(inout) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + real, dimension(:,:,:), intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] + real, dimension(:,:,:), intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this + !! is a pointer it retains its declared indexing conventions. + real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:,:,:), intent(out) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] - real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] - integer :: nz_src, nz_dest - integer :: i, j !< Grid index - integer :: i1, j1 !< 1-based index - integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices - integer :: shift !< Symmetric offset for 1-based indexing + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field call assert(remap_cs%initialized, 'vertically_reintegrate_diag_field: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3), & 'vertically_reintegrate_diag_field: Remap field and thickness z-axes do not match.') + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field, mask(:,:,1)) + else + call vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field) + endif + +end subroutine vertically_reintegrate_diag_field + +!> The internal routine to vertically re-grid an already vertically-integrated diagnostic field to +!! an alternative vertical grid. +subroutine vertically_reintegrate_field(remap_cs, G, isdf, jsdf, h, h_target, staggered_in_x, staggered_in_y, & + field, reintegrated_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The thicknesses of the source grid [H ~> m or kg m-2] or [Z ~> m] + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h_target !< The thicknesses of the target grid [H ~> m or kg m-2] or [Z ~> m] + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: reintegrated_field !< Field argument remapped to alternative coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j ! Grid index + nz_src = size(field,3) nz_dest = remap_cs%nz reintegrated_field(:,:,:) = 0. - ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0 ; if (G%symmetric) shift = 1 - if (staggered_in_x .and. .not. staggered_in_y) then ! U-points - do j=G%jsc, G%jec - do I=G%iscB, G%iecB - I1 = I - G%isdB + 1 - i_lo = I1 - shift; i_hi = i_lo + 1 - if (associated(mask)) then - if (mask(I,j,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (h_target(i_lo,j,:) + h_target(i_hi,j,:)) - call reintegrate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, reintegrated_field(I1,j,:)) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + call reintegrate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, reintegrated_field(I,j,:)) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i+1,j,:)) + call reintegrate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, reintegrated_field(I,j,:)) + enddo ; enddo + endif elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points - do J=G%jscB, G%jecB - J1 = J - G%jsdB + 1 - j_lo = J1 - shift; j_hi = j_lo + 1 - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,J,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (h_target(i,j_lo,:) + h_target(i,j_hi,:)) - call reintegrate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, reintegrated_field(i,J1,:)) - enddo - enddo + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + call reintegrate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, reintegrated_field(i,J,:)) + endif ; enddo ; enddo + else + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (h_target(i,j,:) + h_target(i,j+1,:)) + call reintegrate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, reintegrated_field(i,J,:)) + enddo ; enddo + endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then ! H-points - do j=G%jsc, G%jec - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle - endif - h_src(:) = h(i,j,:) - h_dest(:) = h_target(i,j,:) - call reintegrate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, reintegrated_field(i,j,:)) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,J) > 0.0) then + call reintegrate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, h_target(i,j,:), reintegrated_field(i,j,:)) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call reintegrate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, h_target(i,j,:), reintegrated_field(i,j,:)) + enddo ; enddo + endif else call assert(.false., 'vertically_reintegrate_diag_field: Q point remapping is not coded yet.') endif -end subroutine vertically_reintegrate_diag_field +end subroutine vertically_reintegrate_field !> Vertically interpolate diagnostic field to alternative vertical grid. subroutine vertically_interpolate_diag_field(remap_cs, G, h, staggered_in_x, staggered_in_y, & mask, field, interpolated_field) - type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coodinate control structure + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] + real, dimension(:,:,:), intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_cs%Z_based_coord logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points - real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim] + real, dimension(:,:,:), pointer :: mask !< A mask for the field [nondim]. Note that because this + !! is a pointer it retains its declared indexing conventions. real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] real, dimension(:,:,:), intent(inout) :: interpolated_field !< Field argument remapped to alternative coordinate [A] + ! Local variables - real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] - real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] - integer :: nz_src, nz_dest - integer :: i, j !< Grid index - integer :: i1, j1 !< 1-based index - integer :: i_lo, i_hi, j_lo, j_hi !< (uv->h) interpolation indices - integer :: shift !< Symmetric offset for 1-based indexing + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field call assert(remap_cs%initialized, 'vertically_interpolate_diag_field: remap_cs not initialized.') call assert(size(field, 3) == size(h, 3)+1, & 'vertically_interpolate_diag_field: Remap field and thickness z-axes do not match.') + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + if (associated(mask)) then + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field, mask(:,:,1)) + else + call vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field) + endif + +end subroutine vertically_interpolate_diag_field + +!> Internal routine to vertically interpolate a diagnostic field to an alternative vertical grid. +subroutine vertically_interpolate_field(remap_cs, G, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + field, interpolated_field, mask) + type(diag_remap_ctrl), intent(in) :: remap_cs !< Diagnostic coordinate control structure + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] or [Z ~> m], + !! depending on the value of remap_cs%Z_based_coord + logical, intent(in) :: staggered_in_x !< True is the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True is the y-axis location is at v or q points + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(isdf:,jsdf:,:), & + intent(out) :: interpolated_field !< Field argument remapped to alternative coordinate [A] + real, dimension(isdf:,jsdf:), & + optional, intent(in) :: mask !< A mask for the field [nondim] + + ! Local variables + real, dimension(remap_cs%nz) :: h_dest ! Destination thicknesses [H ~> m or kg m-2] or [Z ~> m] + real, dimension(size(h,3)) :: h_src ! A column of source thicknesses [H ~> m or kg m-2] or [Z ~> m] + integer :: nz_src, nz_dest ! The number of layers on the native and remapped grids + integer :: i, j !< Grid index + interpolated_field(:,:,:) = 0. nz_src = size(h,3) nz_dest = remap_cs%nz - ! Symmetric grid offset under 1-based indexing; see header for details. - shift = 0 ; if (G%symmetric) shift = 1 - if (staggered_in_x .and. .not. staggered_in_y) then ! U-points - do j=G%jsc, G%jec - do I=G%iscB, G%iecB - I1 = I - G%isdB + 1 - i_lo = I1 - shift; i_hi = i_lo + 1 - if (associated(mask)) then - if (mask(I,j,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i_lo,j,:) + h(i_hi,j,:)) - h_dest(:) = 0.5 * (remap_cs%h(i_lo,j,:) + remap_cs%h(i_hi,j,:)) - call interpolate_column(nz_src, h_src, field(I1,j,:), & - nz_dest, h_dest, interpolated_field(I1,j,:), .true.) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call interpolate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, interpolated_field(I,j,:), .true.) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do I=G%IscB,G%IecB + h_src(:) = 0.5 * (h(i,j,:) + h(i+1,j,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i+1,j,:)) + call interpolate_column(nz_src, h_src, field(I,j,:), & + nz_dest, h_dest, interpolated_field(I,j,:), .true.) + enddo ; enddo + endif elseif (staggered_in_y .and. .not. staggered_in_x) then ! V-points - do J=G%jscB, G%jecB - J1 = J - G%jsdB + 1 - j_lo = J1 - shift; j_hi = j_lo + 1 - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,J,1) == 0.) cycle - endif - h_src(:) = 0.5 * (h(i,j_lo,:) + h(i,j_hi,:)) - h_dest(:) = 0.5 * (remap_cs%h(i,j_lo,:) + remap_cs%h(i,j_hi,:)) - call interpolate_column(nz_src, h_src, field(i,J1,:), & - nz_dest, h_dest, interpolated_field(i,J1,:), .true.) - enddo - enddo + if (present(mask)) then + do J=G%jscB,G%jecB ; do i=G%isc,G%iec ; if (mask(I,j) > 0.0) then + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call interpolate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, interpolated_field(i,J,:), .true.) + endif ; enddo ; enddo + else + do J=G%jscB,G%jecB ; do i=G%isc,G%iec + h_src(:) = 0.5 * (h(i,j,:) + h(i,j+1,:)) + h_dest(:) = 0.5 * (remap_cs%h(i,j,:) + remap_cs%h(i,j+1,:)) + call interpolate_column(nz_src, h_src, field(i,J,:), & + nz_dest, h_dest, interpolated_field(i,J,:), .true.) + enddo ; enddo + endif elseif ((.not. staggered_in_x) .and. (.not. staggered_in_y)) then ! H-points - do j=G%jsc, G%jec - do i=G%isc, G%iec - if (associated(mask)) then - if (mask(i,j,1) == 0.) cycle - endif - h_src(:) = h(i,j,:) - h_dest(:) = remap_cs%h(i,j,:) - call interpolate_column(nz_src, h_src, field(i,j,:), & - nz_dest, h_dest, interpolated_field(i,j,:), .true.) - enddo - enddo + if (present(mask)) then + do j=G%jsc,G%jec ; do i=G%isc,G%iec ; if (mask(i,j) > 0.0) then + call interpolate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), interpolated_field(i,j,:), .true.) + endif ; enddo ; enddo + else + do j=G%jsc,G%jec ; do i=G%isc,G%iec + call interpolate_column(nz_src, h(i,j,:), field(i,j,:), & + nz_dest, remap_cs%h(i,j,:), interpolated_field(i,j,:), .true.) + enddo ; enddo + endif else call assert(.false., 'vertically_interpolate_diag_field: Q point remapping is not coded yet.') endif -end subroutine vertically_interpolate_diag_field +end subroutine vertically_interpolate_field -!> Horizontally average field +!> Horizontally average a diagnostic field subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_in_y, & is_layer, is_extensive, & field, averaged_field, & @@ -654,8 +786,37 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i logical, intent(in) :: is_layer !< True if the z-axis location is at h points logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) real, dimension(:,:,:), intent(in) :: field !< The diagnostic field to be remapped [A] - real, dimension(:), intent(inout) :: averaged_field !< Field argument horizontally averaged [A] - logical, dimension(:), intent(inout) :: averaged_mask !< Mask for horizontally averaged field [nondim] + real, dimension(:), intent(out) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] + + ! Local variables + integer :: isdf, jsdf !< The starting i- and j-indices in memory for field + + isdf = G%isd ; if (staggered_in_x) Isdf = G%IsdB + jsdf = G%jsd ; if (staggered_in_y) Jsdf = G%JsdB + + call horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, field, averaged_field, averaged_mask) + +end subroutine horizontally_average_diag_field + +!> Horizontally average a diagnostic field +subroutine horizontally_average_field(G, GV, isdf, jsdf, h, staggered_in_x, staggered_in_y, & + is_layer, is_extensive, field, averaged_field, averaged_mask) + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean vertical grid structure + integer, intent(in) :: isdf !< The starting i-index in memory for field + integer, intent(in) :: jsdf !< The starting j-index in memory for field + real, dimension(G%isd:,G%jsd:,:), & + intent(in) :: h !< The current thicknesses [H ~> m or kg m-2] + logical, intent(in) :: staggered_in_x !< True if the x-axis location is at u or q points + logical, intent(in) :: staggered_in_y !< True if the y-axis location is at v or q points + logical, intent(in) :: is_layer !< True if the z-axis location is at h points + logical, intent(in) :: is_extensive !< True if the z-direction is spatially integrated (over layers) + real, dimension(isdf:,jsdf:,:), & + intent(in) :: field !< The diagnostic field to be remapped [A] + real, dimension(:), intent(out) :: averaged_field !< Field argument horizontally averaged [A] + logical, dimension(:), intent(out) :: averaged_mask !< Mask for horizontally averaged field [nondim] ! Local variables real :: volume(G%isc:G%iec, G%jsc:G%jec, size(field,3)) ! The area [m2], volume [m3] or mass [kg] of each cell. @@ -670,7 +831,6 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i type(EFP_type), dimension(2*size(field,3)) :: sums_EFP ! Sums of volume or stuff by layer real :: height ! An average thickness attributed to an velocity point [H ~> m or kg m-2] integer :: i, j, k, nz - integer :: i1, j1 !< 1-based index nz = size(field, 3) @@ -686,26 +846,23 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i stuff_sum(k) = 0. if (is_extensive) then do j=G%jsc, G%jec ; do I=G%isc, G%iec - I1 = I - G%isdB + 1 volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) - stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) enddo ; enddo else ! Intensive do j=G%jsc, G%jec ; do I=G%isc, G%iec - I1 = i - G%isdB + 1 height = 0.5 * (h(i,j,k) + h(i+1,j,k)) volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) & * (GV%H_to_MKS * height) * G%mask2dCu(I,j) - stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) enddo ; enddo endif enddo else ! Interface do k=1,nz do j=G%jsc, G%jec ; do I=G%isc, G%iec - I1 = I - G%isdB + 1 volume(I,j,k) = (G%US%L_to_m**2 * G%areaCu(I,j)) * G%mask2dCu(I,j) - stuff(I,j,k) = volume(I,j,k) * field(I1,j,k) + stuff(I,j,k) = volume(I,j,k) * field(I,j,k) enddo ; enddo enddo endif @@ -715,26 +872,23 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i do k=1,nz if (is_extensive) then do J=G%jsc, G%jec ; do i=G%isc, G%iec - J1 = J - G%jsdB + 1 volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) - stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) enddo ; enddo else ! Intensive do J=G%jsc, G%jec ; do i=G%isc, G%iec - J1 = J - G%jsdB + 1 height = 0.5 * (h(i,j,k) + h(i,j+1,k)) volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) & * (GV%H_to_MKS * height) * G%mask2dCv(i,J) - stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) enddo ; enddo endif enddo else ! Interface do k=1,nz do J=G%jsc, G%jec ; do i=G%isc, G%iec - J1 = J - G%jsdB + 1 volume(i,J,k) = (G%US%L_to_m**2 * G%areaCv(i,J)) * G%mask2dCv(i,J) - stuff(i,J,k) = volume(i,J,k) * field(i,J1,k) + stuff(i,J,k) = volume(i,J,k) * field(i,J,k) enddo ; enddo enddo endif @@ -794,6 +948,6 @@ subroutine horizontally_average_diag_field(G, GV, h, staggered_in_x, staggered_i endif enddo -end subroutine horizontally_average_diag_field +end subroutine horizontally_average_field end module MOM_diag_remap From d311b1da1b4d7ff562bac80272604366de270ab5 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 5 Feb 2024 09:56:35 -0500 Subject: [PATCH 558/629] +(*)Use z-space remapping for some diagnostics Do remapping in Z-space for some remapped diagnostics, depending on which coordinate is used. The subroutine thickness_to_dz is used with the thermo_vars_type to do the rescaling properly in non-Boussinesq mode. A new thermo_var_ptrs argument was added to diag_mediator_init, replacing three other arguments that had the same information, and its call from MOM.F90 was modified accordingly. The various calls to the diag_remap routines from post_data_3d and diag_update_remap_grids were modified depending on whether a z-unit or h-unit vertical grid is being remapped to. All answers and diagnostics are identical in Boussinesq mode, but some remapped diagnostics are changed (by not using expressions that depend on the Boussinesq reference density) in the non-Boussinesq mode. There are altered or augmented public arguments to two publicly visible routines. --- src/core/MOM.F90 | 5 +- src/framework/MOM_diag_mediator.F90 | 158 +++++++++++++++++++++------- src/framework/MOM_diag_remap.F90 | 13 +-- 3 files changed, 131 insertions(+), 45 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 2bf2b11b1a..094e534312 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3152,14 +3152,15 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & ! Set up pointers within diag mediator control structure, ! this needs to occur _after_ CS%h etc. have been allocated. - call diag_set_state_ptrs(CS%h, CS%T, CS%S, CS%tv%eqn_of_state, diag) + call diag_set_state_ptrs(CS%h, CS%tv, diag) ! This call sets up the diagnostic axes. These are needed, ! e.g. to generate the target grids below. call set_axes_info(G, GV, US, param_file, diag) ! Whenever thickness/T/S changes let the diag manager know, target grids - ! for vertical remapping may need to be regenerated. + ! for vertical remapping may need to be regenerated. In non-Boussinesq mode, + ! calc_derived_thermo needs to be called before diag_update_remap_grids. call diag_update_remap_grids(diag) ! Setup the diagnostic grid storage types diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 61bfa93046..6c90e26b98 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -21,15 +21,18 @@ module MOM_diag_mediator use MOM_diag_remap, only : diag_remap_configure_axes, diag_remap_axes_configured use MOM_diag_remap, only : diag_remap_diag_registration_closed, diag_remap_set_active use MOM_EOS, only : EOS_type -use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert +use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe, assert, callTree_showQuery +use MOM_error_handler, only : callTree_enter, callTree_leave, callTree_waypoint use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type +use MOM_interface_heights, only : thickness_to_dz use MOM_io, only : slasher, vardesc, query_vardesc, MOM_read_data use MOM_io, only : get_filename_appendix use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_string_functions, only : lowercase use MOM_time_manager, only : time_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : thermo_var_ptrs use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -134,7 +137,7 @@ module MOM_diag_mediator !> Contains an array to store a diagnostic target grid type, private :: diag_grids_type - real, dimension(:,:,:), allocatable :: h !< Target grid for remapped coordinate + real, dimension(:,:,:), allocatable :: h !< Target grid for remapped coordinate [H ~> m or kg m-2] or [Z ~> m] end type diag_grids_type !> Stores all the remapping grids and the model's native space thicknesses @@ -238,6 +241,7 @@ module MOM_diag_mediator integer :: chksum_iounit = -1 !< The unit number of a diagnostic documentation file. !! This file is open if available_diag_doc_unit is > 0. logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics + logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space. ! The following fields are used for the output of the data. integer :: is !< The start i-index of cell centers within the computational domain @@ -311,7 +315,9 @@ module MOM_diag_mediator real, dimension(:,:,:), pointer :: h => null() !< The thicknesses needed for remapping [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: T => null() !< The temperatures needed for remapping [C ~> degC] real, dimension(:,:,:), pointer :: S => null() !< The salinities needed for remapping [S ~> ppt] - type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type + type(EOS_type), pointer :: eqn_of_state => null() !< The equation of state type + type(thermo_var_ptrs), pointer :: tv => null() !< A sturcture with thermodynamic variables that are + !! are used to convert thicknesses to vertical extents type(ocean_grid_type), pointer :: G => null() !< The ocean grid type type(verticalGrid_type), pointer :: GV => null() !< The model's vertical ocean grid type(unit_scale_type), pointer :: US => null() !< A dimensional unit scaling type @@ -329,7 +335,7 @@ module MOM_diag_mediator integer :: num_chksum_diags real, dimension(:,:,:), allocatable :: h_begin !< Layer thicknesses at the beginning of the timestep used - !! for remapping of extensive variables + !! for remapping of extensive variables [H ~> m or kg m-2] end type diag_ctrl @@ -1525,13 +1531,15 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) ! Local variables type(diag_type), pointer :: diag => null() real, dimension(:,:,:), allocatable :: remapped_field - logical :: staggered_in_x, staggered_in_y + logical :: staggered_in_x, staggered_in_y, dz_diag_needed, dz_begin_needed real, dimension(:,:,:), pointer :: h_diag => NULL() + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & + dz_diag, & ! Layer vertical extents for remapping [Z ~> m] + dz_begin ! Layer vertical extents for remapping extensive quantities [Z ~> m] if (id_clock_diag_mediator>0) call cpu_clock_begin(id_clock_diag_mediator) - ! For intensive variables only, we can choose to use a different diagnostic grid - ! to map to + ! For intensive variables only, we can choose to use a different diagnostic grid to map to if (present(alt_h)) then h_diag => alt_h else @@ -1542,6 +1550,32 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) ! grids, and post each. call assert(diag_field_id < diag_cs%next_free_diag_id, & 'post_data_3d: Unregistered diagnostic id') + + if (diag_cs%show_call_tree) & + call callTree_enter("post_data_3d("//trim(diag_cs%diags(diag_field_id)%debug_str)//")") + + ! Find out whether there are any z-based diagnostics + diag => diag_cs%diags(diag_field_id) + dz_diag_needed = .false. ; dz_begin_needed = .false. + do while (associated(diag)) + if (diag%v_extensive .and. .not.diag%axes%is_native) then + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) & + dz_begin_needed = .true. + elseif (diag%axes%needs_remapping .or. diag%axes%needs_interpolating) then + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) & + dz_diag_needed = .true. + endif + diag => diag%next + enddo + + ! Determine the diagnostic grid spacing in height units, if it is needed. + if (dz_diag_needed) then + call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + if (dz_begin_needed) then + call thickness_to_dz(diag_cs%h_begin, diag_cs%tv, dz_begin, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + diag => diag_cs%diags(diag_field_id) do while (associated(diag)) call assert(associated(diag%axes), 'post_data_3d: axes is not associated') @@ -1557,11 +1591,17 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) - call vertically_reintegrate_diag_field( & - diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & - diag_cs%h_begin, & - diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & - staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + dz_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + else + call vertically_reintegrate_diag_field( & + diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), diag_cs%G, & + diag_cs%h_begin, diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%h_extensive, & + staggered_in_x, staggered_in_y, diag%axes%mask3d, field, remapped_field) + endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1582,9 +1622,15 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz)) - call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & - diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, field, remapped_field) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + else + call diag_remap_do_remap(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1605,10 +1651,15 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) if (id_clock_diag_remap>0) call cpu_clock_begin(id_clock_diag_remap) allocate(remapped_field(size(field,1), size(field,2), diag%axes%nz+1)) - call vertically_interpolate_diag_field(diag_cs%diag_remap_cs( & - diag%axes%vertical_coordinate_number), & - diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & - diag%axes%mask3d, field, remapped_field) + if (diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number)%Z_based_coord) then + call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, dz_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + else + call vertically_interpolate_diag_field(diag_cs%diag_remap_cs(diag%axes%vertical_coordinate_number), & + diag_cs%G, h_diag, staggered_in_x, staggered_in_y, & + diag%axes%mask3d, field, remapped_field) + endif if (id_clock_diag_remap>0) call cpu_clock_end(id_clock_diag_remap) if (associated(diag%axes%mask3d)) then ! Since 3d masks do not vary in the vertical, just use as much as is @@ -1628,6 +1679,9 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) enddo if (id_clock_diag_mediator>0) call cpu_clock_end(id_clock_diag_mediator) + if (diag_cs%show_call_tree) & + call callTree_leave("post_data_3d("//trim(diag_cs%diags(diag_field_id)%debug_str)//")") + end subroutine post_data_3d !> Make a real 3-d array diagnostic available for averaging or output @@ -1926,8 +1980,7 @@ subroutine post_xy_average(diag_cs, diag, field) call horizontally_average_diag_field(diag_cs%G, diag_cs%GV, diag_cs%h, & staggered_in_x, staggered_in_y, & diag%axes%is_layer, diag%v_extensive, & - field, & - averaged_field, averaged_mask) + field, averaged_field, averaged_mask) else nz = size(field, 3) coord = diag%axes%vertical_coordinate_number @@ -3168,6 +3221,8 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) call initialize_diag_type(diag_cs%diags(i)) enddo + diag_cs%show_call_tree = callTree_showQuery() + ! Read all relevant parameters and write them to the model log. call log_version(param_file, mdl, version, "") @@ -3223,7 +3278,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) if (diag_cs%diag_as_chksum) & diag_cs%num_chksum_diags = 0 - ! Keep pointers grid, h, T, S needed diagnostic remapping + ! Keep pointers to the grid, h, T, S needed for diagnostic remapping diag_cs%G => G diag_cs%GV => GV diag_cs%US => US @@ -3231,6 +3286,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) diag_cs%T => null() diag_cs%S => null() diag_cs%eqn_of_state => null() + diag_cs%tv => null() allocate(diag_cs%h_begin(G%isd:G%ied,G%jsd:G%jed,nz)) #if defined(DEBUG) || defined(__DO_SAFETY_CHECKS__) @@ -3343,18 +3399,18 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) end subroutine diag_mediator_init !> Set pointers to the default state fields used to remap diagnostics. -subroutine diag_set_state_ptrs(h, T, S, eqn_of_state, diag_cs) +subroutine diag_set_state_ptrs(h, tv, diag_cs) real, dimension(:,:,:), target, intent(in ) :: h !< the model thickness array [H ~> m or kg m-2] - real, dimension(:,:,:), target, intent(in ) :: T !< the model temperature array [C ~> degC] - real, dimension(:,:,:), target, intent(in ) :: S !< the model salinity array [S ~> ppt] - type(EOS_type), target, intent(in ) :: eqn_of_state !< Equation of state structure + type(thermo_var_ptrs), target, intent(in ) :: tv !< A sturcture with thermodynamic variables that are + !! are used to convert thicknesses to vertical extents type(diag_ctrl), intent(inout) :: diag_cs !< diag mediator control structure ! Keep pointers to h, T, S needed for the diagnostic remapping diag_cs%h => h - diag_cs%T => T - diag_cs%S => S - diag_cs%eqn_of_state => eqn_of_state + diag_cs%T => tv%T + diag_cs%S => tv%S + diag_cs%eqn_of_state => tv%eqn_of_state + diag_cs%tv => tv end subroutine @@ -3374,11 +3430,15 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv logical, optional, intent(in ) :: update_extensive !< If true (not default), update the grids used for !! intensive diagnostics ! Local variables - integer :: i + integer :: m real, dimension(:,:,:), pointer :: h_diag => NULL() ! The layer thickneses for diagnostics [H ~> m or kg m-2] real, dimension(:,:,:), pointer :: T_diag => NULL() ! The layer temperatures for diagnostics [C ~> degC] real, dimension(:,:,:), pointer :: S_diag => NULL() ! The layer salinities for diagnostics [S ~> ppt] - logical :: update_intensive_local, update_extensive_local + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & + dz_diag ! Layer vertical extents for remapping [Z ~> m] + logical :: update_intensive_local, update_extensive_local, dz_diag_needed + + if (diag_cs%show_call_tree) call callTree_enter("diag_update_remap_grids()") ! Set values based on optional input arguments if (present(alt_h)) then @@ -3415,17 +3475,38 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv "diagnostic structure have been overridden") endif + ! Determine the diagnostic grid spacing in height units, if it is needed. + dz_diag_needed = .false. + if (update_intensive_local .or. update_extensive_local) then + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) dz_diag_needed = .true. + enddo + endif + if (dz_diag_needed) then + call thickness_to_dz(h_diag, diag_cs%tv, dz_diag, diag_cs%G, diag_cs%GV, diag_cs%US, halo_size=1) + endif + if (update_intensive_local) then - do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h) + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) then + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h) + else + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h) + endif enddo endif if (update_extensive_local) then diag_cs%h_begin(:,:,:) = diag_cs%h(:,:,:) - do i=1, diag_cs%num_diag_coords - call diag_remap_update(diag_cs%diag_remap_cs(i), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & - diag_cs%eqn_of_state, diag_cs%diag_remap_cs(i)%h_extensive) + do m=1, diag_cs%num_diag_coords + if (diag_cs%diag_remap_cs(m)%Z_based_coord) then + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, dz_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h_extensive) + else + call diag_remap_update(diag_cs%diag_remap_cs(m), diag_cs%G, diag_cs%GV, diag_cs%US, h_diag, T_diag, S_diag, & + diag_cs%eqn_of_state, diag_cs%diag_remap_cs(m)%h_extensive) + endif enddo endif @@ -3437,6 +3518,8 @@ subroutine diag_update_remap_grids(diag_cs, alt_h, alt_T, alt_S, update_intensiv if (id_clock_diag_grid_updates>0) call cpu_clock_end(id_clock_diag_grid_updates) + if (diag_cs%show_call_tree) call callTree_leave("diag_update_remap_grids()") + end subroutine diag_update_remap_grids !> Sets up the 2d and 3d masks for native diagnostics @@ -4182,6 +4265,7 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d allocate(field_out(1:f1,1:f2,ks:ke)) ! Fill the down sampled field on the down sampled diagnostics (almost always compuate) domain + !### The averaging used here is not rotationally invariant. if (method == MMM) then do k=ks,ke ; do j=jsv_d,jev_d ; do i=isv_d,iev_d i0 = isv_o+dl*(i-isv_d) diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index cd9e22aae2..ace50242a5 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -103,7 +103,7 @@ module MOM_diag_remap !> Initialize a diagnostic remapping type with the given vertical coordinate. subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) - type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure + type(diag_remap_ctrl), intent(inout) :: remap_cs !< Diag remapping control structure character(len=*), intent(in) :: coord_tuple !< A string in form of !! MODULE_SUFFIX PARAMETER_SUFFIX COORDINATE_NAME integer, intent(in) :: answer_date !< The vintage of the order of arithmetic and expressions @@ -118,10 +118,11 @@ subroutine diag_remap_init(remap_cs, coord_tuple, answer_date, GV) remap_cs%vertical_coord_name = trim(extractWord(coord_tuple, 3)) remap_cs%vertical_coord = coordinateMode(remap_cs%vertical_coord_name) remap_cs%Z_based_coord = .false. - ! if ( & ! (.not.(GV%Boussinesq .or. GV%semi_Boussinesq)) .and. & - ! ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & - ! (remap_cs%vertical_coord == coordinateMode('SIGMA'))) ) & - ! remap_cs%Z_based_coord = .true. + if (.not.(GV%Boussinesq .or. GV%semi_Boussinesq) .and. & + ((remap_cs%vertical_coord == coordinateMode('ZSTAR')) .or. & + (remap_cs%vertical_coord == coordinateMode('SIGMA')) .or. & + (remap_cs%vertical_coord == coordinateMode('RHO'))) ) & + remap_cs%Z_based_coord = .true. remap_cs%configured = .false. remap_cs%initialized = .false. @@ -295,7 +296,7 @@ subroutine diag_remap_update(remap_cs, G, GV, US, h, T, S, eqn_of_state, h_targe enddo ; enddo else h_neglect = set_h_neglect(GV, remap_cs%answer_date, h_neglect_edge) - Z_unit_scale = GV%Z_to_H + Z_unit_scale = GV%Z_to_H ! This branch is not used in fully non-Boussinesq mode. do j=js-1,je+1 ; do i=is-1,ie+1 bottom_depth(i,j) = GV%Z_to_H * (G%bathyT(i,j) + G%Z_ref) enddo ; enddo From 611f575fbee7a27686f44832ea8d1197e8765386 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 6 Feb 2024 05:36:36 -0500 Subject: [PATCH 559/629] +(*)Fix downsample_mask indexing bugs Corrected indexing problems in downsample_mask that would cause masked reduced-resolution diagnostics to work improperly when the model is in symmetric memory mode or when global indexing is used. This involves passing the starting index in memory of the native-grid field being downsampled in all calls to downsample_mask. In global-indexing mode, this change avoids a series of segmentation faults that stopped the model runs when compiled for debugging. All solutions are bitwise identical in all cases but some down-scaled diagnostics will change in some memory modes, hopefully becoming consistent across all memory modes (although this has yet to be tested in all modes). --- src/framework/MOM_diag_mediator.F90 | 80 +++++++++++++++++------------ 1 file changed, 46 insertions(+), 34 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 6c90e26b98..eeb239859d 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -872,43 +872,51 @@ subroutine set_masks_for_axes_dsamp(G, diag_cs) do c=1, diag_cs%num_diag_coords ! Level/layer h-points in diagnostic coordinate axes => diag_cs%remap_axesTL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTL(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%jsc, G%isd, G%jsd, & G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesTL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer u-points in diagnostic coordinate axes => diag_cs%remap_axesCuL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCuL(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesCul(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer v-points in diagnostic coordinate axes => diag_cs%remap_axesCvL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & - G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvL(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%JscB, G%isd, G%JsdB, & + G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesCvL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Level/layer q-points in diagnostic coordinate axes => diag_cs%remap_axesBL(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBL(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesBL(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface h-points in diagnostic coordinate (w-point) axes => diag_cs%remap_axesTi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, dl,G%isc, G%jsc, & + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesTi(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%jsc, G%isd, G%jsd, & G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesTi(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface u-points in diagnostic coordinate axes => diag_cs%remap_axesCui(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCui(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB, G%HId2%IecB, G%HId2%jsc, G%HId2%jec, G%HId2%IsdB, G%HId2%IedB, G%HId2%jsd, G%HId2%jed) diag_cs%dsamp(dl)%remap_axesCui(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface v-points in diagnostic coordinate axes => diag_cs%remap_axesCvi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, dl,G%isc ,G%JscB, & - G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesCvi(c)%dsamp(dl)%mask3d, & + dl, G%isc, G%JscB, G%isd, G%JsdB, & + G%HId2%isc, G%HId2%iec, G%HId2%JscB, G%HId2%JecB, G%HId2%isd, G%HId2%ied, G%HId2%JsdB, G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesCvi(c)%mask3d => axes%mask3d !set non-downsampled mask ! Interface q-points in diagnostic coordinate axes => diag_cs%remap_axesBi(c) - call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(axes%mask3d, diag_cs%dsamp(dl)%remap_axesBi(c)%dsamp(dl)%mask3d, & + dl, G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB, G%HId2%IecB, G%HId2%JscB, G%HId2%JecB, G%HId2%IsdB, G%HId2%IedB, G%HId2%JsdB, G%HId2%JedB) diag_cs%dsamp(dl)%remap_axesBi(c)%mask3d => axes%mask3d !set non-downsampled mask enddo enddo @@ -3998,13 +4006,13 @@ subroutine downsample_diag_masks_set(G, nz, diag_cs) do dl=2,MAX_DSAMP_LEV ! 2d mask - call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl,G%isc, G%jsc, & + call downsample_mask(G%mask2dT, diag_cs%dsamp(dl)%mask2dT, dl, G%isc, G%jsc, G%isd, G%jsd, & G%HId2%isc, G%HId2%iec, G%HId2%jsc, G%HId2%jec, G%HId2%isd, G%HId2%ied, G%HId2%jsd, G%HId2%jed) - call downsample_mask(G%mask2dBu,diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) - call downsample_mask(G%mask2dCu,diag_cs%dsamp(dl)%mask2dCu, dl,G%IscB,G%JscB, & - G%HId2%IscB,G%HId2%IecB,G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) - call downsample_mask(G%mask2dCv,diag_cs%dsamp(dl)%mask2dCv, dl,G%isc ,G%JscB, & + call downsample_mask(G%mask2dBu, diag_cs%dsamp(dl)%mask2dBu, dl,G%IscB, G%JscB, G%IsdB, G%JsdB, & + G%HId2%IscB,G%HId2%IecB, G%HId2%JscB,G%HId2%JecB,G%HId2%IsdB,G%HId2%IedB,G%HId2%JsdB,G%HId2%JedB) + call downsample_mask(G%mask2dCu, diag_cs%dsamp(dl)%mask2dCu, dl, G%IscB, G%jsc, G%IsdB, G%jsd, & + G%HId2%IscB,G%HId2%IecB, G%HId2%jsc, G%HId2%jec,G%HId2%IsdB,G%HId2%IedB,G%HId2%jsd, G%HId2%jed) + call downsample_mask(G%mask2dCv, diag_cs%dsamp(dl)%mask2dCv, dl,G %isc ,G%JscB, G%isd, G%JsdB, & G%HId2%isc ,G%HId2%iec, G%HId2%JscB,G%HId2%JecB,G%HId2%isd ,G%HId2%ied, G%HId2%JsdB,G%HId2%JedB) ! 3d native masks are needed by diag_manager but the native variables ! can only be masked 2d - for ocean points, all layers exists. @@ -4517,10 +4525,12 @@ end subroutine downsample_field_2d !> Allocate and compute the 2d down sampled mask !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) !! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, & - isd_d, ied_d, jsd_d, jed_d) - real, dimension(:,:), intent(in) :: field_in !< Original field to be down sampled - real, dimension(:,:), pointer :: field_out !< Down sampled field +subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & + isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) + integer, intent(in) :: isd_o !< Original data domain i-start index + integer, intent(in) :: jsd_o !< Original data domain j-start index + real, dimension(isd_o:,jsd_o:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] + real, dimension(:,:), pointer :: field_out !< Down sampled field mask [nondim] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: isc_o !< Original i-start index integer, intent(in) :: jsc_o !< Original j-start index @@ -4528,13 +4538,13 @@ subroutine downsample_mask_2d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ integer, intent(in) :: iec_d !< Computational i-end index of down sampled data integer, intent(in) :: jsc_d !< Computational j-start index of down sampled data integer, intent(in) :: jec_d !< Computational j-end index of down sampled data - integer, intent(in) :: isd_d !< Computational i-start index of down sampled data - integer, intent(in) :: ied_d !< Computational i-end index of down sampled data - integer, intent(in) :: jsd_d !< Computational j-start index of down sampled data - integer, intent(in) :: jed_d !< Computational j-end index of down sampled data + integer, intent(in) :: isd_d !< Data domain i-start index of down sampled data + integer, intent(in) :: ied_d !< Data domain i-end index of down sampled data + integer, intent(in) :: jsd_d !< Data domain j-start index of down sampled data + integer, intent(in) :: jed_d !< Data domain j-end index of down sampled data ! Locals integer :: i,j,ii,jj,i0,j0 - real :: tot_non_zero + real :: tot_non_zero ! The sum of values in the down-scaled cell [A] ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 allocate(field_out(isd_d:ied_d,jsd_d:jed_d)) field_out(:,:) = 0.0 @@ -4552,10 +4562,12 @@ end subroutine downsample_mask_2d !> Allocate and compute the 3d down sampled mask !! The masks are down sampled based on a minority rule, i.e., a coarse cell is open (1) !! if at least one of the sub-cells are open, otherwise it's closed (0) -subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_d, jsc_d, jec_d, & - isd_d, ied_d, jsd_d, jed_d) - real, dimension(:,:,:), intent(in) :: field_in !< Original field to be down sampled - real, dimension(:,:,:), pointer :: field_out !< down sampled field +subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isd_o, jsd_o, & + isc_d, iec_d, jsc_d, jec_d, isd_d, ied_d, jsd_d, jed_d) + integer, intent(in) :: isd_o !< Original data domain i-start index + integer, intent(in) :: jsd_o !< Original data domain j-start index + real, dimension(isd_o:,jsd_o:,:), intent(in) :: field_in !< Original field to be down sampled in arbitrary units [A] + real, dimension(:,:,:), pointer :: field_out !< down sampled field mask [nondim] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: isc_o !< Original i-start index integer, intent(in) :: jsc_o !< Original j-start index @@ -4569,7 +4581,7 @@ subroutine downsample_mask_3d(field_in, field_out, dl, isc_o, jsc_o, isc_d, iec_ integer, intent(in) :: jed_d !< Computational j-end index of down sampled data ! Locals integer :: i,j,ii,jj,i0,j0,k,ks,ke - real :: tot_non_zero + real :: tot_non_zero ! The sum of values in the down-scaled cell [A] ! down sampled mask = 0 unless the mask value of one of the down sampling cells is 1 ks = lbound(field_in,3) ; ke = ubound(field_in,3) allocate(field_out(isd_d:ied_d,jsd_d:jed_d,ks:ke)) From 2bc04bd76c743da3f896e4395ff63dd495615f6a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 29 Feb 2024 12:51:49 -0500 Subject: [PATCH 560/629] (*)Eliminate IIm1 and JJm1 in Update_Stokes_Drift Replaced the IIm1 and JJm1 variables in Update_Stokes_Drift with 'I-1' and 'J-1' in Update_Stokes_Drift. The previous expressions could give incorrect solutions at the southern and western edges of the global domain with global indexing and serve no purpose when global indexing is not used. In addition, the i-, j- and k- index variables in Update_Surface_Waves, Update_Stokes_Drift, get_Langmuir_Number and Get_SL_Average_Prof were changed from ii to i, jj to j, and kk to k to follow the patterns used elsewhere in the MOM_wave_interface module and throughout the rest of the MOM6 code. All answers are bitwise identical in cases that do not use global indexing. --- src/user/MOM_wave_interface.F90 | 188 +++++++++++++++----------------- 1 file changed, 86 insertions(+), 102 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index fa7b567845..9a951cf655 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -673,7 +673,7 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) type(mech_forcing), intent(in), optional :: forces !< MOM_forcing_type ! Local variables type(time_type) :: Stokes_Time - integer :: ii, jj, b + integer :: i, j, b if (CS%WaveMethod == TESTPROF) then ! Do nothing @@ -701,37 +701,37 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) do b=1,CS%NumBands CS%WaveNum_Cen(b) = forces%stk_wavenumbers(b) !Interpolate from a grid to c grid - do jj=G%jsc,G%jec - do II=G%iscB,G%iecB - CS%STKx0(II,jj,b) = 0.5*(forces%UStkb(ii,jj,b)+forces%UStkb(ii+1,jj,b)) + do j=G%jsc,G%jec + do I=G%iscB,G%iecB + CS%STKx0(I,j,b) = 0.5*(forces%UStkb(i,j,b)+forces%UStkb(i+1,j,b)) enddo enddo - do JJ=G%jscB, G%jecB - do ii=G%isc,G%iec - CS%STKY0(ii,JJ,b) = 0.5*(forces%VStkb(ii,jj,b)+forces%VStkb(ii,jj+1,b)) + do J=G%jscB,G%jecB + do i=G%isc,G%iec + CS%STKY0(i,J,b) = 0.5*(forces%VStkb(i,j,b)+forces%VStkb(i,j+1,b)) enddo enddo call pass_vector(CS%STKx0(:,:,b),CS%STKy0(:,:,b), G%Domain) enddo - do jj=G%jsc,G%jec - do ii=G%isc,G%iec - !CS%Omega_w2x(ii,jj) = forces%omega_w2x(ii,jj) + do j=G%jsc,G%jec + do i=G%isc,G%iec + !CS%Omega_w2x(i,j) = forces%omega_w2x(i,j) do b=1,CS%NumBands - CS%UStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%UStkb(ii,jj,b) - CS%VStk_Hb(ii,jj,b) = US%m_s_to_L_T*forces%VStkb(ii,jj,b) + CS%UStk_Hb(i,j,b) = US%m_s_to_L_T*forces%UStkb(i,j,b) + CS%VStk_Hb(i,j,b) = US%m_s_to_L_T*forces%VStkb(i,j,b) enddo enddo enddo elseif (CS%DataSource == INPUT) then do b=1,CS%NumBands - do jj=G%jsd,G%jed - do II=G%isdB,G%iedB - CS%STKx0(II,jj,b) = CS%PrescribedSurfStkX(b) + do j=G%jsd,G%jed + do I=G%isdB,G%iedB + CS%STKx0(I,j,b) = CS%PrescribedSurfStkX(b) enddo enddo - do JJ=G%jsdB, G%jedB - do ii=G%isd,G%ied - CS%STKY0(ii,JJ,b) = CS%PrescribedSurfStkY(b) + do J=G%jsdB, G%jedB + do i=G%isd,G%ied + CS%STKY0(i,J,b) = CS%PrescribedSurfStkY(b) enddo enddo enddo @@ -763,7 +763,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) real :: UStokes ! A Stokes drift velocity [L T-1 ~> m s-1] real :: PI ! 3.1415926535... [nondim] real :: La ! The local Langmuir number [nondim] - integer :: ii, jj, kk, b, iim1, jjm1 + integer :: i, j, k, b real :: I_dt ! The inverse of the time step [T-1 ~> s-1] if (CS%WaveMethod==EFACTOR) return @@ -777,29 +777,27 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) if (CS%WaveMethod==TESTPROF) then PI = 4.0*atan(1.0) DecayScale = 4.*PI / CS%TP_WVL !4pi - do jj = G%jsc,G%jec - do II = G%iscB,G%iecB - IIm1 = max(1,II-1) + do j=G%jsc,G%jec + do I=G%iscB,G%iecB Bottom = 0.0 MidPoint = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - MidPoint = Bottom - 0.25*(dz(II,jj,kk)+dz(IIm1,jj,kk)) - Bottom = Bottom - 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) - CS%Us_x(II,jj,kk) = CS%TP_STKX0*exp(MidPoint*DecayScale) + MidPoint = Bottom - 0.25*(dz(I,j,k)+dz(I-1,j,k)) + Bottom = Bottom - 0.5*(dz(I,j,k)+dz(I-1,j,k)) + CS%Us_x(I,j,k) = CS%TP_STKX0*exp(MidPoint*DecayScale) enddo enddo enddo - do JJ = G%jscB,G%jecB - do ii = G%isc,G%iec - JJm1 = max(1,JJ-1) + do J=G%jscB,G%jecB + do i=G%isc,G%iec Bottom = 0.0 MidPoint = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - MidPoint = Bottom - 0.25*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) - Bottom = Bottom - 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) - CS%Us_y(ii,JJ,kk) = CS%TP_STKY0*exp(MidPoint*DecayScale) + MidPoint = Bottom - 0.25*(dz(i,J,k)+dz(i,J-1,k)) + Bottom = Bottom - 0.5*(dz(i,J,k)+dz(i,J-1,k)) + CS%Us_y(i,J,k) = CS%TP_STKY0*exp(MidPoint*DecayScale) enddo enddo enddo @@ -813,19 +811,18 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) CS%Us0_x(:,:) = 0.0 CS%Us0_y(:,:) = 0.0 ! Computing X direction Stokes drift - do jj = G%jsc,G%jec - do II = G%iscB,G%iecB + do j=G%jsc,G%jec + do I=G%iscB,G%iecB ! 1. First compute the surface Stokes drift ! by summing over the partitions. do b = 1,CS%NumBands - CS%US0_x(II,jj) = CS%US0_x(II,jj) + CS%STKx0(II,jj,b) + CS%US0_x(I,j) = CS%US0_x(I,j) + CS%STKx0(I,j,b) enddo ! 2. Second compute the level averaged Stokes drift bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - IIm1 = max(II-1,1) - level_thick = 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) + level_thick = 0.5*(dz(I,j,k)+dz(I-1,j,k)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -840,7 +837,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC enddo elseif (level_thick > CS%Stokes_min_thick_avg) then @@ -855,7 +852,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC enddo else ! Take the value at the midpoint do b = 1,CS%NumBands @@ -864,7 +861,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) else CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif - CS%US_x(II,jj,kk) = CS%US_x(II,jj,kk) + CS%STKx0(II,jj,b)*CMN_FAC + CS%US_x(I,j,k) = CS%US_x(I,j,k) + CS%STKx0(I,j,b)*CMN_FAC enddo endif enddo @@ -872,18 +869,17 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) enddo ! Computing Y direction Stokes drift - do JJ = G%jscB,G%jecB - do ii = G%isc,G%iec + do J=G%jscB,G%jecB + do i=G%isc,G%iec ! Set the surface value to that at z=0 do b = 1,CS%NumBands - CS%US0_y(ii,JJ) = CS%US0_y(ii,JJ) + CS%STKy0(ii,JJ,b) + CS%US0_y(i,J) = CS%US0_y(i,J) + CS%STKy0(i,J,b) enddo ! Compute the level averages. bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - JJm1 = max(JJ-1,1) - level_thick = 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) + level_thick = 0.5*(dz(i,J,k)+dz(i,J-1,k)) MidPoint = Top - 0.5*level_thick Bottom = Top - level_thick @@ -898,7 +894,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) WN = CS%Freq_Cen(b)**2 * CS%I_g_Earth CMN_FAC = exp(2.*WN*Top) * one_minus_exp_x(2.*WN*level_thick) endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC enddo elseif (level_thick > CS%Stokes_min_thick_avg) then ! -> Stokes drift in thin layers not averaged. @@ -912,7 +908,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) WN = CS%Freq_Cen(b)**2 / CS%g_Earth !bgr bug-fix missing g CMN_FAC = (exp(2.*WN*Top)-exp(2.*WN*Bottom)) / (2.*WN*(Top-Bottom)) endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC enddo else ! Take the value at the midpoint do b = 1,CS%NumBands @@ -921,7 +917,7 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) else CMN_FAC = exp(MidPoint * 2. * CS%Freq_Cen(b)**2 / CS%g_Earth) endif - CS%US_y(ii,JJ,kk) = CS%US_y(ii,JJ,kk) + CS%STKy0(ii,JJ,b)*CMN_FAC + CS%US_y(i,J,k) = CS%US_y(i,J,k) + CS%STKy0(i,J,b)*CMN_FAC enddo endif enddo @@ -931,39 +927,37 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) call pass_vector(CS%Us0_x(:,:),CS%Us0_y(:,:), G%Domain) elseif (CS%WaveMethod == DHH85) then if (.not.(CS%StaticWaves .and. CS%DHH85_is_set)) then - do jj = G%jsc,G%jec - do II = G%iscB,G%iecB + do j=G%jsc,G%jec + do I=G%iscB,G%iecB bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - IIm1 = max(II-1,1) - MidPoint = Top - 0.25*(dz(II,jj,kk)+dz(IIm1,jj,kk)) - Bottom = Top - 0.5*(dz(II,jj,kk)+dz(IIm1,jj,kk)) - !bgr note that this is using a u-point ii on h-point ustar + MidPoint = Top - 0.25*(dz(I,j,k)+dz(I-1,j,k)) + Bottom = Top - 0.5*(dz(I,j,k)+dz(I-1,j,k)) + !bgr note that this is using a u-point I on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. call DHH85_mid(GV, US, CS, MidPoint, UStokes) ! Putting into x-direction (no option for direction - CS%US_x(II,jj,kk) = UStokes + CS%US_x(I,j,k) = UStokes enddo enddo enddo - do JJ = G%jscB,G%jecB - do ii = G%isc,G%iec + do J=G%jscB,G%jecB + do i=G%isc,G%iec Bottom = 0.0 - do kk=1, GV%ke + do k = 1,GV%ke Top = Bottom - JJm1 = max(JJ-1,1) - MidPoint = Bottom - 0.25*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) - Bottom = Bottom - 0.5*(dz(ii,JJ,kk)+dz(ii,JJm1,kk)) - !bgr note that this is using a v-point jj on h-point ustar + MidPoint = Bottom - 0.25*(dz(i,J,k)+dz(i,J-1,k)) + Bottom = Bottom - 0.5*(dz(i,J,k)+dz(i,J-1,k)) + !bgr note that this is using a v-point J on h-point ustar ! this code has only been previous used for uniform ! grid cases. This needs fixed if DHH85 is used for non ! uniform cases. ! call DHH85_mid(GV, US, CS, Midpoint, UStokes) ! Putting into x-direction, so setting y direction to 0 - CS%US_y(ii,JJ,kk) = 0.0 + CS%US_y(i,J,k) = 0.0 ! For rotational symmetry there should be the option for this to become = UStokes ! bgr - see note above, but this is true ! if this is used for anything @@ -975,28 +969,18 @@ subroutine Update_Stokes_Drift(G, GV, US, CS, dz, ustar, dt, dynamics_step) endif call pass_vector(CS%Us_x(:,:,:),CS%Us_y(:,:,:), G%Domain) else! Keep this else, fallback to 0 Stokes drift - do kk= 1,GV%ke - do jj = G%jsd,G%jed - do II = G%isdB,G%iedB - CS%Us_x(II,jj,kk) = 0. - enddo - enddo - do JJ = G%jsdB,G%jedB - do ii = G%isd,G%ied - CS%Us_y(ii,JJ,kk) = 0. - enddo - enddo - enddo + CS%Us_x(:,:,:) = 0. + CS%Us_y(:,:,:) = 0. endif ! Turbulent Langmuir number is computed here and available to use anywhere. ! SL Langmuir number requires mixing layer depth, and therefore is computed ! in the routine it is needed by (e.g. KPP or ePBL). - do jj = G%jsc, G%jec - do ii = G%isc,G%iec - call get_Langmuir_Number( La, G, GV, US, dz(ii,jj,1), ustar(ii,jj), ii, jj, & - dz(ii,jj,:), CS, Override_MA=.false.) - CS%La_turb(ii,jj) = La + do j=G%jsc, G%jec + do i=G%isc,G%iec + call get_Langmuir_Number( La, G, GV, US, dz(i,j,1), ustar(i,j), i, j, & + dz(i,j,:), CS, Override_MA=.false.) + CS%La_turb(i,j) = La enddo enddo @@ -1197,7 +1181,7 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & logical :: ContinueLoop, USE_MA real, dimension(SZK_(GV)) :: US_H, VS_H ! Profiles of Stokes velocities [L T-1 ~> m s-1] real, allocatable :: StkBand_X(:), StkBand_Y(:) ! Stokes drifts by band [L T-1 ~> m s-1] - integer :: KK, BB + integer :: k, BB ! Compute averaging depth for Stokes drift (negative) Dpt_LASL = -1.0*max(Waves%LA_FracHBL*HBL, Waves%LA_HBL_min) @@ -1211,24 +1195,24 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & "Get_LA_waves requested to consider misalignment, but velocities were not provided.") ContinueLoop = .true. bottom = 0.0 - do kk = 1,GV%ke + do k = 1,GV%ke Top = Bottom - MidPoint = Bottom + 0.5*dz(kk) - Bottom = Bottom + dz(kk) + MidPoint = Bottom + 0.5*dz(k) + Bottom = Bottom + dz(k) !### Given the sign convention that Dpt_LASL is negative, the next line seems to have a bug. ! To correct this bug, this line should be changed to: - ! if (MidPoint > abs(Dpt_LASL) .and. (kk > 1) .and. ContinueLoop) then - if (MidPoint > Dpt_LASL .and. kk > 1 .and. ContinueLoop) then - ShearDirection = atan2(V_H(1)-V_H(kk),U_H(1)-U_H(kk)) + ! if (MidPoint > abs(Dpt_LASL) .and. (k > 1) .and. ContinueLoop) then + if (MidPoint > Dpt_LASL .and. k > 1 .and. ContinueLoop) then + ShearDirection = atan2(V_H(1)-V_H(k), U_H(1)-U_H(k)) ContinueLoop = .false. endif enddo endif if (Waves%WaveMethod==TESTPROF) then - do kk = 1,GV%ke - US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) - VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) + do k = 1,GV%ke + US_H(k) = 0.5*(Waves%US_X(I,j,k)+Waves%US_X(I-1,j,k)) + VS_H(k) = 0.5*(Waves%US_Y(i,J,k)+Waves%US_Y(i,J-1,k)) enddo call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) @@ -1245,9 +1229,9 @@ subroutine get_Langmuir_Number( LA, G, GV, US, HBL, ustar, i, j, dz, Waves, & deallocate(StkBand_X, StkBand_Y) elseif (Waves%WaveMethod==DHH85) then ! Temporarily integrating profile rather than spectrum for simplicity - do kk = 1,GV%ke - US_H(kk) = 0.5*(Waves%US_X(I,j,kk)+Waves%US_X(I-1,j,kk)) - VS_H(kk) = 0.5*(Waves%US_Y(i,J,kk)+Waves%US_Y(i,J-1,kk)) + do k = 1,GV%ke + US_H(k) = 0.5*(Waves%US_X(I,j,k)+Waves%US_X(I-1,j,k)) + VS_H(k) = 0.5*(Waves%US_Y(i,J,k)+Waves%US_Y(i,J-1,k)) enddo call Get_SL_Average_Prof( GV, Dpt_LASL, dz, US_H, LA_STKx) call Get_SL_Average_Prof( GV, Dpt_LASL, dz, VS_H, LA_STKy) @@ -1451,20 +1435,20 @@ subroutine Get_SL_Average_Prof( GV, AvgDepth, dz, Profile, Average ) !Local variables real :: Top, Bottom ! Depths, negative downward [Z ~> m] real :: Sum ! The depth weighted vertical sum of a quantity [A Z ~> A m] - integer :: kk + integer :: k ! Initializing sum Sum = 0.0 ! Integrate bottom = 0.0 - do kk = 1, GV%ke + do k = 1, GV%ke Top = Bottom - Bottom = Bottom - dz(kk) + Bottom = Bottom - dz(k) if (AvgDepth < Bottom) then ! The whole cell is within H_LA - Sum = Sum + Profile(kk) * dz(kk) + Sum = Sum + Profile(k) * dz(k) elseif (AvgDepth < Top) then ! A partial cell is within H_LA - Sum = Sum + Profile(kk) * (Top-AvgDepth) + Sum = Sum + Profile(k) * (Top-AvgDepth) exit else exit From 744dbcc9576a5b424509b34089e8eb0b5c27e4ef Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 14 Feb 2024 18:32:24 -0500 Subject: [PATCH 561/629] Document remapping function variable units Added or amended comments to document the mostly arbitrary units of about 360 variables in 13 low-level remapping modules. Only comments are changed and all answers are bitwise identical. --- src/ALE/MOM_hybgen_regrid.F90 | 14 +-- src/ALE/MOM_hybgen_remap.F90 | 2 +- src/ALE/MOM_remapping.F90 | 4 +- src/ALE/P1M_functions.F90 | 10 +- src/ALE/PCM_functions.F90 | 6 +- src/ALE/PLM_functions.F90 | 122 ++++++++++++------------ src/ALE/PPM_functions.F90 | 32 ++++--- src/ALE/PQM_functions.F90 | 63 +++++++------ src/ALE/coord_zlike.F90 | 8 +- src/ALE/polynomial_functions.F90 | 32 ++++--- src/ALE/regrid_edge_values.F90 | 157 ++++++++++++++++++------------- src/ALE/regrid_solvers.F90 | 70 ++++++++------ src/ALE/remapping_attic.F90 | 115 ++++++++++++---------- 13 files changed, 351 insertions(+), 284 deletions(-) diff --git a/src/ALE/MOM_hybgen_regrid.F90 b/src/ALE/MOM_hybgen_regrid.F90 index 524f9b8ff2..491693549f 100644 --- a/src/ALE/MOM_hybgen_regrid.F90 +++ b/src/ALE/MOM_hybgen_regrid.F90 @@ -41,8 +41,10 @@ module MOM_hybgen_regrid dp0k, & !< minimum deep z-layer separation [H ~> m or kg m-2] ds0k !< minimum shallow z-layer separation [H ~> m or kg m-2] - real :: coord_scale = 1.0 !< A scaling factor to restores the depth coordinates to values in m - real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to values in kg m-3 + real :: coord_scale = 1.0 !< A scaling factor to restores the depth coordinates to + !! values in m [m H-1 ~> 1 or m3 kg-1] + real :: Rho_coord_scale = 1.0 !< A scaling factor to restores the denesity coordinates to + !! values in kg m-3 [kg m-3 R-1 ~> 1] real :: dpns !< depth to start terrain following [H ~> m or kg m-2] real :: dsns !< depth to stop terrain following [H ~> m or kg m-2] @@ -68,7 +70,7 @@ module MOM_hybgen_regrid !! the bottom that certain adjustments can be made in the Hybgen regridding !! code [H ~> m or kg m-2]. In Hycom, this is set to onem (nominally 1 m). real :: h_thin !< A layer thickness below which a layer is considered to be too thin for - !! certain adjustments to be made in the Hybgen regridding code. + !! certain adjustments to be made in the Hybgen regridding code [H ~> m or kg m-2]. !! In Hycom, this is set to onemm (nominally 0.001 m). real :: rho_eps !< A small nonzero density that is used to prevent division by zero @@ -284,7 +286,7 @@ subroutine get_hybgen_regrid_params(CS, nk, ref_pressure, hybiso, nsigma, dp00i, real, optional, intent(out) :: ref_pressure !< Reference pressure for density calculations [R L2 T-2 ~> Pa] real, optional, intent(out) :: hybiso !< Hybgen uses PCM if layer is within hybiso of target density [R ~> kg m-3] integer, optional, intent(out) :: nsigma !< Number of sigma levels used by HYBGEN - real, optional, intent(out) :: dp00i !< Deep isopycnal spacing minimum thickness (m) + real, optional, intent(out) :: dp00i !< Deep isopycnal spacing minimum thickness [H ~> m or kg m-2] real, optional, intent(out) :: qhybrlx !< Fractional relaxation amount per timestep, 0 < qyhbrlx <= 1 [nondim] real, optional, intent(out) :: dp0k(:) !< minimum deep z-layer separation [H ~> m or kg m-2] real, optional, intent(out) :: ds0k(:) !< minimum shallow z-layer separation [H ~> m or kg m-2] @@ -687,8 +689,8 @@ real function cushn(delp, dp0) ! These are derivative nondimensional parameters. ! real, parameter :: cusha = qqmn**2 * (qqmx-1.0) / (qqmx-qqmn)**2 ! real, parameter :: I_qqmn = 1.0 / qqmn - real, parameter :: qq_scale = (qqmx-1.0) / (qqmx-qqmn)**2 - real, parameter :: I_qqmx = 1.0 / qqmx + real, parameter :: qq_scale = (qqmx-1.0) / (qqmx-qqmn)**2 ! A scaling factor based on qqmn and qqmx [nondim] + real, parameter :: I_qqmx = 1.0 / qqmx ! The inverse of qqmx [nondim] ! --- if delp >= qqmx*dp0 >> dp0, cushn returns delp. ! --- if delp <= qqmn*dp0 << -dp0, cushn returns dp0. diff --git a/src/ALE/MOM_hybgen_remap.F90 b/src/ALE/MOM_hybgen_remap.F90 index 5ab3e162db..f97b0e9c62 100644 --- a/src/ALE/MOM_hybgen_remap.F90 +++ b/src/ALE/MOM_hybgen_remap.F90 @@ -126,7 +126,7 @@ subroutine hybgen_ppm_coefs(s, h_src, edges, nk, ns, thin, PCM_lay) real :: da ! Difference between the unlimited scalar edge value estimates [A] real :: a6 ! Scalar field differences that are proportional to the curvature [A] real :: slk, srk ! Differences between adjacent cell averages of scalars [A] - real :: sck ! Scalar differences across a cell. + real :: sck ! Scalar differences across a cell [A] real :: as(nk) ! Scalar field difference across each cell [A] real :: al(nk), ar(nk) ! Scalar field at the left and right edges of a cell [A] real :: h112(nk+1), h122(nk+1) ! Combinations of thicknesses [H ~> m or kg m-2] diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index eeb4590a08..abcd821790 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -1723,7 +1723,7 @@ logical function test_interp(verbose, msg, nsrc, h_src, u_src, ndest, h_dest, u_ ! Local variables real, dimension(ndest+1) :: u_dest ! Interpolated value at destination cell interfaces [A] integer :: k - real :: error + real :: error ! The difference between the evaluated and expected solutions [A] ! Interpolate from src to dest call interpolate_column(nsrc, h_src, u_src, ndest, h_dest, u_dest, .true.) @@ -1760,7 +1760,7 @@ logical function test_reintegrate(verbose, msg, nsrc, h_src, uh_src, ndest, h_de ! Local variables real, dimension(ndest) :: uh_dest ! Reintegrated value on destination cells [A H] integer :: k - real :: error + real :: error ! The difference between the evaluated and expected solutions [A H] ! Interpolate from src to dest call reintegrate_column(nsrc, h_src, uh_src, ndest, h_dest, uh_dest) diff --git a/src/ALE/P1M_functions.F90 b/src/ALE/P1M_functions.F90 index b17b35c85c..7889966135 100644 --- a/src/ALE/P1M_functions.F90 +++ b/src/ALE/P1M_functions.F90 @@ -36,7 +36,7 @@ subroutine P1M_interpolation( N, h, u, edge_values, ppoly_coef, h_neglect, answe ! Local variables integer :: k ! loop index - real :: u0_l, u0_r ! edge values (left and right) + real :: u0_l, u0_r ! edge values (left and right) [A] ! Bound edge values (routine found in 'edge_values.F90') call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) @@ -74,10 +74,10 @@ subroutine P1M_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly [A] ! Local variables - real :: u0, u1 ! cell averages - real :: h0, h1 ! corresponding cell widths - real :: slope ! retained PLM slope - real :: u0_l, u0_r ! edge values + real :: u0, u1 ! cell averages [A] + real :: h0, h1 ! corresponding cell widths [H] + real :: slope ! retained PLM slope [A] + real :: u0_l, u0_r ! edge values [A] ! ----------------------------------------- ! Left edge value in the left boundary cell diff --git a/src/ALE/PCM_functions.F90 b/src/ALE/PCM_functions.F90 index 4f64e4a96d..f5899339e4 100644 --- a/src/ALE/PCM_functions.F90 +++ b/src/ALE/PCM_functions.F90 @@ -17,11 +17,11 @@ module PCM_functions !! defining 'grid' and 'ppoly'. No consistency check is performed. subroutine PCM_reconstruction( N, u, edge_values, ppoly_coef ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: u !< cell averages + real, dimension(:), intent(in) :: u !< cell averages in arbitrary units [A] real, dimension(:,:), intent(inout) :: edge_values !< Edge value of polynomial, - !! with the same units as u. + !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, - !! with the same units as u. + !! with the same units as u [A]. ! Local variables integer :: k diff --git a/src/ALE/PLM_functions.F90 b/src/ALE/PLM_functions.F90 index bc7f100a04..c0c4516fe2 100644 --- a/src/ALE/PLM_functions.F90 +++ b/src/ALE/PLM_functions.F90 @@ -16,20 +16,21 @@ module PLM_functions contains -!> Returns a limited PLM slope following White and Adcroft, 2008. [units of u] +!> Returns a limited PLM slope following White and Adcroft, 2008, in the same arbitrary +!! units [A] as the input values. !! Note that this is not the same as the Colella and Woodward method. real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) - real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] - real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] - real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] - real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] - real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] ! Local variables real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as - ! differences across the cell [units of u] - real :: u_min, u_max ! Minimum and maximum value across cell [units of u] + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] ! Side differences sigma_r = u_r - u_c @@ -63,20 +64,21 @@ real elemental pure function PLM_slope_wa(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ end function PLM_slope_wa -!> Returns a limited PLM slope following Colella and Woodward 1984. +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_r) - real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] - real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] - real, intent(in) :: h_r !< Thickness of right cell [units of grid thickness] - real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] - real, intent(in) :: u_r !< Value of right cell [units of u] + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_r !< Thickness of right cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] ! Local variables real :: sigma_l, sigma_c, sigma_r ! Left, central and right slope estimates as - ! differences across the cell [units of u] - real :: u_min, u_max ! Minimum and maximum value across cell [units of u] - real :: h_cn ! Thickness of center cell [units of grid thickness] + ! differences across the cell [A] + real :: u_min, u_max ! Minimum and maximum value across cell [A] + real :: h_cn ! Thickness of center cell [H] h_cn = h_c + h_neglect @@ -117,18 +119,19 @@ real elemental pure function PLM_slope_cw(h_l, h_c, h_r, h_neglect, u_l, u_c, u_ end function PLM_slope_cw -!> Returns a limited PLM slope following Colella and Woodward 1984. +!> Returns a limited PLM slope following Colella and Woodward 1984, in the same +!! arbitrary units as the input values [A]. real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] - real, intent(in) :: u_r !< Value of right cell [units of u] - real, intent(in) :: s_l !< PLM slope of left cell [units of u] - real, intent(in) :: s_c !< PLM slope of center cell [units of u] - real, intent(in) :: s_r !< PLM slope of right cell [units of u] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] + real, intent(in) :: u_r !< Value of right cell in arbitrary units [A] + real, intent(in) :: s_l !< PLM slope of left cell [A] + real, intent(in) :: s_c !< PLM slope of center cell [A] + real, intent(in) :: s_r !< PLM slope of right cell [A] ! Local variables - real :: e_r, e_l, edge ! Right, left and temporary edge values [units of u] - real :: almost_two ! The number 2, almost. - real :: slp ! Magnitude of PLM central slope [units of u] + real :: e_r, e_l, edge ! Right, left and temporary edge values [A] + real :: almost_two ! The number 2, almost [nondim] + real :: slp ! Magnitude of PLM central slope [A] almost_two = 2. * ( 1. - epsilon(s_c) ) @@ -155,17 +158,18 @@ real elemental pure function PLM_monotonized_slope(u_l, u_c, u_r, s_l, s_c, s_r) end function PLM_monotonized_slope -!> Returns a PLM slope using h2 extrapolation from a cell to the left. +!> Returns a PLM slope using h2 extrapolation from a cell to the left, in the same +!! arbitrary units as the input values [A]. !! Use the negative to extrapolate from the cell to the right. real elemental pure function PLM_extrapolate_slope(h_l, h_c, h_neglect, u_l, u_c) - real, intent(in) :: h_l !< Thickness of left cell [units of grid thickness] - real, intent(in) :: h_c !< Thickness of center cell [units of grid thickness] - real, intent(in) :: h_neglect !< A negligible thickness [units of grid thickness] - real, intent(in) :: u_l !< Value of left cell [units of u] - real, intent(in) :: u_c !< Value of center cell [units of u] + real, intent(in) :: h_l !< Thickness of left cell in arbitrary grid thickness units [H] + real, intent(in) :: h_c !< Thickness of center cell in arbitrary grid thickness units [H] + real, intent(in) :: h_neglect !< A negligible thickness [H] + real, intent(in) :: u_l !< Value of left cell in arbitrary units [A] + real, intent(in) :: u_c !< Value of center cell in arbitrary units [A] ! Local variables - real :: left_edge ! Left edge value [units of u] - real :: hl, hc ! Left and central cell thicknesses [units of grid thickness] + real :: left_edge ! Left edge value [A] + real :: hl, hc ! Left and central cell thicknesses [H] ! Avoid division by zero for vanished cells hl = h_l + h_neglect @@ -185,24 +189,26 @@ end function PLM_extrapolate_slope !! defining 'grid' and 'ppoly'. No consistency check is performed here. subroutine PLM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, - !! with the same units as u. + !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly - !! with the same units as u. + !! with the same units as u [A]. real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions - !! in the same units as h + !! in the same units as h [H] ! Local variables - integer :: k ! loop index - real :: u_l, u_r ! left and right cell averages - real :: slope ! retained PLM slope - real :: e_r, edge - real :: almost_one - real, dimension(N) :: slp, mslp - real :: hNeglect + integer :: k ! loop index + real :: u_l, u_r ! left and right cell averages [A] + real :: slope ! retained PLM slope for a normalized cell width [A] + real :: e_r ! The edge value in the neighboring cell [A] + real :: edge ! The projected edge value in the cell [A] + real :: almost_one ! A value that is slightly smaller than 1 [nondim] + real, dimension(N) :: slp ! The first guess at the normalized tracer slopes [A] + real, dimension(N) :: mslp ! The monotonized normalized tracer slopes [A] + real :: hNeglect ! A negligibly small width used in cell reconstructions [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -265,18 +271,18 @@ end subroutine PLM_reconstruction !! defining 'grid' and 'ppoly'. No consistency check is performed here. subroutine PLM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_neglect ) integer, intent(in) :: N !< Number of cells - real, dimension(:), intent(in) :: h !< cell widths (size N) - real, dimension(:), intent(in) :: u !< cell averages (size N) + real, dimension(:), intent(in) :: h !< cell widths (size N) [H] + real, dimension(:), intent(in) :: u !< cell averages (size N) in arbitrary units [A] real, dimension(:,:), intent(inout) :: edge_values !< edge values of piecewise polynomials, - !! with the same units as u. + !! with the same units as u [A]. real, dimension(:,:), intent(inout) :: ppoly_coef !< coefficients of piecewise polynomials, mainly - !! with the same units as u. + !! with the same units as u [A]. real, optional, intent(in) :: h_neglect !< A negligibly small width for !! the purpose of cell reconstructions - !! in the same units as h + !! in the same units as h [H] ! Local variables - real :: slope ! retained PLM slope - real :: hNeglect + real :: slope ! retained PLM slope for a normalized cell width [A] + real :: hNeglect ! A negligibly small width used in cell reconstructions [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect diff --git a/src/ALE/PPM_functions.F90 b/src/ALE/PPM_functions.F90 index 805a70d502..ef6841f635 100644 --- a/src/ALE/PPM_functions.F90 +++ b/src/ALE/PPM_functions.F90 @@ -28,7 +28,7 @@ module PPM_functions subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answer_date) integer, intent(in) :: N !< Number of cells real, dimension(N), intent(in) :: h !< Cell widths [H] - real, dimension(N), intent(in) :: u !< Cell averages [A] + real, dimension(N), intent(in) :: u !< Cell averages in arbitrary coordinates [A] real, dimension(N,2), intent(inout) :: edge_values !< Edge values [A] real, dimension(N,3), intent(inout) :: ppoly_coef !< Polynomial coefficients, mainly [A] real, optional, intent(in) :: h_neglect !< A negligibly small width [H] @@ -36,7 +36,7 @@ subroutine PPM_reconstruction( N, h, u, edge_values, ppoly_coef, h_neglect, answ ! Local variables integer :: k ! Loop index - real :: edge_l, edge_r ! Edge values (left and right) + real :: edge_l, edge_r ! Edge values (left and right) [A] ! PPM limiter call PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date=answer_date ) @@ -69,9 +69,9 @@ subroutine PPM_limiter_standard( N, h, u, edge_values, h_neglect, answer_date ) ! Local variables integer :: k ! Loop index - real :: u_l, u_c, u_r ! Cell averages (left, center and right) - real :: edge_l, edge_r ! Edge values (left and right) - real :: expr1, expr2 + real :: u_l, u_c, u_r ! Cell averages (left, center and right) [A] + real :: edge_l, edge_r ! Edge values (left and right) [A] + real :: expr1, expr2 ! Temporary expressions [A2] ! Bound edge values call bound_edge_values( N, h, u, edge_values, h_neglect, answer_date=answer_date ) @@ -135,8 +135,8 @@ subroutine PPM_monotonicity( N, u, edge_values ) real, dimension(:,:), intent(inout) :: edge_values !< Potentially modified edge values [A] ! Local variables - integer :: k ! Loop index - real :: a6,da ! scalar temporaries + integer :: k ! Loop index + real :: a6, da ! Normalized scalar curvature and slope [A] ! Loop on interior cells to impose monotonicity ! Eq. 1.10 of (Colella & Woodward, JCP 84) @@ -195,14 +195,16 @@ subroutine PPM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef, h_negle ! Local variables integer :: i0, i1 - real :: u0, u1 - real :: h0, h1 - real :: a, b, c - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: exp1, exp2 - real :: hNeglect + real :: u0, u1 ! Average concentrations in the two neighboring cells [A] + real :: h0, h1 ! Thicknesses of the two neighboring cells [H] + real :: a, b, c ! An edge value, normalized slope and normalized curvature + ! of a reconstructed distribution [A] + real :: u0_l, u0_r ! Edge values of a neighboring cell [A] + real :: u1_l, u1_r ! Neighboring cell slopes renormalized by the thickness of + ! the cell being worked on [A] + real :: slope ! The normalized slope [A] + real :: exp1, exp2 ! Temporary expressions [A2] + real :: hNeglect ! A negligibly small width used in cell reconstructions [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect diff --git a/src/ALE/PQM_functions.F90 b/src/ALE/PQM_functions.F90 index 1159652858..ef42fb9f01 100644 --- a/src/ALE/PQM_functions.F90 +++ b/src/ALE/PQM_functions.F90 @@ -30,10 +30,10 @@ subroutine PQM_reconstruction( N, h, u, edge_values, edge_slopes, ppoly_coef, h_ ! Local variables integer :: k ! loop index - real :: h_c ! cell width + real :: h_c ! cell width [H] real :: u0_l, u0_r ! edge values (left and right) [A] real :: u1_l, u1_r ! edge slopes (left and right) [A H-1] - real :: a, b, c, d, e ! parabola coefficients + real :: a, b, c, d, e ! quartic fit coefficients [A] ! PQM limiter call PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_date=answer_date ) @@ -90,14 +90,15 @@ subroutine PQM_limiter( N, h, u, edge_values, edge_slopes, h_neglect, answer_dat real :: u1_l, u1_r ! edge slopes [A H-1] real :: u_l, u_c, u_r ! left, center and right cell averages [A] real :: h_l, h_c, h_r ! left, center and right cell widths [H] - real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes - real :: slope ! retained PLM slope - real :: a, b, c, d, e - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 - real :: hNeglect + real :: sigma_l, sigma_c, sigma_r ! left, center and right van Leer slopes [A H-1] + real :: slope ! retained PLM slope [A H-1] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: alpha1, alpha2, alpha3 ! Normalized second derivative coefficients [A] + real :: rho ! A temporary expression [A2] + real :: sqrt_rho ! The square root of rho [A] + real :: gradient1, gradient2 ! Normalized gradients [A] + real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] + real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -359,13 +360,13 @@ subroutine PQM_boundary_extrapolation( N, h, u, edge_values, ppoly_coef ) real, dimension(:,:), intent(inout) :: ppoly_coef !< Coefficients of polynomial, mainly [A] ! Local variables integer :: i0, i1 - real :: u0, u1 - real :: h0, h1 - real :: a, b, c, d, e - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: slope - real :: exp1, exp2 + real :: u0, u1 ! Successive cell averages [A] + real :: h0, h1 ! Successive cell thicknesses [H] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: u0_l, u0_r ! Edge values [A] + real :: u1_l, u1_r ! Edge slopes [A H-1] + real :: slope ! The integrated slope across the cell [A] + real :: exp1, exp2 ! Two temporary expressions [A2] ! ----- Left boundary ----- i0 = 1 @@ -511,19 +512,21 @@ subroutine PQM_boundary_extrapolation_v1( N, h, u, edge_values, edge_slopes, ppo integer :: i0, i1 integer :: inflexion_l integer :: inflexion_r - real :: u0, u1, um - real :: h0, h1 - real :: a, b, c, d, e - real :: ar, br, beta - real :: u0_l, u0_r - real :: u1_l, u1_r - real :: u_plm - real :: slope - real :: alpha1, alpha2, alpha3 - real :: rho, sqrt_rho - real :: gradient1, gradient2 - real :: x1, x2 - real :: hNeglect + real :: u0, u1, um ! Successive cell averages [A] + real :: h0, h1 ! Successive cell thicknesses [H] + real :: a, b, c, d, e ! quartic fit coefficients [A] + real :: ar, br ! Temporary variables in [A] + real :: beta ! A rational function coefficient [nondim] + real :: u0_l, u0_r ! Edge values [A] + real :: u1_l, u1_r ! Edge slopes [A H-1] + real :: u_plm ! The integrated piecewise linear method slope [A] + real :: slope ! The integrated slope across the cell [A] + real :: alpha1, alpha2, alpha3 ! Normalized second derivative coefficients [A] + real :: rho ! A temporary expression [A2] + real :: sqrt_rho ! The square root of rho [A] + real :: gradient1, gradient2 ! Normalized gradients [A] + real :: x1, x2 ! Fractional inflection point positions in a cell [nondim] + real :: hNeglect ! A negligibly small width for the purpose of cell reconstructions [H] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect diff --git a/src/ALE/coord_zlike.F90 b/src/ALE/coord_zlike.F90 index f2ed7f0035..7f284217b2 100644 --- a/src/ALE/coord_zlike.F90 +++ b/src/ALE/coord_zlike.F90 @@ -67,13 +67,15 @@ subroutine build_zstar_column(CS, depth, total_thickness, zInterface, & !! output units), units may be [Z ~> m] or [H ~> m or kg m-2] real, intent(in) :: total_thickness !< Column thickness (positive definite in the same !! units as depth) [Z ~> m] or [H ~> m or kg m-2] - real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces + real, dimension(CS%nk+1), intent(inout) :: zInterface !< Absolute positions of interfaces (in the same + !! units as depth) [Z ~> m] or [H ~> m or kg m-2] real, optional, intent(in) :: z_rigid_top !< The height of a rigid top (positive upward in the same !! units as depth) [Z ~> m] or [H ~> m or kg m-2] - real, optional, intent(in) :: eta_orig !< The actual original height of the top in the same + real, optional, intent(in) :: eta_orig !< The actual original height of the top (in the same !! units as depth) [Z ~> m] or [H ~> m or kg m-2] real, optional, intent(in) :: zScale !< Scaling factor from the target coordinate resolution - !! in Z to desired units for zInterface, perhaps Z_to_H + !! in Z to desired units for zInterface, perhaps Z_to_H, + !! often [nondim] or [H Z-1 ~> 1 or kg m-3] ! Local variables real :: eta ! Free surface height [Z ~> m] or [H ~> m or kg m-2] real :: stretching ! A stretching factor for the coordinate [nondim] diff --git a/src/ALE/polynomial_functions.F90 b/src/ALE/polynomial_functions.F90 index e5c90fe31d..b01e097b83 100644 --- a/src/ALE/polynomial_functions.F90 +++ b/src/ALE/polynomial_functions.F90 @@ -9,7 +9,7 @@ module polynomial_functions contains -!> Pointwise evaluation of a polynomial at x +!> Pointwise evaluation of a polynomial in arbitrary units [A] at x !! !! The polynomial is defined by the coefficients contained in the !! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... @@ -17,12 +17,14 @@ module polynomial_functions !! The number of coefficients is given by ncoef and x !! is the coordinate where the polynomial is to be evaluated. real function evaluation_polynomial( coeff, ncoef, x ) - real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] integer, intent(in) :: ncoef !< The number of polynomial coefficients real, intent(in) :: x !< The position at which to evaluate the polynomial + !! in arbitrary thickness units [H] ! Local variables integer :: k - real :: f ! value of polynomial at x + real :: f ! value of polynomial at x in arbitrary units [A] f = 0.0 do k = 1,ncoef @@ -33,7 +35,8 @@ real function evaluation_polynomial( coeff, ncoef, x ) end function evaluation_polynomial -!> Calculates the first derivative of a polynomial evaluated at a point x +!> Calculates the first derivative of a polynomial evaluated in arbitrary units of [A H-1] +!! at a point x !! !! The polynomial is defined by the coefficients contained in the !! array of the same name, as follows: C(1) + C(2)x + C(3)x^2 + C(4)x^3 + ... @@ -41,12 +44,14 @@ end function evaluation_polynomial !! The number of coefficients is given by ncoef and x !! is the coordinate where the polynomial's derivative is to be evaluated. real function first_derivative_polynomial( coeff, ncoef, x ) - real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial + real, dimension(:), intent(in) :: coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] integer, intent(in) :: ncoef !< The number of polynomial coefficients real, intent(in) :: x !< The position at which to evaluate the derivative + !! in arbitrary thickness units [H] ! Local variables integer :: k - real :: f ! value of polynomial at x + real :: f ! value of the derivative at x in [A H-1] f = 0.0 do k = 2,ncoef @@ -57,17 +62,20 @@ real function first_derivative_polynomial( coeff, ncoef, x ) end function first_derivative_polynomial -!> Exact integration of polynomial of degree npoly +!> Exact integration of polynomial of degree npoly in arbitrary units of [A H] !! !! The array of coefficients (Coeff) must be of size npoly+1. real function integration_polynomial( xi0, xi1, Coeff, npoly ) - real, intent(in) :: xi0 !< The lower bound of the integral - real, intent(in) :: xi1 !< The lower bound of the integral - real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial + real, intent(in) :: xi0 !< The lower bound of the integral in arbitrary + !! thickness units [H] + real, intent(in) :: xi1 !< The upper bound of the integral in arbitrary + !! thickness units [H] + real, dimension(:), intent(in) :: Coeff !< The coefficients of the polynomial, in units that + !! vary with the index k as [A H^(k-1)] integer, intent(in) :: npoly !< The degree of the polynomial ! Local variables - integer :: k - real :: integral + integer :: k + real :: integral ! The integral of the polynomial over the specified range in [A H] integral = 0.0 diff --git a/src/ALE/regrid_edge_values.F90 b/src/ALE/regrid_edge_values.F90 index 9b574348af..0814c6a907 100644 --- a/src/ALE/regrid_edge_values.F90 +++ b/src/ALE/regrid_edge_values.F90 @@ -27,7 +27,7 @@ module regrid_edge_values !! thickness for sum(h) in edge value inversions real, parameter :: hNeglect_dflt = 1.e-30 !< The default value for cut-off minimum !! thickness for sum(h) in other calculations -real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) +real, parameter :: hMinFrac = 1.e-5 !< A minimum fraction for min(h)/sum(h) [nondim] contains @@ -119,7 +119,7 @@ subroutine average_discontinuous_edge_values( N, edge_val ) !! second index is for the two edges of each cell. ! Local variables integer :: k ! loop index - real :: u0_avg ! avg value at given edge + real :: u0_avg ! avg value at given edge [A] ! Loop on interior edges do k = 1,N-1 @@ -231,19 +231,24 @@ subroutine edge_values_explicit_h4( N, h, u, edge_val, h_neglect, answer_date ) ! Local variables real :: h0, h1, h2, h3 ! temporary thicknesses [H] real :: h_min ! A minimal cell width [H] - real :: f1, f2, f3 ! auxiliary variables with various units + real :: f1 ! An auxiliary variable [H] + real :: f2 ! An auxiliary variable [A H] + real :: f3 ! An auxiliary variable [H-1] real :: et1, et2, et3 ! terms the expression for edge values [A H] real :: I_h12 ! The inverse of the sum of the two central thicknesses [H-1] real :: I_h012, I_h123 ! Inverses of sums of three successive thicknesses [H-1] real :: I_den_et2, I_den_et3 ! Inverses of denominators in edge value terms [H-2] - real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] - real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real, parameter :: C1_12 = 1.0 / 12.0 - real :: dx ! Difference of successive values of x [H] - real, dimension(4,4) :: A ! values near the boundaries - real, dimension(4) :: B, C - real :: hNeglect ! A negligible thickness in the same units as h. + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] + real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational constant [nondim] + real :: dx ! Difference of successive values of x [H] + real, dimension(4,4) :: A ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: B ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: C ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] + real :: hNeglect ! A negligible thickness in the same units as h [H]. integer :: i, j logical :: use_2018_answers ! If true use older, less accurate expressions. @@ -383,11 +388,11 @@ subroutine edge_values_explicit_h4cw( N, h, u, edge_val, h_neglect ) ! Local variables real :: dp(N) ! Input grid layer thicknesses, but with a minimum thickness [H ~> m or kg m-2] - real :: hNeglect ! A negligible thickness in the same units as h + real :: hNeglect ! A negligible thickness in the same units as h [H] real :: da ! Difference between the unlimited scalar edge value estimates [A] real :: a6 ! Scalar field differences that are proportional to the curvature [A] real :: slk, srk ! Differences between adjacent cell averages of scalars [A] - real :: sck ! Scalar differences across a cell. + real :: sck ! Scalar differences across a cell [A] real :: au(N) ! Scalar field difference across each cell [A] real :: al(N), ar(N) ! Scalar field at the left and right edges of a cell [A] real :: h112(N+1), h122(N+1) ! Combinations of thicknesses [H ~> m or kg m-2] @@ -496,22 +501,26 @@ subroutine edge_values_implicit_h4( N, h, u, edge_val, h_neglect, answer_date ) integer :: i, j ! loop indexes real :: h0, h1 ! cell widths [H] real :: h_min ! A minimal cell width [H] - real :: h0_2, h1_2, h0h1 - real :: h0ph1_2, h0ph1_4 + real :: h0_2, h1_2, h0h1 ! Squares or products of thicknesses [H2] + real :: h0ph1_2 ! The square of a sum of thicknesses [H2] + real :: h0ph1_4 ! The fourth power of a sum of thicknesses [H4] real :: alpha, beta ! stencil coefficients [nondim] real :: I_h2, abmix ! stencil coefficients [nondim] - real :: a, b + real :: a, b ! Combinations of stencil coefficients [nondim] real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C1_3 = 1.0 / 3.0 + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational constant [nondim] + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational constant [nondim] real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] real :: dx ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: Asys ! boundary conditions - real, dimension(4) :: Bsys, Csys + real, dimension(4,4) :: Asys ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: Bsys ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: Csys ! The coefficients of a fit polynomial in units that vary + ! with the index (j) as [A H^(j-1)] real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] - tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_c, & ! tridiagonal system central value [nondim], with tri_d = tri_c+tri_l+tri_u tri_u, & ! tridiagonal system (upper diagonal) [nondim] tri_b, & ! tridiagonal system (right hand side) [A] tri_x ! tridiagonal system (solution vector) [A] @@ -667,7 +676,7 @@ subroutine end_value_h4(dz, u, Csys) real :: I_denom ! The inverse of the denominator some expressions [H-3] real :: I_denB3 ! The inverse of the product of three sums of thicknesses [H-3] real :: min_frac = 1.0e-6 ! The square of min_frac should be much larger than roundoff [nondim] - real, parameter :: C1_3 = 1.0 / 3.0 + real, parameter :: C1_3 = 1.0 / 3.0 ! A rational parameter [nondim] ! These are only used for code verification ! real, dimension(4) :: Atest ! The coefficients of an expression that is being tested. @@ -810,17 +819,21 @@ subroutine edge_slopes_implicit_h3( N, h, u, edge_slopes, h_neglect, answer_date real :: I_h ! Inverses of thicknesses [H-1] real :: alpha, beta ! stencil coefficients [nondim] real :: a, b ! weights of cells [H-1] - real, parameter :: C1_12 = 1.0 / 12.0 + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] real, dimension(4) :: dz ! A temporary array of limited layer thicknesses [H] real, dimension(4) :: u_tmp ! A temporary array of cell average properties [A] - real, dimension(5) :: x ! Coordinate system with 0 at edges [H] - real :: dx ! Differences and averages of successive values of x [H] - real, dimension(4,4) :: Asys ! matrix used to find boundary conditions - real, dimension(4) :: Bsys, Csys - real, dimension(3) :: Dsys + real, dimension(5) :: x ! Coordinate system with 0 at edges [H] + real :: dx ! Differences and averages of successive values of x [H] + real, dimension(4,4) :: Asys ! Differences in successive positions raised to various powers, + ! in units that vary with the second (j) index as [H^j] + real, dimension(4) :: Bsys ! The right hand side of the system to solve for C [A H] + real, dimension(4) :: Csys ! The coefficients of a fit polynomial in units that vary with the + ! index (j) as [A H^(j-1)] + real, dimension(3) :: Dsys ! The coefficients of the first derivative of the fit polynomial + ! in units that vary with the index (j) as [A H^(j-2)] real, dimension(N+1) :: tri_l, & ! tridiagonal system (lower diagonal) [nondim] tri_d, & ! tridiagonal system (middle diagonal) [nondim] - tri_c, & ! tridiagonal system central value, with tri_d = tri_c+tri_l+tri_u + tri_c, & ! tridiagonal system central value [nondim], with tri_d = tri_c+tri_l+tri_u tri_u, & ! tridiagonal system (upper diagonal) [nondim] tri_b, & ! tridiagonal system (right hand side) [A H-1] tri_x ! tridiagonal system (solution vector) [A H-1] @@ -1009,23 +1022,27 @@ subroutine edge_slopes_implicit_h5( N, h, u, edge_slopes, h_neglect, answer_date real :: h01, h01_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: h23, h23_2 ! Summed thicknesses to various powers [H^n ~> m^n or kg^n m-2n] real :: hNeglect ! A negligible thickness [H]. - real :: h1_2, h2_2 ! the coefficients of the - real :: h1_3, h2_3 ! tridiagonal system - real :: h1_4, h2_4 ! ... - real :: h1_5, h2_5 ! ... - real :: alpha, beta ! stencil coefficients - real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C5_6 = 5.0 / 6.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] - real, dimension(6,6) :: Asys ! matrix used to find boundary conditions - real, dimension(6) :: Bsys, Csys ! ... - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) - real :: h_Min_Frac = 1.0e-4 + real :: h1_2, h2_2 ! Squares of thicknesses [H2] + real :: h1_3, h2_3 ! Cubes of thicknesses [H3] + real :: h1_4, h2_4 ! Fourth powers of thicknesses [H4] + real :: h1_5, h2_5 ! Fifth powers of thicknesses [H5] + real :: alpha, beta ! stencil coefficients [nondim] + real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim] + real :: dx, xavg ! Differences and averages of successive values of x [same units as h] + real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution, + ! in units that might vary with the second (j) index as [H^j] + real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various + ! units that sometimes vary with the intex (j) as [H^(j-1)] or [H^j] + ! or might be [A] + real, dimension(6) :: Csys ! The solution to a matrix equation usually [nondim] in this routine. + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (rhs) [A H-1] + tri_x ! trid. system (unknowns vector) [A H-1] + real :: h_Min_Frac = 1.0e-4 ! A minimum fractional thickness [nondim] integer :: i, k ! loop indexes hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -1249,18 +1266,24 @@ subroutine edge_values_implicit_h6( N, h, u, edge_val, h_neglect, answer_date ) real :: hNeglect ! A negligible thickness [H]. real :: h1_2, h2_2, h1_3, h2_3 ! Cell widths raised to the 2nd and 3rd powers [H2] or [H3] real :: h1_4, h2_4, h1_5, h2_5 ! Cell widths raised to the 4th and 5th powers [H4] or [H5] - real :: alpha, beta ! stencil coefficients - real, dimension(7) :: x ! Coordinate system with 0 at edges [same units as h] - real, parameter :: C1_12 = 1.0 / 12.0 - real, parameter :: C5_6 = 5.0 / 6.0 - real :: dx, xavg ! Differences and averages of successive values of x [same units as h] - real, dimension(6,6) :: Asys ! boundary conditions - real, dimension(6) :: Bsys, Csys ! ... - real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) - tri_d, & ! trid. system (middle diagonal) - tri_u, & ! trid. system (upper diagonal) - tri_b, & ! trid. system (unknowns vector) - tri_x ! trid. system (rhs) + real :: alpha, beta ! stencil coefficients [nondim] + real, dimension(7) :: x ! Coordinate system with 0 at edges in the same units as h [H] + real, parameter :: C1_12 = 1.0 / 12.0 ! A rational parameter [nondim] + real, parameter :: C5_6 = 5.0 / 6.0 ! A rational parameter [nondim] + real :: dx, xavg ! Differences and averages of successive values of x [H] + real, dimension(6,6) :: Asys ! The matrix that is being inverted for a solution, + ! in units that might vary with the second (j) index as [H^j] + real, dimension(6) :: Bsys ! The right hand side of the system to solve for C in various + ! units that sometimes vary with the intex (j) as [H^(j-1)] or [H^j] + ! or might be [A] + real, dimension(6) :: Csys ! The solution to a matrix equation, which might be [nondim] or the + ! coefficients of a fit polynomial in units that vary with the + ! index (j) as [A H^(j-1)] + real, dimension(N+1) :: tri_l, & ! trid. system (lower diagonal) [nondim] + tri_d, & ! trid. system (middle diagonal) [nondim] + tri_u, & ! trid. system (upper diagonal) [nondim] + tri_b, & ! trid. system (rhs) [A] + tri_x ! trid. system (unknowns vector) [A] integer :: i, k ! loop indexes hNeglect = hNeglect_edge_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -1432,16 +1455,16 @@ end subroutine edge_values_implicit_h6 !> Test that A*C = R to within a tolerance, issuing a fatal error with an explanatory message if they do not. subroutine test_line(msg, N, A, C, R, mag, tol) - real, intent(in) :: mag !< The magnitude of leading order terms in this line - integer, intent(in) :: N !< The number of points in the system - real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied - real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied - real, intent(in) :: R !< The expected solution of the equation character(len=*), intent(in) :: msg !< An identifying message for this test - real, optional, intent(in) :: tol !< The fractional tolerance for the two solutions - - real :: sum, sum_mag - real :: tolerance + integer, intent(in) :: N !< The number of points in the system + real, dimension(4), intent(in) :: A !< One of the two vectors being multiplied in arbitrary units [A] + real, dimension(4), intent(in) :: C !< One of the two vectors being multiplied in arbitrary units [B] + real, intent(in) :: R !< The expected solution of the equation [A B] + real, intent(in) :: mag !< The magnitude of leading order terms in this line [A B] + real, optional, intent(in) :: tol !< The fractional tolerance for the sums [nondim] + + real :: sum, sum_mag ! The sum of the products and their magnitude in arbitrary units [A B] + real :: tolerance ! The fractional tolerance for the sums [nondim] character(len=128) :: mesg2 integer :: i diff --git a/src/ALE/regrid_solvers.F90 b/src/ALE/regrid_solvers.F90 index 0655d31062..6e5b3a0cb0 100644 --- a/src/ALE/regrid_solvers.F90 +++ b/src/ALE/regrid_solvers.F90 @@ -18,15 +18,19 @@ module regrid_solvers !! The matrix A must be square, with the first index varing down the column. subroutine solve_linear_system( A, R, X, N, answer_date ) integer, intent(in) :: N !< The size of the system - real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] - real, dimension(N), intent(inout) :: R !< system right-hand side [A] - real, dimension(N), intent(inout) :: X !< solution vector [A] + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted in arbitrary units [A] on + !! input, but internally modified to become nondimensional + !! during the solver. + real, dimension(N), intent(inout) :: R !< system right-hand side in arbitrary units [A B] on + !! input, but internally modified to have units of [B] + !! during the solver + real, dimension(N), intent(inout) :: X !< solution vector in arbitrary units [B] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables - real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor ! The factor that eliminates the leading nonzero element in a row. - real :: pivot, I_pivot ! The pivot value and its reciprocal [nondim] - real :: swap_a, swap_b + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed [A] + real :: factor ! The factor that eliminates the leading nonzero element in a row [A-1] + real :: pivot, I_pivot ! The pivot value and its reciprocal, in [A] and [A-1] + real :: swap_a, swap_b ! Swap space in various units [various] logical :: found_pivot ! If true, a pivot has been found logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers integer :: i, j, k @@ -110,15 +114,18 @@ end subroutine solve_linear_system !! The matrix A must be square, with the first index varing along the row. subroutine linear_solver( N, A, R, X ) integer, intent(in) :: N !< The size of the system - real, dimension(N,N), intent(inout) :: A !< The matrix being inverted [nondim] - real, dimension(N), intent(inout) :: R !< system right-hand side [A] - real, dimension(N), intent(inout) :: X !< solution vector [A] + real, dimension(N,N), intent(inout) :: A !< The matrix being inverted in arbitrary units [A] on + !! input, but internally modified to become nondimensional + !! during the solver. + real, dimension(N), intent(inout) :: R !< system right-hand side in [A B] on input, but internally + !! modified to have units of [B] during the solver + real, dimension(N), intent(inout) :: X !< solution vector [B] ! Local variables - real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed - real :: factor ! The factor that eliminates the leading nonzero element in a row. - real :: I_pivot ! The reciprocal of the pivot value [inverse of the input units of a row of A] - real :: swap + real, parameter :: eps = 0.0 ! Minimum pivot magnitude allowed [A] + real :: factor ! The factor that eliminates the leading nonzero element in a row [A-1]. + real :: I_pivot ! The reciprocal of the pivot value [A-1] + real :: swap ! Swap space used in various units [various] integer :: i, j, k ! Loop on rows to transform the problem into multiplication by an upper-right matrix. @@ -175,16 +182,17 @@ end subroutine linear_solver !! (A is made up of lower, middle and upper diagonals) subroutine solve_tridiagonal_system( Al, Ad, Au, R, X, N, answer_date ) integer, intent(in) :: N !< The size of the system - real, dimension(N), intent(in) :: Ad !< Matrix center diagonal - real, dimension(N), intent(in) :: Al !< Matrix lower diagonal - real, dimension(N), intent(in) :: Au !< Matrix upper diagonal - real, dimension(N), intent(in) :: R !< system right-hand side - real, dimension(N), intent(out) :: X !< solution vector + real, dimension(N), intent(in) :: Ad !< Matrix center diagonal in arbitrary units [A] + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal [A] + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal [A] + real, dimension(N), intent(in) :: R !< system right-hand side in arbitrary units [A B] + real, dimension(N), intent(out) :: X !< solution vector in arbitrary units [B] integer, optional, intent(in) :: answer_date !< The vintage of the expressions to use ! Local variables - real, dimension(N) :: pivot, Al_piv - real, dimension(N) :: c1 ! Au / pivot for the backward sweep - real :: I_pivot ! The inverse of the most recent pivot + real, dimension(N) :: pivot ! The pivot value [A] + real, dimension(N) :: Al_piv ! The lower diagonal divided by the pivot value [nondim] + real, dimension(N) :: c1 ! Au / pivot for the backward sweep [nondim] + real :: I_pivot ! The inverse of the most recent pivot [A-1] integer :: k ! Loop index logical :: old_answers ! If true, use expressions that give the original (2008 through 2018) MOM6 answers @@ -237,16 +245,16 @@ end subroutine solve_tridiagonal_system !! roundoff compared with (Al+Au), the answers are prone to inaccuracy. subroutine solve_diag_dominant_tridiag( Al, Ac, Au, R, X, N ) integer, intent(in) :: N !< The size of the system - real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au - real, dimension(N), intent(in) :: Al !< Matrix lower diagonal - real, dimension(N), intent(in) :: Au !< Matrix upper diagonal - real, dimension(N), intent(in) :: R !< system right-hand side - real, dimension(N), intent(out) :: X !< solution vector + real, dimension(N), intent(in) :: Ac !< Matrix center diagonal offset from Al + Au in arbitrary units [A] + real, dimension(N), intent(in) :: Al !< Matrix lower diagonal [A] + real, dimension(N), intent(in) :: Au !< Matrix upper diagonal [A] + real, dimension(N), intent(in) :: R !< system right-hand side in arbitrary units [A B] + real, dimension(N), intent(out) :: X !< solution vector in arbitrary units [B] ! Local variables - real, dimension(N) :: c1 ! Au / pivot for the backward sweep - real :: d1 ! The next value of 1.0 - c1 - real :: I_pivot ! The inverse of the most recent pivot - real :: denom_t1 ! The first term in the denominator of the inverse of the pivot. + real, dimension(N) :: c1 ! Au / pivot for the backward sweep [nondim] + real :: d1 ! The next value of 1.0 - c1 [nondim] + real :: I_pivot ! The inverse of the most recent pivot [A-1] + real :: denom_t1 ! The first term in the denominator of the inverse of the pivot [A] integer :: k ! Loop index ! Factorization and forward sweep, in a form that will never give a division by a diff --git a/src/ALE/remapping_attic.F90 b/src/ALE/remapping_attic.F90 index 534428aaed..be20a27466 100644 --- a/src/ALE/remapping_attic.F90 +++ b/src/ALE/remapping_attic.F90 @@ -46,11 +46,13 @@ module remapping_attic function isPosSumErrSignificant(n1, sum1, n2, sum2) integer, intent(in) :: n1 !< Number of values in sum1 integer, intent(in) :: n2 !< Number of values in sum2 - real, intent(in) :: sum1 !< Sum of n1 values [A] + real, intent(in) :: sum1 !< Sum of n1 values in arbitrary units [A] real, intent(in) :: sum2 !< Sum of n2 values [A] logical :: isPosSumErrSignificant !< True if difference in sums is large ! Local variables - real :: sumErr, allowedErr, eps + real :: sumErr ! The absolutde difference in the sums [A] + real :: allowedErr ! The tolerance for the integrated reconstruction [A] + real :: eps ! A tiny fractional error [nondim] if (sum1<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum1<0 is not allowed!') if (sum2<0.) call MOM_error(FATAL,'isPosSumErrSignificant: sum2<0 is not allowed!') @@ -73,22 +75,22 @@ end function isPosSumErrSignificant subroutine remapByProjection( n0, h0, u0, ppoly0_E, ppoly0_coefs, & n1, h1, method, u1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid - real, intent(in) :: h0(:) !< Source grid widths (size n0) - real, intent(in) :: u0(:) !< Source cell averages (size n0) - real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial - real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial + real, intent(in) :: h0(:) !< Source grid widths (size n0) in thickness units [H] + real, intent(in) :: u0(:) !< Source cell averages (size n0) in arbitrary units [A] + real, intent(in) :: ppoly0_E(:,:) !< Edge value of polynomial [A] + real, intent(in) :: ppoly0_coefs(:,:) !< Coefficients of polynomial [A] integer, intent(in) :: n1 !< Number of cells in target grid - real, intent(in) :: h1(:) !< Target grid widths (size n1) + real, intent(in) :: h1(:) !< Target grid widths (size n1) [H] integer, intent(in) :: method !< Remapping scheme to use - real, intent(out) :: u1(:) !< Target cell averages (size n1) + real, intent(out) :: u1(:) !< Target cell averages (size n1) [A] real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h. + !! in the same units as h [H]. ! Local variables integer :: iTarget - real :: xL, xR ! coordinates of target cell edges + real :: xL, xR ! coordinates of target cell edges [H] integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() + real :: xStart ! Used by integrateReconOnInterval() [H] ! Loop on cells in target grid (grid1). For each target cell, we need to find ! in which source cells the target cell edges lie. The associated indexes are @@ -120,27 +122,32 @@ end subroutine remapByProjection subroutine remapByDeltaZ( n0, h0, u0, ppoly0_E, ppoly0_coefs, n1, dx1, & method, u1, h1, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) - real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) in thickness units [H] + real, dimension(:), intent(in) :: u0 !< Source cell averages (size n0) in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] integer, intent(in) :: n1 !< Number of cells in target grid - real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) + real, dimension(:), intent(in) :: dx1 !< Target grid edge positions (size n1+1) [H] integer, intent(in) :: method !< Remapping scheme to use - real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) + real, dimension(:), intent(out) :: u1 !< Target cell averages (size n1) [A] real, dimension(:), & - optional, intent(out) :: h1 !< Target grid widths (size n1) + optional, intent(out) :: h1 !< Target grid widths (size n1) [H] real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h. + !! in the same units as h [H]. ! Local variables integer :: iTarget - real :: xL, xR ! coordinates of target cell edges - real :: xOld, hOld, uOld - real :: xNew, hNew, h_err - real :: uhNew, hFlux, uAve, fluxL, fluxR + real :: xL, xR ! Coordinates of target cell edges [H] + real :: xOld, xNew ! Edge positions on the old and new grids [H] + real :: hOld, hNew ! Cell thicknesses on the old and new grids [H] + real :: uOld ! A source cell average of u [A] + real :: h_err ! An estimate of the error in the reconstructed thicknesses [H] + real :: uhNew ! Cell integrated u on the new grid [A H] + real :: hFlux ! Width of the remapped volume [H] + real :: uAve ! Target cell average of u [A] + real :: fluxL, fluxR ! Fluxes of u through the two cell faces [A H] integer :: jStart ! Used by integrateReconOnInterval() - real :: xStart ! Used by integrateReconOnInterval() + real :: xStart ! Used by integrateReconOnInterval() [H] ! Loop on cells in target grid. For each cell, iTarget, the left flux is ! the right flux of the cell to the left, iTarget-1. @@ -198,36 +205,35 @@ end subroutine remapByDeltaZ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, & xL, xR, hC, uAve, jStart, xStart, h_neglect ) integer, intent(in) :: n0 !< Number of cells in source grid - real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) - real, dimension(:), intent(in) :: u0 !< Source cell averages - real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial - real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial + real, dimension(:), intent(in) :: h0 !< Source grid sizes (size n0) in thickness units [H] + real, dimension(:), intent(in) :: u0 !< Source cell averages in arbitrary units [A] + real, dimension(:,:), intent(in) :: ppoly0_E !< Edge value of polynomial [A] + real, dimension(:,:), intent(in) :: ppoly0_coefs !< Coefficients of polynomial [A] integer, intent(in) :: method !< Remapping scheme to use - real, intent(in) :: xL !< Left edges of target cell - real, intent(in) :: xR !< Right edges of target cell - real, intent(in) :: hC !< Cell width hC = xR - xL - real, intent(out) :: uAve !< Average value on target cell + real, intent(in) :: xL !< Left edges of target cell [H] + real, intent(in) :: xR !< Right edges of target cell [H] + real, intent(in) :: hC !< Cell width hC = xR - xL [H] + real, intent(out) :: uAve !< Average value on target cell [A] integer, intent(inout) :: jStart !< The index of the cell to start searching from !< On exit, contains index of last cell used - real, intent(inout) :: xStart !< The left edge position of cell jStart + real, intent(inout) :: xStart !< The left edge position of cell jStart [H] !< On first entry should be 0. real, optional, intent(in) :: h_neglect !< A negligibly small width for the !! purpose of cell reconstructions - !! in the same units as h + !! in the same units as h [H] ! Local variables integer :: j, k - integer :: jL, jR ! indexes of source cells containing target - ! cell edges - real :: q ! complete integration - real :: xi0, xi1 ! interval of integration (local -- normalized - ! -- coordinates) - real :: x0jLl, x0jLr ! Left/right position of cell jL - real :: x0jRl, x0jRr ! Left/right position of cell jR + integer :: jL, jR ! indexes of source cells containing target cell edges + real :: q ! complete integration [A H] + real :: xi0, xi1 ! interval of integration (local -- normalized -- coordinates) [nondim] + real :: x0jLl, x0jLr ! Left/right position of cell jL [H] + real :: x0jRl, x0jRr ! Left/right position of cell jR [H] real :: hAct ! The distance actually used in the integration - ! (notionally xR - xL) which differs due to roundoff. - real :: x0_2, x1_2, x02px12, x0px1 ! Used in evaluation of integrated polynomials - real :: hNeglect ! A negligible thickness in the same units as h - real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials + ! (notionally xR - xL) which differs due to roundoff [H]. + real :: x0_2, x1_2 ! Squares of normalized positions used to evaluate polynomials [nondim] + real :: x0px1, x02px12 ! Sums of normalized positions and their squares [nondim] + real :: hNeglect ! A negligible thickness in the same units as h [H] + real, parameter :: r_3 = 1.0/3.0 ! Used in evaluation of integrated polynomials [nondim] hNeglect = hNeglect_dflt ; if (present(h_neglect)) hNeglect = h_neglect @@ -281,7 +287,7 @@ subroutine integrateReconOnInterval( n0, h0, u0, ppoly0_E, ppoly0_coefs, method, if ( h0(jL) == 0.0 ) then uAve = 0.5 * ( ppoly0_E(jL,1) + ppoly0_E(jL,2) ) else - !### WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA + ! WHY IS THIS NOT WRITTEN AS xi0 = ( xL - x0jLl ) / h0(jL) ---AJA xi0 = xL / ( h0(jL) + hNeglect ) - x0jLl / ( h0(jL) + hNeglect ) select case ( method ) @@ -540,17 +546,24 @@ logical function remapping_attic_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer, parameter :: n0 = 4, n1 = 3, n2 = 6 - real :: h0(n0), x0(n0+1), u0(n0) - real :: h1(n1), x1(n1+1), u1(n1), hn1(n1), dx1(n1+1) - real :: h2(n2), x2(n2+1), u2(n2), hn2(n2), dx2(n2+1) + real :: h0(n0), x0(n0+1) ! Test cell widths and edge coordinates [H] + real :: u0(n0) ! Test values for remapping in arbitrary units [A] + real :: h1(n1), x1(n1+1) ! Test cell widths and edge coordinates [H] + real :: u1(n1) ! Test values for remapping [A] + real :: h2(n2), x2(n2+1) ! Test cell widths and edge coordinates [H] + real :: u2(n2) ! Test values for remapping [A] + real :: hn1(n1), hn2(n2) ! Updated grid thicknesses [H] + real :: dx1(n1+1), dx2(n2+1) ! Differences in interface positions [H] data u0 /9., 3., -3., -9./ ! Linear profile, 4 at surface to -4 at bottom data h0 /4*0.75/ ! 4 uniform layers with total depth of 3 data h1 /3*1./ ! 3 uniform layers with total depth of 3 data h2 /6*0.5/ ! 6 uniform layers with total depth of 3 - real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S, ppoly0_coefs + real, allocatable, dimension(:,:) :: ppoly0_E, ppoly0_S ! Polynomial edge values [A] + real, allocatable, dimension(:,:) :: ppoly0_coefs ! Polynomial reconstruction coefficients [A] integer :: answer_date ! The vintage of the expressions to test integer :: i, degree - real :: err, h_neglect, h_neglect_edge + real :: err ! Difference between a remapped value and its expected value [A] + real :: h_neglect, h_neglect_edge ! Negligible thicknesses used in remapping [H] logical :: thisTest, v v = verbose From a23c7d8a66cb169bb95d32d39868a683afd97083 Mon Sep 17 00:00:00 2001 From: yuchengt900 Date: Mon, 11 Mar 2024 21:35:53 -0400 Subject: [PATCH 562/629] fix gtracer restart repro issue with OBC --- src/tracer/MOM_generic_tracer.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/tracer/MOM_generic_tracer.F90 b/src/tracer/MOM_generic_tracer.F90 index 7f550d8de5..f430e94515 100644 --- a/src/tracer/MOM_generic_tracer.F90 +++ b/src/tracer/MOM_generic_tracer.F90 @@ -414,7 +414,8 @@ subroutine initialize_MOM_generic_tracer(restart, day, G, GV, US, h, tv, param_f endif call g_tracer_get_obc_segment_props(g_tracer,g_tracer_name,obc_has ) - if(obc_has .and. g_tracer_is_prog(g_tracer)) call fill_obgc_segments(G, GV, OBC, tr_ptr, g_tracer_name) + if(obc_has .and. g_tracer_is_prog(g_tracer) .and. .not.restart) & + call fill_obgc_segments(G, GV, OBC, tr_ptr, g_tracer_name) !traverse the linked list till hit NULL call g_tracer_get_next(g_tracer, g_tracer_next) if (.NOT. associated(g_tracer_next)) exit From 4fd01625b23a3986e15e205357471e88d1e88e7f Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 14 Mar 2024 14:46:59 -0400 Subject: [PATCH 563/629] Rotation bugfixes This patch contains several bugfixes associated with the rotational grid testing. The following checksums are declared as scalar pairs, rather than vectors: * eta_[uv] (in porous barrier) * por_face_area[UV] * por_layer_width[UV] * Ray_[uv] (Rayleigh drag velocity) Fluxes and surface fields are now permitted to contain tracer fluxes (tr_fluxes) when rotation is enabled. The fields are retained in their unrotated form, since these are accessed and handled outside of MOM6. The rotated p_surf_SSH pointer in forces now correctly points to either p_surf or p_surf_full. read_netcdf_nc() now correctly uses the unrotated horizontal index struct HI, used to access the contents of the file. Previously, it was using the model HI, which may be rotated. Reading chlorophyll with time_interp_external now uses rotation to correctly fetch its output. NOTE: This could be cleaned up so that the rotation details are hidden from users, but there are some unresolved issues around how to approach this. --- src/core/MOM_forcing_type.F90 | 19 +++++++++++++++---- src/core/MOM_porous_barriers.F90 | 10 ++++++---- src/core/MOM_variables.F90 | 9 ++++++--- src/framework/MOM_io_file.F90 | 8 +++++++- .../vertical/MOM_diabatic_aux.F90 | 8 ++++++-- .../vertical/MOM_set_diffusivity.F90 | 3 ++- .../vertical/MOM_set_viscosity.F90 | 3 ++- 7 files changed, 44 insertions(+), 16 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 98cfdb3f17..452161c6ca 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -6,6 +6,7 @@ module MOM_forcing_type use MOM_array_transform, only : rotate_array, rotate_vector, rotate_array_pair use MOM_coupler_types, only : coupler_2d_bc_type, coupler_type_destructor use MOM_coupler_types, only : coupler_type_increment_data, coupler_type_initialized +use MOM_coupler_types, only : coupler_type_copy_data use MOM_cpu_clock, only : cpu_clock_id, cpu_clock_begin, cpu_clock_end, CLOCK_ROUTINE use MOM_debugging, only : hchksum, uvchksum use MOM_diag_mediator, only : post_data, register_diag_field, register_scalar_field @@ -3702,9 +3703,11 @@ subroutine rotate_forcing(fluxes_in, fluxes, turns) if (associated(fluxes_in%ustar_tidal)) & call rotate_array(fluxes_in%ustar_tidal, turns, fluxes%ustar_tidal) - ! TODO: tracer flux rotation - if (coupler_type_initialized(fluxes%tr_fluxes)) & - call MOM_error(FATAL, "Rotation of tracer BC fluxes not yet implemented.") + ! NOTE: Tracer fields are handled by FMS, so are left unrotated. Any + ! reads/writes to tr_fields must be appropriately rotated. + if (coupler_type_initialized(fluxes%tr_fluxes)) then + call coupler_type_copy_data(fluxes_in%tr_fluxes, fluxes%tr_fluxes) + endif ! Scalars and flags fluxes%accumulate_p_surf = fluxes_in%accumulate_p_surf @@ -3757,10 +3760,18 @@ subroutine rotate_mech_forcing(forces_in, turns, forces) endif if (do_press) then - ! NOTE: p_surf_SSH either points to p_surf or p_surf_full call rotate_array(forces_in%p_surf, turns, forces%p_surf) call rotate_array(forces_in%p_surf_full, turns, forces%p_surf_full) call rotate_array(forces_in%net_mass_src, turns, forces%net_mass_src) + + ! p_surf_SSH points to either p_surf or p_surf_full + if (associated(forces_in%p_surf_SSH, forces_in%p_surf)) then + forces%p_surf_SSH => forces%p_surf + else if (associated(forces_in%p_surf_SSH, forces_in%p_surf_full)) then + forces%p_surf_SSH => forces%p_surf_full + else + forces%p_surf_SSH => null() + endif endif if (do_iceberg) then diff --git a/src/core/MOM_porous_barriers.F90 b/src/core/MOM_porous_barriers.F90 index e212581993..8f872ceb15 100644 --- a/src/core/MOM_porous_barriers.F90 +++ b/src/core/MOM_porous_barriers.F90 @@ -168,9 +168,10 @@ subroutine porous_widths_layer(h, tv, G, GV, US, pbv, CS, eta_bt) if (CS%debug) then call uvchksum("Interface height used by porous barrier for layer weights", & - eta_u, eta_v, G%HI, haloshift=0) + eta_u, eta_v, G%HI, haloshift=0, scalar_pair=.true.) call uvchksum("Porous barrier layer-averaged weights: por_face_area[UV]", & - pbv%por_face_areaU, pbv%por_face_areaV, G%HI, haloshift=0) + pbv%por_face_areaU, pbv%por_face_areaV, G%HI, haloshift=0, & + scalar_pair=.true.) endif if (CS%id_por_face_areaU > 0) call post_data(CS%id_por_face_areaU, pbv%por_face_areaU, CS%diag) @@ -256,9 +257,10 @@ subroutine porous_widths_interface(h, tv, G, GV, US, pbv, CS, eta_bt) if (CS%debug) then call uvchksum("Interface height used by porous barrier for interface weights", & - eta_u, eta_v, G%HI, haloshift=0) + eta_u, eta_v, G%HI, haloshift=0, scalar_pair=.true.) call uvchksum("Porous barrier weights at the layer-interface: por_layer_width[UV]", & - pbv%por_layer_widthU, pbv%por_layer_widthV, G%HI, haloshift=0) + pbv%por_layer_widthU, pbv%por_layer_widthV, G%HI, & + haloshift=0, scalar_pair=.true.) endif if (CS%id_por_layer_widthU > 0) call post_data(CS%id_por_layer_widthU, pbv%por_layer_widthU, CS%diag) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index 0eab1a5b17..cb20837d3b 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -6,6 +6,7 @@ module MOM_variables use MOM_array_transform, only : rotate_array, rotate_vector use MOM_coupler_types, only : coupler_1d_bc_type, coupler_2d_bc_type use MOM_coupler_types, only : coupler_type_spawn, coupler_type_destructor, coupler_type_initialized +use MOM_coupler_types, only : coupler_type_copy_data use MOM_debugging, only : hchksum use MOM_domains, only : MOM_domain_type, get_domain_extent, group_pass_type use MOM_EOS, only : EOS_type @@ -499,9 +500,11 @@ subroutine rotate_surface_state(sfc_state_in, sfc_state, G, turns) sfc_state%T_is_conT = sfc_state_in%T_is_conT sfc_state%S_is_absS = sfc_state_in%S_is_absS - ! TODO: tracer field rotation - if (coupler_type_initialized(sfc_state_in%tr_fields)) & - call MOM_error(FATAL, "Rotation of surface state tracers is not yet implemented.") + ! NOTE: Tracer fields are handled by FMS, so are left unrotated. Any + ! reads/writes to tr_fields must be appropriately rotated. + if (coupler_type_initialized(sfc_state_in%tr_fields)) then + call coupler_type_copy_data(sfc_state_in%tr_fields, sfc_state%tr_fields) + endif end subroutine rotate_surface_state !> Allocates the arrays contained within a BT_cont_type and initializes them to 0. diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index 6eaa10f622..c6d86a008b 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -1326,7 +1326,13 @@ subroutine open_file_nc(handle, filename, action, MOM_domain, threading, fileset if (present(MOM_domain)) then handle%domain_decomposed = .true. - call hor_index_init(MOM_domain, handle%HI) + + ! Input files use unrotated indexing. + if (associated(MOM_domain%domain_in)) then + call hor_index_init(MOM_domain%domain_in, handle%HI) + else + call hor_index_init(MOM_domain, handle%HI) + endif endif call handle%axes%init() diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 6fdfdd5936..1ba5aef392 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -643,7 +643,7 @@ subroutine set_pen_shortwave(optics, fluxes, G, GV, US, CS, opacity, tracer_flow if (CS%chl_from_file) then ! Only the 2-d surface chlorophyll can be read in from a file. The ! same value is assumed for all layers. - call time_interp_external(CS%sbc_chl, CS%Time, chl_2d) + call time_interp_external(CS%sbc_chl, CS%Time, chl_2d, turns=G%HI%turns) do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. (chl_2d(i,j) < 0.0)) then write(mesg,'(" Time_interp negative chl of ",(1pe12.4)," at i,j = ",& @@ -1899,7 +1899,11 @@ subroutine diabatic_aux_init(Time, G, GV, US, param_file, diag, CS, useALEalgori call log_param(param_file, mdl, "INPUTDIR/CHL_FILE", chl_filename) call get_param(param_file, mdl, "CHL_VARNAME", chl_varname, & "Name of CHL_A variable in CHL_FILE.", default='CHL_A') - CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain) + if (modulo(G%Domain%turns, 4) /= 0) then + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain%domain_in) + else + CS%sbc_chl = init_external_field(chl_filename, trim(chl_varname), MOM_domain=G%Domain) + endif endif CS%id_chl = register_diag_field('ocean_model', 'Chl_opac', diag%axesT1, Time, & diff --git a/src/parameterizations/vertical/MOM_set_diffusivity.F90 b/src/parameterizations/vertical/MOM_set_diffusivity.F90 index 3de5ad1162..ef2e4ed5f6 100644 --- a/src/parameterizations/vertical/MOM_set_diffusivity.F90 +++ b/src/parameterizations/vertical/MOM_set_diffusivity.F90 @@ -613,7 +613,8 @@ subroutine set_diffusivity(u, v, h, u_h, v_h, tv, fluxes, optics, visc, dt, Kd_i endif if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) then - call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, symmetric=.true., scale=GV%H_to_m*US%s_to_T) + call uvchksum("Ray_[uv]", visc%Ray_u, visc%Ray_v, G%HI, 0, & + symmetric=.true., scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) endif endif diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index 60298f9226..e601fdf2f7 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1072,7 +1072,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (CS%debug) then if (allocated(visc%Ray_u) .and. allocated(visc%Ray_v)) & - call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, scale=GV%H_to_m*US%s_to_T) + call uvchksum("Ray [uv]", visc%Ray_u, visc%Ray_v, G%HI, haloshift=0, & + scale=GV%H_to_m*US%s_to_T, scalar_pair=.true.) if (allocated(visc%kv_bbl_u) .and. allocated(visc%kv_bbl_v)) & call uvchksum("kv_bbl_[uv]", visc%kv_bbl_u, visc%kv_bbl_v, G%HI, & haloshift=0, scale=GV%HZ_T_to_m2_s, scalar_pair=.true.) From dc248836f0cadf3120ea35210f4d3434beb77f0e Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sun, 10 Mar 2024 17:05:14 -0400 Subject: [PATCH 564/629] Error cleanup (Intel Fortran) This patch clears out many errors detected by Intel Fortran. Most are false positives from stub functions which would normally be replaced in production and report unset output. These variables are now assigned dummy values in order to pacify the compiler. The `stat` function in POSIX was incorrectly passing its `buf` object to the C `stat` function as `intent(in)`, causing the compiler to believe that the contents were unset. Oddly, this was already working correctly, and perhaps warrants further investigation, but it has now been correctly set to `intent(inout)`. The `ppoly_*` variables in `check_reconstruction_1d` appear to have been incorrectly declared as `out`, when they are clearly used as `in` to validate the values. This has been corrected. `register_diag_field` in the ice shelf diag manager was incorrectly declared and the function appeared to return nothing. Perhaps this function was not used for anything. An IO statement in MOM_open_boundary had a syntax error; this has been fixed. `get_dataset` returns a `dataset_type`, so some compilers expect the stub function to also return a valid `dataset`. Since the stub `dataset_type` contains no fields, any locally declared instance should be sufficient as a return value. --- .../GFDL_ocean_BGC/FMS_coupler_util.F90 | 2 ++ .../GFDL_ocean_BGC/generic_tracer_utils.F90 | 29 +++++++++++++++++++ .../database_client_interface.F90 | 19 ++++++++++++ src/ALE/MOM_remapping.F90 | 6 ++-- src/core/MOM_open_boundary.F90 | 2 +- src/framework/MOM_io_file.F90 | 2 ++ src/framework/posix.F90 | 2 +- src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 | 6 ++-- 8 files changed, 60 insertions(+), 8 deletions(-) diff --git a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 index b7ee7de684..5d78e0d501 100644 --- a/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 +++ b/config_src/external/GFDL_ocean_BGC/FMS_coupler_util.F90 @@ -22,6 +22,8 @@ subroutine extract_coupler_values(BC_struc, BC_index, BC_element, array_out, ilb integer, optional, intent(in) :: js !< The j- limits of array_out to be filled integer, optional, intent(in) :: je !< The j- limits of array_out to be filled real, optional, intent(in) :: conversion !< A number that every element is multiplied by + + array_out(:,:) = -1. end subroutine extract_coupler_values !> Set element and index of a boundary condition diff --git a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 index ea9f225a27..fec9c80461 100644 --- a/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 +++ b/config_src/external/GFDL_ocean_BGC/generic_tracer_utils.F90 @@ -143,6 +143,17 @@ subroutine g_tracer_get_common(isc,iec,jsc,jec,isd,ied,jsd,jed,nk,ntau,& integer, optional, dimension(:,:), pointer :: grid_mask_coast !< Unknown integer, optional, dimension(:,:), pointer :: grid_kmt !< Unknown type(g_diag_ctrl), optional, pointer :: diag_CS !< Unknown + + isc = -1 + iec = -1 + jsc = -1 + jec = -1 + isd = -1 + ied = -1 + jsd = -1 + jed = -1 + nk = -1 + ntau = -1 end subroutine g_tracer_get_common !> Unknown @@ -177,6 +188,8 @@ subroutine g_tracer_get_4D_val(g_tracer_list,name,member,array,isd,jsd) integer, intent(in) :: isd !< Unknown integer, intent(in) :: jsd !< Unknown real, dimension(isd:,jsd:,:,:), intent(out):: array !< Unknown + + array(:,:,:,:) = -1. end subroutine g_tracer_get_4D_val !> Unknown @@ -190,6 +203,8 @@ subroutine g_tracer_get_3D_val(g_tracer_list,name,member,array,isd,jsd,ntau,posi logical, optional, intent(in) :: positive !< Unknown real, dimension(isd:,jsd:,:), intent(out):: array !< Unknown character(len=fm_string_len), parameter :: sub_name = 'g_tracer_get_3D_val' + + array(:,:,:) = -1. end subroutine g_tracer_get_3D_val !> Unknown @@ -200,6 +215,8 @@ subroutine g_tracer_get_2D_val(g_tracer_list,name,member,array,isd,jsd) integer, intent(in) :: isd !< Unknown integer, intent(in) :: jsd !< Unknown real, dimension(isd:,jsd:), intent(out):: array !< Unknown + + array(:,:) = -1. end subroutine g_tracer_get_2D_val !> Unknown @@ -208,6 +225,8 @@ subroutine g_tracer_get_real(g_tracer_list,name,member,value) character(len=*), intent(in) :: member !< Unknown type(g_tracer_type), pointer :: g_tracer_list !< Unknown real, intent(out):: value !< Unknown + + value = -1 end subroutine g_tracer_get_real !> Unknown @@ -216,6 +235,8 @@ subroutine g_tracer_get_string(g_tracer_list,name,member,string) character(len=*), intent(in) :: member !< Unknown type(g_tracer_type), pointer :: g_tracer_list !< Unknown character(len=fm_string_len), intent(out) :: string !< Unknown + + string = "" end subroutine g_tracer_get_string !> Unknown @@ -268,18 +289,24 @@ end subroutine g_tracer_send_diag subroutine g_tracer_get_name(g_tracer,string) type(g_tracer_type), pointer :: g_tracer !< Unknown character(len=*), intent(out) :: string !< Unknown + + string = "" end subroutine g_tracer_get_name !> Unknown subroutine g_tracer_get_alias(g_tracer,string) type(g_tracer_type), pointer :: g_tracer !< Unknown character(len=*), intent(out) :: string !< Unknown + + string = "" end subroutine g_tracer_get_alias !> Is the tracer prognostic? function g_tracer_is_prog(g_tracer) logical :: g_tracer_is_prog type(g_tracer_type), pointer :: g_tracer !< Pointer to tracer node + + g_tracer_is_prog = .false. end function g_tracer_is_prog !> get the next tracer in the list @@ -297,6 +324,8 @@ subroutine g_tracer_get_obc_segment_props(g_tracer_list, name, obc_has, src_file real, optional,intent(out):: lfac_out !< OBC reservoir inverse lengthscale factor character(len=*),optional,intent(out):: src_file !< OBC source file character(len=*),optional,intent(out):: src_var_name !< OBC source variable in file + + obc_has = .false. end subroutine g_tracer_get_obc_segment_props !>Vertical Diffusion of a tracer node diff --git a/config_src/external/database_comms/database_client_interface.F90 b/config_src/external/database_comms/database_client_interface.F90 index 9b57628921..8f52df6617 100644 --- a/config_src/external/database_comms/database_client_interface.F90 +++ b/config_src/external/database_comms/database_client_interface.F90 @@ -317,6 +317,7 @@ function unpack_tensor_float_1d(self, name, data, dims) result(code) integer :: code code = -1 + data(:) = -1_real32 end function unpack_tensor_float_1d !> Unpack a 32-bit real 2d tensor from the database @@ -328,6 +329,7 @@ function unpack_tensor_float_2d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:) = -1_real32 end function unpack_tensor_float_2d !> Unpack a 32-bit real 3d tensor from the database @@ -339,6 +341,7 @@ function unpack_tensor_float_3d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:,:) = -1_real32 end function unpack_tensor_float_3d !> Unpack a 32-bit real 4d tensor from the database @@ -350,6 +353,7 @@ function unpack_tensor_float_4d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:,:,:) = -1_real32 end function unpack_tensor_float_4d !> Unpack a 64-bit real 1d tensor from the database @@ -361,6 +365,7 @@ function unpack_tensor_double_1d(self, name, data, dims) result(code) integer :: code code = -1 + data(:) = -1_real64 end function unpack_tensor_double_1d !> Unpack a 64-bit real 2d tensor from the database @@ -372,6 +377,7 @@ function unpack_tensor_double_2d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:) = -1_real64 end function unpack_tensor_double_2d !> Unpack a 64-bit real 3d tensor from the database @@ -383,6 +389,7 @@ function unpack_tensor_double_3d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:,:) = -1_real64 end function unpack_tensor_double_3d !> Unpack a 64-bit real 4d tensor from the database @@ -394,6 +401,7 @@ function unpack_tensor_double_4d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:,:,:) = -1_real64 end function unpack_tensor_double_4d !> Unpack a 32-bit integer 1d tensor from the database @@ -405,6 +413,7 @@ function unpack_tensor_int32_1d(self, name, data, dims) result(code) integer :: code code = -1 + data(:) = -1_int32 end function unpack_tensor_int32_1d !> Unpack a 32-bit integer 2d tensor from the database @@ -416,6 +425,7 @@ function unpack_tensor_int32_2d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:) = -1_int32 end function unpack_tensor_int32_2d !> Unpack a 32-bit integer 3d tensor from the database @@ -427,6 +437,7 @@ function unpack_tensor_int32_3d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:,:) = -1_int32 end function unpack_tensor_int32_3d !> Unpack a 32-bit integer 4d tensor from the database @@ -438,6 +449,7 @@ function unpack_tensor_int32_4d(self, name, data, dims) result(code) integer :: code code = -1 + data(:,:,:,:) = -1_int32 end function unpack_tensor_int32_4d !> Move a tensor to a new name @@ -479,6 +491,7 @@ function get_model(self, name, model) result(code) integer :: code code = -1 + model = "" end function get_model !> Load the machine learning model from a file and set the configuration @@ -621,6 +634,7 @@ function get_script(self, name, script) result(code) integer :: code code = -1 + script = "" end function get_script !> Set a script (from file) in the database for future execution @@ -735,7 +749,12 @@ function get_dataset(self, name, dataset) result(code) type(dataset_type), intent( out) :: dataset !< receives the dataset integer :: code + type(dataset_type) :: dataset_out + ! Placeholder dataset to prevent compiler warnings + ! Since dataset_type contains no data, any declared instance should work. + code = -1 + dataset = dataset_out end function get_dataset !> Rename a dataset stored in the database diff --git a/src/ALE/MOM_remapping.F90 b/src/ALE/MOM_remapping.F90 index eeb4590a08..9c32b76260 100644 --- a/src/ALE/MOM_remapping.F90 +++ b/src/ALE/MOM_remapping.F90 @@ -393,9 +393,9 @@ subroutine check_reconstructions_1d(n0, h0, u0, deg, boundary_extrapolation, & real, dimension(n0), intent(in) :: u0 !< Cell averages on source grid [A] integer, intent(in) :: deg !< Degree of polynomial reconstruction logical, intent(in) :: boundary_extrapolation !< Extrapolate at boundaries if true - real, dimension(n0,deg+1),intent(out) :: ppoly_r_coefs !< Coefficients of polynomial [A] - real, dimension(n0,2), intent(out) :: ppoly_r_E !< Edge value of polynomial [A] - real, dimension(n0,2), intent(out) :: ppoly_r_S !< Edge slope of polynomial [A H-1] + real, dimension(n0,deg+1),intent(in) :: ppoly_r_coefs !< Coefficients of polynomial [A] + real, dimension(n0,2), intent(in) :: ppoly_r_E !< Edge value of polynomial [A] + real, dimension(n0,2), intent(in) :: ppoly_r_S !< Edge slope of polynomial [A H-1] ! Local variables integer :: i0, n real :: u_l, u_c, u_r ! Cell averages [A] diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 7bfb6479b2..b54c93cefa 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -854,7 +854,7 @@ subroutine initialize_segment_data(G, GV, US, OBC, PF) ! if (siz(4) == 1) segment%values_needed = .false. if (segment%on_pe) then if (OBC%brushcutter_mode .and. (modulo(siz(1),2) == 0 .or. modulo(siz(2),2) == 0)) then - write(mesg,'("Brushcutter mode sizes ", I6, I6))') siz(1), siz(2) + write(mesg,'("Brushcutter mode sizes ", I6, I6)') siz(1), siz(2) call MOM_error(WARNING, mesg // " " // trim(filename) // " " // trim(fieldname)) call MOM_error(FATAL,'segment data are not on the supergrid') endif diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index 6eaa10f622..b4e6fde800 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -1702,6 +1702,8 @@ subroutine read_field_chksum_nc(handle, field, chksum, valid_chksum) !< If true, chksum has been successfully read call MOM_error(FATAL, 'read_field_chksum over netCDF is not yet implemented.') + chksum = -1_int64 + valid_chksum = .false. end subroutine read_field_chksum_nc diff --git a/src/framework/posix.F90 b/src/framework/posix.F90 index fffb619cba..1087958939 100644 --- a/src/framework/posix.F90 +++ b/src/framework/posix.F90 @@ -84,7 +84,7 @@ function stat_posix(path, buf) result(rc) bind(c, name="stat") character(kind=c_char), dimension(*), intent(in) :: path !< Pathname of a POSIX file - type(stat_buf), intent(in) :: buf + type(stat_buf), intent(inout) :: buf !< Information describing the file if it exists integer(kind=c_int) :: rc !< Function return code diff --git a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 index dabb075cf3..42fa63fd95 100644 --- a/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 +++ b/src/ice_shelf/MOM_ice_shelf_diag_mediator.F90 @@ -514,9 +514,9 @@ function register_MOM_IS_diag_field(module_name, field_name, axes, init_time, & end function register_MOM_IS_diag_field !> Registers a static diagnostic, returning an integer handle -integer function register_MOM_IS_static_field(module_name, field_name, axes, & - long_name, units, missing_value, range, mask_variant, standard_name, & - do_not_log, interp_method, tile_count) +function register_MOM_IS_static_field(module_name, field_name, axes, & + long_name, units, missing_value, range, mask_variant, standard_name, & + do_not_log, interp_method, tile_count) result(register_static_field) integer :: register_static_field !< The returned diagnostic handle character(len=*), intent(in) :: module_name !< Name of this module, usually "ice_model" character(len=*), intent(in) :: field_name !< Name of the diagnostic field From de59adf02748b001a1b06860c5bd050f3cfb2f39 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 20 Mar 2024 09:29:38 -0400 Subject: [PATCH 565/629] Make the US argument to MOM_domains_init optional This commit makes the unit_scale_type argument US to MOM_domains_init and gen_auto_mask_table optional and moves it to the end of the argument list, so that coupled or ice-ocean models using SIS2 will compile with the proposed updates to the main branch of MOM6 from dev/ncar. Because MOM6 and SIS2 use some common framework code but are managed in separate github repositories, we need to use optional argument to allow a single version of SIS2 to work across changes to MOM6 interfaces. Because the TOPO_CONFIG parameter as used in SIS2 has a default value, there is an alternative call to get_param for TOPO_CONFIG with a default when MOM_domains_init is called with a domain_name argument. Also added missing scale arguments to get_param calls for MINIMUM_DEPTH and MASKING_DEPTH. This commit also adds or corrects units in the comments describing 4 recently added or modified variables. All answers are bitwise identical in any cases that worked before (noting that some cases using SIS2 would not even compile). --- src/core/MOM.F90 | 12 ++--- src/framework/MOM_domains.F90 | 54 ++++++++++++------- src/ice_shelf/MOM_ice_shelf.F90 | 4 +- src/ocean_data_assim/MOM_oda_driver.F90 | 2 +- .../lateral/MOM_hor_visc.F90 | 2 +- 5 files changed, 45 insertions(+), 29 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index b7f8bd3f66..a9c8c5cd9e 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2538,13 +2538,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & #endif G_in => CS%G_in #ifdef STATIC_MEMORY_ - call MOM_domains_init(G_in%domain, US, param_file, symmetric=symmetric, & - static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & - NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & - NJPROC=NJPROC_) + call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + static_memory=.true., NIHALO=NIHALO_, NJHALO=NJHALO_, & + NIGLOBAL=NIGLOBAL_, NJGLOBAL=NJGLOBAL_, NIPROC=NIPROC_, & + NJPROC=NJPROC_, US=US) #else - call MOM_domains_init(G_in%domain, US, param_file, symmetric=symmetric, & - domain_name="MOM_in") + call MOM_domains_init(G_in%domain, param_file, symmetric=symmetric, & + domain_name="MOM_in", US=US) #endif ! Copy input grid (G_in) domain to active grid G diff --git a/src/framework/MOM_domains.F90 b/src/framework/MOM_domains.F90 index f2c3225025..d937ed7b0c 100644 --- a/src/framework/MOM_domains.F90 +++ b/src/framework/MOM_domains.F90 @@ -63,12 +63,11 @@ module MOM_domains !> MOM_domains_init initializes a MOM_domain_type variable, based on the information !! read in from a param_file_type, and optionally returns data describing various !! properties of the domain type. -subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & +subroutine MOM_domains_init(MOM_dom, param_file, symmetric, static_memory, & NIHALO, NJHALO, NIGLOBAL, NJGLOBAL, NIPROC, NJPROC, & - min_halo, domain_name, include_name, param_suffix) + min_halo, domain_name, include_name, param_suffix, US) type(MOM_domain_type), pointer :: MOM_dom !< A pointer to the MOM_domain_type !! being defined here. - type(unit_scale_type), pointer :: US !< A dimensional unit scaling type type(param_file_type), intent(in) :: param_file !< A structure to parse for !! run-time parameters logical, optional, intent(in) :: symmetric !< If present, this specifies @@ -99,6 +98,7 @@ subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & !! "MOM_memory.h" if missing. character(len=*), optional, intent(in) :: param_suffix !< A suffix to apply to !! layout-specific parameters. + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type ! Local variables integer, dimension(2) :: layout ! The number of logical processors in the i- and j- directions @@ -120,6 +120,7 @@ subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & logical :: auto_mask_table ! Runtime flag that turns on automatic mask table generator integer :: auto_io_layout_fac ! Used to compute IO layout when auto_mask_table is True. logical :: mask_table_exists ! True if there is a mask table file + logical :: is_MOM_domain ! True if this domain is being set for MOM, and not another component like SIS2. character(len=128) :: inputdir ! The directory in which to find the diag table character(len=200) :: mask_table ! The file name and later the full path to the diag table character(len=64) :: inc_nm ! The name of the memory include file @@ -288,7 +289,16 @@ subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & call get_param(param_file, mdl, "INPUTDIR", inputdir, do_not_log=.true., default=".") inputdir = slasher(inputdir) - call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, do_not_log=.true., fail_if_missing=.true.) + is_MOM_domain = .true. + if (present(domain_name)) then + is_MOM_domain = (index(domain_name, "MOM") > 1) + endif + + if (is_MOM_domain) then + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, do_not_log=.true., fail_if_missing=.true.) + else ! SIS2 has a default value for TOPO_CONFIG. + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, default="file", do_not_log=.true.) + endif auto_mask_table = .false. if (.not. present(param_suffix) .and. .not. is_static .and. trim(topo_config) == 'file') then @@ -314,7 +324,7 @@ subroutine MOM_domains_init(MOM_dom, US, param_file, symmetric, static_memory, & call cpu_clock_begin(id_clock_auto_mask) if (is_root_PE()) then call gen_auto_mask_table(n_global, reentrant, tripolar_N, PEs_used, param_file, inputdir, & - auto_mask_table_fname, US, auto_layout) + auto_mask_table_fname, auto_layout, US) endif call broadcast(auto_layout, length=2) call cpu_clock_end(id_clock_auto_mask) @@ -462,17 +472,18 @@ subroutine MOM_define_layout(n_global, ndivs, layout) end subroutine MOM_define_layout !> Given a desired number of active npes, generate a layout and mask_table -subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file, inputdir, filename, US, layout) +subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file, inputdir, filename, layout, US) integer, dimension(2), intent(in) :: n_global !< The total number of gridpoints in 2 directions logical, dimension(2), intent(in) :: reentrant !< True if the x- and y- directions are periodic. - logical :: tripolar_N !< A flag indicating whether there is n. tripolar connectivity + logical, intent(in) :: tripolar_N !< A flag indicating whether there is n. tripolar connectivity integer, intent(in) :: npes !< The desired number of active PEs. type(param_file_type), intent(in) :: param_file !< A structure to parse for run-time parameters - character(len=128), intent(in) :: inputdir !< INPUTDIR parameter + character(len=128), intent(in) :: inputdir !< INPUTDIR parameter character(len=:), allocatable, intent(in) :: filename !< Mask table file path (to be auto-generated.) - type(unit_scale_type), pointer :: US !< A dimensional unit scaling type integer, dimension(2), intent(out) :: layout !< The generated layout of PEs (incl. masked blocks) - !local + type(unit_scale_type), optional, pointer :: US !< A dimensional unit scaling type + + ! Local variables real, dimension(n_global(1), n_global(2)) :: D ! Bathymetric depth (to be read in from TOPO_FILE) [Z ~> m] integer, dimension(:,:), allocatable :: mask ! Cell masks (based on D and MINIMUM_DEPTH) character(len=200) :: topo_filepath, topo_file ! Strings for file/path @@ -483,18 +494,23 @@ subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file real :: Dmask ! The depth for masking in the same units as D [Z ~> m] real :: min_depth ! The minimum ocean depth in the same units as D [Z ~> m] real :: mask_depth ! The depth shallower than which to mask a point as land. [Z ~> m] - real :: glob_ocn_frac ! ratio of ocean points to total number of points - real :: r_p ! aspect ratio for division count p. + real :: glob_ocn_frac ! ratio of ocean points to total number of points [nondim] + real :: r_p ! aspect ratio for division count p. [nondim] + real :: m_to_Z ! A conversion factor from m to height units [Z m-1 ~> 1] integer :: nx, ny ! global domain sizes integer, parameter :: ibuf=2, jbuf=2 - real, parameter :: r_extreme = 4.0 ! aspect ratio limit (>1) for a layout to be considered. + real, parameter :: r_extreme = 4.0 ! aspect ratio limit (>1) for a layout to be considered [nondim] integer :: num_masked_blocks integer, allocatable :: mask_table(:,:) + m_to_Z = 1.0 ; if (present(US)) m_to_Z = US%m_to_Z + ! Read in params necessary for auto-masking - call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, do_not_log=.true., units="m", default=0.0) - call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, do_not_log=.true., units="m", default=-9999.0) - call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, do_not_log=.true., fail_if_missing=.true.) + call get_param(param_file, mdl, "MINIMUM_DEPTH", min_depth, & + units="m", default=0.0, scale=m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "MASKING_DEPTH", mask_depth, & + units="m", default=-9999.0, scale=m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "TOPO_CONFIG", topo_config, default="file", do_not_log=.true.) call get_param(param_file, mdl, "TOPO_FILE", topo_file, do_not_log=.true., default="topog.nc") call get_param(param_file, mdl, "TOPO_VARNAME", topo_varname, do_not_log=.true., default="depth") topo_filepath = trim(inputdir)//trim(topo_file) @@ -514,15 +530,15 @@ subroutine gen_auto_mask_table(n_global, reentrant, tripolar_N, npes, param_file ny = n_global(2) ! Read in bathymetric depth. - D(:,:) = -9.0e30 * US%m_to_Z ! Initializing to a very large negative depth (tall mountains) everywhere. + D(:,:) = -9.0e30 * m_to_Z ! Initializing to a very large negative depth (tall mountains) everywhere. call read_field(topo_filepath, trim(topo_varname), D, start=(/1, 1/), nread=n_global, no_domain=.true., & - scale=US%m_to_Z) + scale=m_to_Z) allocate(mask(nx+2*ibuf, ny+2*jbuf), source=0) ! Determine cell masks Dmask = mask_depth - if (mask_depth == -9999.0) Dmask = min_depth + if (mask_depth == -9999.0*m_to_Z) Dmask = min_depth do i=1,nx ; do j=1,ny if (D(i,j) <= Dmask) then mask(i+ibuf,j+jbuf) = 0 diff --git a/src/ice_shelf/MOM_ice_shelf.F90 b/src/ice_shelf/MOM_ice_shelf.F90 index eab178280c..b9640502d2 100644 --- a/src/ice_shelf/MOM_ice_shelf.F90 +++ b/src/ice_shelf/MOM_ice_shelf.F90 @@ -1322,8 +1322,8 @@ subroutine initialize_ice_shelf(param_file, ocn_grid, Time, CS, diag, Time_init, ! Set up the ice-shelf domain and grid wd_halos(:)=0 allocate(CS%Grid) - call MOM_domains_init(CS%Grid%domain, CS%US, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& - domain_name='MOM_Ice_Shelf_in') + call MOM_domains_init(CS%Grid%domain, param_file, min_halo=wd_halos, symmetric=GRID_SYM_,& + domain_name='MOM_Ice_Shelf_in', US=CS%US) !allocate(CS%Grid_in%HI) !call hor_index_init(CS%Grid%Domain, CS%Grid%HI, param_file, & ! local_indexing=.not.global_indexing) diff --git a/src/ocean_data_assim/MOM_oda_driver.F90 b/src/ocean_data_assim/MOM_oda_driver.F90 index f45939d007..6e24b9faee 100644 --- a/src/ocean_data_assim/MOM_oda_driver.F90 +++ b/src/ocean_data_assim/MOM_oda_driver.F90 @@ -291,7 +291,7 @@ subroutine init_oda(Time, G, GV, US, diag_CS, CS) CS%G => G allocate(CS%Grid) ! params NIHALO_ODA, NJHALO_ODA set the DA halo size - call MOM_domains_init(CS%Grid%Domain,CS%US,PF,param_suffix='_ODA') + call MOM_domains_init(CS%Grid%Domain, PF, param_suffix='_ODA', US=CS%US) allocate(HI) call hor_index_init(CS%Grid%Domain, HI, PF) call verticalGridInit( PF, CS%GV, CS%US ) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 9b1d81348e..1b73a7ec12 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -300,7 +300,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, GME_effic_h, & ! The filtered efficiency of the GME terms at h points [nondim] m_leithy, & ! Kh=m_leithy*Ah in Leith+E parameterization [L-2 ~> m-2] Ah_sq, & ! The square of the biharmonic viscosity [L8 T-2 ~> m8 s-2] - htot ! The total thickness of all layers [Z ~> m] + htot ! The total thickness of all layers [H ~> m or kg m-2] real :: Del2vort_h ! Laplacian of vorticity at h-points [L-2 T-1 ~> m-2 s-1] real :: grad_vel_mag_bt_h ! Magnitude of the barotropic velocity gradient tensor squared at h-points [T-2 ~> s-2] real :: boundary_mask_h ! A mask that zeroes out cells with at least one land edge [nondim] From 32f631623eccfc88a4d3dd0c97001dc5eeef4cc2 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 29 Feb 2024 17:09:31 -0500 Subject: [PATCH 566/629] +Rotationally symmetric neutral diffusion option Added the option to do neutral tracer diffusion with expressions that satisfy rotational symmetry. This option is enabled by setting the new runtime parameter NDIFF_ANSWER_DATE to be greater than 20240330. By default, this parameter is set to use the previous expressions, although the default may be changed later to follow DEFAULT_ANSWER_DATE. By default all answers are bitwise identical, but there are changes to some MOM_parameter_doc files due to the introduction of a new runtime parameter. --- src/tracer/MOM_neutral_diffusion.F90 | 110 ++++++++++++++++++++------- 1 file changed, 84 insertions(+), 26 deletions(-) diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 87a8881b10..b64c665c87 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -119,6 +119,10 @@ module MOM_neutral_diffusion !! for remapping. Values below 20190101 recover the remapping !! answers from 2018, while higher values use more robust !! forms of the same remapping expressions. + integer :: ndiff_answer_date !< The vintage of the order of arithmetic to use for the neutral + !! diffusion. Values of 20240330 or below recover the answers + !! from the original form of this code, while higher values use + !! mathematically equivalent expressions that recover rotational symmetry. type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to get BLD type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL()!< ePBL control structure needed to get MLD end type neutral_diffusion_CS @@ -200,6 +204,16 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "transports that were unmasked, as used prior to Jan 2018. This is not "//& "recommended.", default=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231) + call get_param(param_file, mdl, "NDIFF_ANSWER_DATE", CS%ndiff_answer_date, & + "The vintage of the order of arithmetic to use for the neutral diffusion. "//& + "Values of 20240330 or below recover the answers from the original form of the "//& + "neutral diffusion code, while higher values use mathematically equivalent "//& + "expressions that recover rotational symmetry.", & + default=20240101) !### Change this default later to default_answer_date. + ! Initialize and configure remapping if ( .not.CS%continuous_reconstruction ) then call get_param(param_file, mdl, "NDIFF_BOUNDARY_EXTRAP", boundary_extrap, & @@ -211,9 +225,6 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, "for vertical remapping for all variables. "//& "It can be one of the following schemes: "//& trim(remappingSchemesDoc), default=remappingDefaultScheme) - call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & - "This sets the default value for the various _ANSWER_DATE parameters.", & - default=99991231) call get_param(param_file, mdl, "REMAPPING_ANSWER_DATE", CS%remap_answer_date, & "The vintage of the expressions and order of arithmetic to use for remapping. "//& "Values below 20190101 result in the use of older, less accurate expressions "//& @@ -623,6 +634,18 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) real, dimension(SZK_(GV)) :: dTracer ! Change in tracer concentration due to neutral diffusion ! [H L2 conc ~> m3 conc or kg conc]. For temperature ! these units are [C H L2 ~> degC m3 or degC kg]. + real, dimension(SZK_(GV)) :: dTracer_N ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically northern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_S ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically southern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_E ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically eastern face, in + ! [H L2 conc ~> m3 conc or kg conc]. + real, dimension(SZK_(GV)) :: dTracer_W ! Change in tracer concentration due to neutral diffusion + ! into a cell via its logically western face, in + ! [H L2 conc ~> m3 conc or kg conc]. real :: normalize ! normalization used for averaging Coef_x and Coef_y to t-points [nondim]. type(tracer_type), pointer :: Tracer => NULL() ! Pointer to the current tracer @@ -800,21 +823,39 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) endif endif - ! Update the tracer concentration from divergence of neutral diffusive flux components + ! Update the tracer concentration from divergence of neutral diffusive flux components, noting + ! that uFlx and vFlx use an unexpected sign convention. if (CS%KhTh_use_ebt_struct) then do j = G%jsc,G%jec ; do i = G%isc,G%iec if (G%mask2dT(i,j)>0.) then - dTracer(:) = 0. - do ks = 1,CS%nsurf-1 - k = CS%uKoL(I,j,ks) - dTracer(k) = dTracer(k) + uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dTracer(k) = dTracer(k) - uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dTracer(k) = dTracer(k) + vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dTracer(k) = dTracer(k) - vFlx(i,J-1,ks) - enddo + if (CS%ndiff_answer_date <= 20240330) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - vFlx(i,J-1,ks) + enddo + else ! This form recovers rotational symmetry. + dTracer_N(:) = 0.0 ; dTracer_S(:) = 0.0 ; dTracer_E(:) = 0.0 ; dTracer_W(:) = 0.0 + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer_E(k) = dTracer_E(k) + uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer_W(k) = dTracer_W(k) - uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer_N(k) = dTracer_N(k) + vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer_S(k) = dTracer_S(k) - vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + dTracer(k) = (dTracer_N(k) + dTracer_S(k)) + (dTracer_E(k) + dTracer_W(k)) + enddo + endif do k = 1, GV%ke tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) @@ -832,17 +873,34 @@ subroutine neutral_diffusion(G, GV, h, Coef_x, Coef_y, dt, Reg, US, CS) else do j = G%jsc,G%jec ; do i = G%isc,G%iec if (G%mask2dT(i,j)>0.) then - dTracer(:) = 0. - do ks = 1,CS%nsurf-1 - k = CS%uKoL(I,j,ks) - dTracer(k) = dTracer(k) + Coef_x(I,j,1) * uFlx(I,j,ks) - k = CS%uKoR(I-1,j,ks) - dTracer(k) = dTracer(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) - k = CS%vKoL(i,J,ks) - dTracer(k) = dTracer(k) + Coef_y(i,J,1) * vFlx(i,J,ks) - k = CS%vKoR(i,J-1,ks) - dTracer(k) = dTracer(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) - enddo + if (CS%ndiff_answer_date <= 20240330) then + dTracer(:) = 0. + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer(k) = dTracer(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer(k) = dTracer(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer(k) = dTracer(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer(k) = dTracer(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo + else ! This form recovers rotational symmetry. + dTracer_N(:) = 0.0 ; dTracer_S(:) = 0.0 ; dTracer_E(:) = 0.0 ; dTracer_W(:) = 0.0 + do ks = 1,CS%nsurf-1 + k = CS%uKoL(I,j,ks) + dTracer_E(k) = dTracer_E(k) + Coef_x(I,j,1) * uFlx(I,j,ks) + k = CS%uKoR(I-1,j,ks) + dTracer_W(k) = dTracer_W(k) - Coef_x(I-1,j,1) * uFlx(I-1,j,ks) + k = CS%vKoL(i,J,ks) + dTracer_N(k) = dTracer_N(k) + Coef_y(i,J,1) * vFlx(i,J,ks) + k = CS%vKoR(i,J-1,ks) + dTracer_S(k) = dTracer_S(k) - Coef_y(i,J-1,1) * vFlx(i,J-1,ks) + enddo + do k = 1, GV%ke + dTracer(k) = (dTracer_N(k) + dTracer_S(k)) + (dTracer_E(k) + dTracer_W(k)) + enddo + endif do k = 1, GV%ke tracer%t(i,j,k) = tracer%t(i,j,k) + dTracer(k) * & ( G%IareaT(i,j) / ( h(i,j,k) + GV%H_subroundoff ) ) From 812510bc4906426ed2f0a2d11cac1629e24369f0 Mon Sep 17 00:00:00 2001 From: He Wang Date: Mon, 4 Mar 2024 00:01:57 -0500 Subject: [PATCH 567/629] Add an option in hor_visc to use cont thickness Runtime parameter USE_CONT_THICKNESS is added in hor_visc to let it use velocity-point thickness consistent with the continuity solver. Thicknesses are borrowed from BT_cont so only split mode is supported. --- src/core/MOM_dynamics_split_RK2.F90 | 5 ++-- .../lateral/MOM_hor_visc.F90 | 24 +++++++++++++++++-- 2 files changed, 25 insertions(+), 4 deletions(-) diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 11b1eb5c16..0557ec7cd5 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -851,7 +851,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & MEKE, Varmix, G, GV, US, CS%hor_visc, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & - ADp=CS%ADp) + ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2)") @@ -1518,7 +1518,8 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp) + OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call set_initialized(CS%diffu, "diffu", restart_CS) call set_initialized(CS%diffv, "diffv", restart_CS) endif diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index e3249afb73..96b8bd2a9e 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -111,7 +111,7 @@ module MOM_hor_visc !! limit the grid Reynolds number [L2 T-1 ~> m2 s-1] real :: min_grid_Ah !< Minimun horizontal biharmonic viscosity used to !! limit grid Reynolds number [L4 T-1 ~> m4 s-1] - + logical :: use_cont_thick !< If true, thickness at velocity points adopts h[uv] in BT_cont from continuity solver. type(ZB2020_CS) :: ZB2020 !< Zanna-Bolton 2020 control structure. logical :: use_ZB2020 !< If true, use Zanna-Bolton 2020 parameterization. @@ -239,7 +239,7 @@ module MOM_hor_visc !! v[is-2:ie+2,js-2:je+2] !! h[is-1:ie+1,js-1:je+1] subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT, TD, ADp) + CS, OBC, BT, TD, ADp, hu_cont, hv_cont) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & @@ -263,6 +263,10 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & + optional, intent(in) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & + optional, intent(in) :: hv_cont !< Layer thickness at v-points [H ~> m or kg m-2]. ! Local variables real, dimension(SZIB_(G),SZJ_(G)) :: & @@ -391,6 +395,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, logical :: apply_OBC = .false. logical :: use_MEKE_Ku logical :: use_MEKE_Au + logical :: use_cont_huv integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz integer :: i, j, k, n real :: inv_PI3, inv_PI2, inv_PI6 ! Powers of the inverse of pi [nondim] @@ -445,6 +450,8 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, use_MEKE_Ku = allocated(MEKE%Ku) use_MEKE_Au = allocated(MEKE%Au) + use_cont_huv = CS%use_cont_thick .and. present(hu_cont) .and. present(hv_cont) + rescale_Kh = .false. if (VarMix%use_variable_mixing) then rescale_Kh = VarMix%Resoln_scaled_Kh @@ -658,6 +665,16 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, enddo ; enddo endif + ! The following should obviously be combined with the previous block if adopted. + if (use_cont_huv) then + do j=js-2,je+2 ; do I=Isq-1,Ieq+1 + h_u(I,j) = hu_cont(I,j,k) + enddo ; enddo + do J=Jsq-1,Jeq+1 ; do i=is-2,ie+2 + h_v(i,J) = hv_cont(i,J,k) + enddo ; enddo + endif + ! Adjust contributions to shearing strain and interpolated values of ! thicknesses on open boundaries. if (apply_OBC) then ; do n=1,OBC%number_of_segments @@ -1969,6 +1986,9 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call get_param(param_file, mdl, "DEBUG", CS%debug, default=.false.) + call get_param(param_file, mdl, "USE_CONT_THICKNESS", CS%use_cont_thick, & + "If true, use thickness at velocity points from continuity solver. This option"//& + "currently only works with split mode.", default=.false.) call get_param(param_file, mdl, "LAPLACIAN", CS%Laplacian, & "If true, use a Laplacian horizontal viscosity.", & default=.false.) From 37ff301a65817e7212cd7743c66fb406fc2b9223 Mon Sep 17 00:00:00 2001 From: He Wang Date: Mon, 4 Mar 2024 08:44:52 -0500 Subject: [PATCH 568/629] fix opemmp parallel --- src/parameterizations/lateral/MOM_hor_visc.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index 96b8bd2a9e..6f707f9e87 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -561,12 +561,12 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & !$OMP is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, & + !$OMP use_MEKE_Ku, use_MEKE_Au, use_cont_huv, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & !$OMP div_xx_h, sh_xx_h, vort_xy_q, sh_xy_q, GME_coeff_h, GME_coeff_q, & - !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt & + !$OMP KH_u_GME, KH_v_GME, grid_Re_Kh, grid_Re_Ah, NoSt, ShSt, hu_cont, hv_cont & !$OMP ) & !$OMP private( & !$OMP i, j, k, n, & From 2b59089ea5561b14cb55c092ec78b1c0e1864a2c Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Mar 2024 05:52:47 -0500 Subject: [PATCH 569/629] Set up auxiliary domain for unrotated grid When ROTATE_INDEX is true, the model keeps both its rotated internal grid and an unrotated grid for setting initialization and forcing. When the model is run in symmetric memory mode, there is an auxiliary non-symmetric domain that is needed for reading in fields at velocity points. The auxiliary domain in the unrotated grid (G_in) was not being set previously, causing the model to fail to run some cases when ROTATE_INDEX was true. That auxiliary domain in the unrotated grid is now being set up properly. All answers and output are bitwise identical for any cases that worked previously. --- src/core/MOM.F90 | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 094e534312..595b730e0f 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -2904,6 +2904,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (CS%rotate_index) then G_in%ke = GV%ke + ! Allocate the auxiliary non-symmetric domain for debugging or I/O purposes. + if (CS%debug .or. G_in%symmetric) then + call clone_MOM_domain(G_in%Domain, G_in%Domain_aux, symmetric=.false.) + else ; G_in%Domain_aux => G_in%Domain ; endif + allocate(u_in(G_in%IsdB:G_in%IedB, G_in%jsd:G_in%jed, nz), source=0.0) allocate(v_in(G_in%isd:G_in%ied, G_in%JsdB:G_in%JedB, nz), source=0.0) allocate(h_in(G_in%isd:G_in%ied, G_in%jsd:G_in%jed, nz), source=GV%Angstrom_H) From 5e34f486b0b50d4f7bdbf752456b355824d6e885 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 6 Mar 2024 15:31:51 -0500 Subject: [PATCH 570/629] Set flags properly for rotated tripolar grids Added code to tht two versions of clone_MD_to_MD in the FMS1 and FMS2 versions of MOM_domain_infra.F90 to properly change the flags when a tripolar grid is rotated, so that it does not lead to misleadingly incorrect answers. With the current versions of FMS, doing grid rotation testing with a tripolar grid will lead to error messages about the incomplete implementation of FMS, but these failures are preferable to the model silently working incorrectly. All answers are bitwise identical in cases that worked correctly before. --- config_src/infra/FMS1/MOM_domain_infra.F90 | 26 ++++++++++++++++++++-- config_src/infra/FMS2/MOM_domain_infra.F90 | 26 ++++++++++++++++++++-- 2 files changed, 48 insertions(+), 4 deletions(-) diff --git a/config_src/infra/FMS1/MOM_domain_infra.F90 b/config_src/infra/FMS1/MOM_domain_infra.F90 index 2c97a0bb31..8040be27d9 100644 --- a/config_src/infra/FMS1/MOM_domain_infra.F90 +++ b/config_src/infra/FMS1/MOM_domain_infra.F90 @@ -19,7 +19,8 @@ module MOM_domain_infra use mpp_domains_mod, only : mpp_compute_block_extent use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN +use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE 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 @@ -1553,6 +1554,19 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain call get_layout_extents(MD_in, exnj, exni) MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (qturns == 1) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + elseif (qturns == 3) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(2:1:-1) MOM_dom%io_layout(:) = io_layout_in(2:1:-1) else @@ -1561,11 +1575,19 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain call get_layout_extents(MD_in, exni, exnj) MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (qturns == 2) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(:) MOM_dom%io_layout(:) = io_layout_in(:) endif - ! Ensure that the points per processor are the same on the source and densitation grids. + ! Ensure that the points per processor are the same on the source and destination grids. select case (qturns) case (1) ; call invert(exni) case (2) ; call invert(exni) ; call invert(exnj) diff --git a/config_src/infra/FMS2/MOM_domain_infra.F90 b/config_src/infra/FMS2/MOM_domain_infra.F90 index ff1d888c47..76d9469e3c 100644 --- a/config_src/infra/FMS2/MOM_domain_infra.F90 +++ b/config_src/infra/FMS2/MOM_domain_infra.F90 @@ -19,7 +19,8 @@ module MOM_domain_infra use mpp_domains_mod, only : mpp_compute_block_extent use mpp_domains_mod, only : mpp_broadcast_domain, mpp_redistribute, mpp_global_field use mpp_domains_mod, only : AGRID, BGRID_NE, CGRID_NE, SCALAR_PAIR, BITWISE_EXACT_SUM -use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN, FOLD_NORTH_EDGE +use mpp_domains_mod, only : CYCLIC_GLOBAL_DOMAIN +use mpp_domains_mod, only : FOLD_NORTH_EDGE, FOLD_SOUTH_EDGE, FOLD_EAST_EDGE, FOLD_WEST_EDGE 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 @@ -1555,6 +1556,19 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain call get_layout_extents(MD_in, exnj, exni) MOM_dom%X_FLAGS = MD_in%Y_FLAGS ; MOM_dom%Y_FLAGS = MD_in%X_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (modulo(qturns, 4) == 1) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + elseif (modulo(qturns, 4) == 3) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(2:1:-1) MOM_dom%io_layout(:) = io_layout_in(2:1:-1) else @@ -1563,11 +1577,19 @@ subroutine clone_MD_to_MD(MD_in, MOM_dom, min_halo, halo_size, symmetric, domain call get_layout_extents(MD_in, exni, exnj) MOM_dom%X_FLAGS = MD_in%X_FLAGS ; MOM_dom%Y_FLAGS = MD_in%Y_FLAGS + ! Correct the position of a tripolar grid, assuming that flags are not additive. + if (modulo(qturns, 4) == 2) then + if (MD_in%Y_FLAGS == FOLD_NORTH_EDGE) MOM_dom%Y_FLAGS = FOLD_SOUTH_EDGE + if (MD_in%Y_FLAGS == FOLD_SOUTH_EDGE) MOM_dom%Y_FLAGS = FOLD_NORTH_EDGE + if (MD_in%X_FLAGS == FOLD_EAST_EDGE) MOM_dom%X_FLAGS = FOLD_WEST_EDGE + if (MD_in%X_FLAGS == FOLD_WEST_EDGE) MOM_dom%X_FLAGS = FOLD_EAST_EDGE + endif + MOM_dom%layout(:) = MD_in%layout(:) MOM_dom%io_layout(:) = io_layout_in(:) endif - ! Ensure that the points per processor are the same on the source and densitation grids. + ! Ensure that the points per processor are the same on the source and destination grids. select case (qturns) case (1) ; call invert(exni) case (2) ; call invert(exni) ; call invert(exnj) From f9372f3d66392df199ae7541c62a99f467971285 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 10 Mar 2024 22:46:41 -0400 Subject: [PATCH 571/629] +Add get_netcdf_filename for a get_field_nc error Add get_netcdf_filename and use it to add useful details (the field and filenames in question) to a fatal error message in get_field_nc. All answers are bitwise identical, but there is a new public interface and some output is changed in cases where get_field_nc is failing. --- src/framework/MOM_io_file.F90 | 6 ++++-- src/framework/MOM_netcdf.F90 | 9 +++++++++ 2 files changed, 13 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_io_file.F90 b/src/framework/MOM_io_file.F90 index c6d86a008b..6697e56f68 100644 --- a/src/framework/MOM_io_file.F90 +++ b/src/framework/MOM_io_file.F90 @@ -34,6 +34,7 @@ module MOM_io_file use MOM_netcdf, only : write_netcdf_attribute use MOM_netcdf, only : get_netcdf_size use MOM_netcdf, only : get_netcdf_fields +use MOM_netcdf, only : get_netcdf_filename use MOM_netcdf, only : read_netcdf_field use MOM_error_handler, only : MOM_error, FATAL @@ -1757,8 +1758,9 @@ subroutine get_field_nc(handle, label, values, rescale) ! NOTE: Data on face and vertex points is not yet supported. This is a ! temporary check to detect such cases, but may be removed in the future. if (.not. (compute_domain .or. data_domain)) & - call MOM_error(FATAL, 'get_field_nc: Only compute and data domains ' // & - 'are currently supported.') + call MOM_error(FATAL, 'get_field_nc trying to read '//trim(label)//' from '//& + trim(get_netcdf_filename(handle%handle_nc))//& + ': Only compute and data domains are currently supported.') field_nc = handle%fields%get(label) diff --git a/src/framework/MOM_netcdf.F90 b/src/framework/MOM_netcdf.F90 index 95e6aa7bb7..8d6534e5dd 100644 --- a/src/framework/MOM_netcdf.F90 +++ b/src/framework/MOM_netcdf.F90 @@ -39,6 +39,7 @@ module MOM_netcdf public :: write_netcdf_attribute public :: get_netcdf_size public :: get_netcdf_fields +public :: get_netcdf_filename public :: read_netcdf_field @@ -722,6 +723,14 @@ subroutine get_netcdf_fields(handle, axes, fields) fields(:) = vars(:nfields) end subroutine get_netcdf_fields +!> Return the name of a file from a netCDF handle +function get_netcdf_filename(handle) + type(netcdf_file_type), intent(in) :: handle !< A netCDF file handle + character(len=:), allocatable :: get_netcdf_filename !< The name of the file that this handle refers to. + + get_netcdf_filename = handle%filename + +end function !> Read the values of a field from a netCDF file subroutine read_netcdf_field(handle, field, values, bounds) From a3fd1f3a7466e886b45af116ae93db6111e4c644 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 18 Mar 2024 13:15:08 -0400 Subject: [PATCH 572/629] +Rotationally symmetric epipycnal diffusion option Added the option to do epipycnal tracer diffusion between a bulk mixed layer and the interior ocean with expressions that satisfy rotational symmetry. This option is enabled by setting the new runtime parameter HOR_DIFF_ANSWER_DATE to be greater than 20240330. By default, this parameter is set to use the previous expressions, although the default may be changed later to follow DEFAULT_ANSWER_DATE. Also corrected two bugs with the tracer limits used to repartition the fluxes between layers within tracer_epipycnal_ML_diff; this correction is enables by setting the new HOR_DIFF_LIMIT_BUG to .false., but to retain previous answers by default it is set to true. By default all answers are bitwise identical, but there are changes to some MOM_parameter_doc files due to the introduction of two new runtime parameters. --- src/tracer/MOM_tracer_hor_diff.F90 | 217 ++++++++++++++++++++--------- 1 file changed, 149 insertions(+), 68 deletions(-) diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 6f4e5d0f90..732a42e44b 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -65,6 +65,14 @@ module MOM_tracer_hor_diff !! tracer_hor_diff. logical :: recalc_neutral_surf !< If true, recalculate the neutral surfaces if CFL has been !! exceeded + logical :: limit_bug !< If true and the answer date is 20240330 or below, use a + !! rotational symmetry breaking bug when limiting the tracer + !! properties in tracer_epipycnal_ML_diff. + integer :: answer_date !< The vintage of the order of arithmetic to use for the tracer + !! diffusion. Values of 20240330 or below recover the answers + !! from the original form of this code, while higher values use + !! mathematically equivalent expressions that recover rotational symmetry + !! when DIFFUSE_ML_TO_INTERIOR is true. type(neutral_diffusion_CS), pointer :: neutral_diffusion_CSp => NULL() !< Control structure for neutral diffusion. type(hbd_CS), pointer :: hor_bnd_diffusion_CSp => NULL() !< Control structure for !! horizontal boundary diffusion. @@ -678,7 +686,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & real, dimension(SZI_(G),SZJB_(G)), intent(in) :: khdt_epi_y !< Meridional epipycnal diffusivity times !! a time step and the ratio of the open face width over !! the distance between adjacent tracer points [L2 ~> m2] - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_hor_diff_CS), intent(inout) :: CS !< module control structure type(thermo_var_ptrs), intent(in) :: tv !< thermodynamic structure integer, intent(in) :: num_itts !< number of iterations (usually=1) @@ -706,13 +714,16 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & k0b_Lv, k0a_Lv, & ! The original k-indices of the layers that participate k0b_Rv, k0a_Rv ! in each pair of mixing at v-faces. - !### Accumulating the converge into this array one face at a time may lead to a lack of rotational symmetry. - real, dimension(SZI_(G), SZJ_(G), SZK_(GV)) :: & - tr_flux_conv ! The flux convergence of tracers [conc H L2 ~> conc m3 or conc kg] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & + tr_flux_N, & ! The tracer flux through the northern face [conc H L2 ~> conc m3 or conc kg] + tr_flux_S, & ! The tracer flux through the southern face [conc H L2 ~> conc m3 or conc kg] + tr_flux_E, & ! The tracer flux through the eastern face [conc H L2 ~> conc m3 or conc kg] + tr_flux_W, & ! The tracer flux through the western face [conc H L2 ~> conc m3 or conc kg] + tr_flux_conv ! The flux convergence of tracers [conc H L2 ~> conc m3 or conc kg] ! The following 3-d arrays were created in 2014 in MOM6 PR#12 to facilitate openMP threading - ! on an i-loop, which might have been ill advised. The k-size extents here might also be problematic. - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: & + ! on an i-loop, which might have been ill advised. + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)*2) :: & Tr_flux_3d, & ! The tracer flux through pairings at meridional faces [conc H L2 ~> conc m3 or conc kg] Tr_adj_vert_L, & ! Vertical adjustments to which layer the fluxes go into in the southern ! columns at meridional face [conc H L2 ~> conc m3 or conc kg] @@ -815,6 +826,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & do k=2,nkmb ; do j=js-2,je+2 ; do i=is-2,ie+2 if (Rml_max(i,j) < rho_coord(i,j,k)) Rml_max(i,j) = rho_coord(i,j,k) enddo ; enddo ; enddo + ! Use bracketing and bisection to find the k-level that the densest of the ! mixed and buffer layer corresponds to, such that: ! GV%Rlay(max_kRho-1) < Rml_max <= GV%Rlay(max_kRho) @@ -1191,12 +1203,7 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif ; enddo ; enddo ! i- & j- loops over meridional faces. -! The tracer-specific calculations start here. - - ! Zero out tracer tendencies. - do k=1,PEmax_kRho ; do j=js-1,je+1 ; do i=is-1,ie+1 - tr_flux_conv(i,j,k) = 0.0 - enddo ; enddo ; enddo + ! The tracer-specific calculations start here. do itt=1,max_itt @@ -1205,12 +1212,19 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif do m=1,ntr -!$OMP parallel do default(none) shared(is,ie,js,je,G,Tr,nkmb,nPu,m,max_kRho,nz,h,h_exclude, & -!$OMP k0b_Lu,k0b_Ru,deep_wt_Lu,k0a_Lu,deep_wt_Ru,k0a_Ru, & -!$OMP hP_Lu,hP_Ru,I_maxitt,khdt_epi_x,tr_flux_conv,Idt) & -!$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & -!$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & -!$OMP Tr_flux,Tr_adj_vert,wt_a,vol) + ! Zero out tracer tendencies. + if (CS%answer_date <= 20240330) then + tr_flux_conv(:,:,:) = 0.0 + else + tr_flux_N(:,:,:) = 0.0 ; tr_flux_S(:,:,:) = 0.0 + tr_flux_E(:,:,:) = 0.0 ; tr_flux_W(:,:,:) = 0.0 + endif + tr_flux_3d(:,:,:) = 0.0 + tr_adj_vert_R(:,:,:) = 0.0 ; tr_adj_vert_L(:,:,:) = 0.0 + + !$OMP parallel do default(shared) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb,Tr_La, & + !$OMP Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R,h_L,h_R, & + !$OMP Tr_flux,Tr_adj_vert,wt_a,vol) do j=js,je ; do I=is-1,ie ; if (G%mask2dCu(I,j) > 0.0) then ! Determine the fluxes through the zonal faces. @@ -1230,7 +1244,11 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & kRb = kRa ; if (max_kRho(i+1,j) < nz) kRb = max_kRho(i+1,j)+1 Tr_La = Tr_min_face ; Tr_Lb = Tr_La ; Tr_Ra = Tr_La ; Tr_Rb = Tr_La if (h(i,j,kLa) > h_exclude) Tr_La = Tr(m)%t(i,j,kLa) - if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + if ((CS%answer_date <= 20240330) .and. CS%limit_bug) then + if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + else + if (h(i,j,kLb) > h_exclude) Tr_Lb = Tr(m)%t(i,j,kLb) + endif if (h(i+1,j,kRa) > h_exclude) Tr_Ra = Tr(m)%t(i+1,j,kRa) if (h(i+1,j,kRb) > h_exclude) Tr_Rb = Tr(m)%t(i+1,j,kRb) Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) @@ -1264,12 +1282,20 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif h_L = hP_Lu(j)%p(I,k) ; h_R = hP_Ru(j)%p(I,k) - Tr_flux = I_maxitt * khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) * & - ((2.0 * h_L * h_R) / (h_L + h_R)) - + if (CS%answer_date <= 20240330) then + Tr_flux = I_maxitt * khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) * & + ((2.0 * h_L * h_R) / (h_L + h_R)) + else + Tr_flux = I_maxitt * ((2.0 * h_L * h_R) / (h_L + h_R)) * & + khdt_epi_x(I,j) * (Tr_av_L - Tr_av_R) + endif if (deep_wt_Lu(j)%p(I,k) >= 1.0) then - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux + if (CS%answer_date <= 20240330) then + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux + else + tr_flux_E(i,j,kLb) = tr_flux_E(i,j,kLb) + Tr_flux + endif else Tr_adj_vert = 0.0 wt_b = deep_wt_Lu(j)%p(I,k) ; wt_a = 1.0 - wt_b @@ -1299,12 +1325,21 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif endif - tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux + Tr_adj_vert) - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux - Tr_adj_vert) + if (CS%answer_date <= 20240330) then + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux + Tr_adj_vert) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux - Tr_adj_vert) + else + tr_flux_E(i,j,kLa) = tr_flux_E(i,j,kLa) + (wt_a*Tr_flux + Tr_adj_vert) + tr_flux_E(i,j,kLb) = tr_flux_E(i,j,kLb) + (wt_b*Tr_flux - Tr_adj_vert) + endif endif if (deep_wt_Ru(j)%p(I,k) >= 1.0) then - tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + Tr_flux + if (CS%answer_date <= 20240330) then + tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + Tr_flux + else + tr_flux_W(i+1,j,kRb) = tr_flux_W(i+1,j,kRb) + Tr_flux + endif else Tr_adj_vert = 0.0 wt_b = deep_wt_Ru(j)%p(I,k) ; wt_a = 1.0 - wt_b @@ -1334,23 +1369,22 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & endif endif - tr_flux_conv(i+1,j,kRa) = tr_flux_conv(i+1,j,kRa) + & - (wt_a*Tr_flux - Tr_adj_vert) - tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + & - (wt_b*Tr_flux + Tr_adj_vert) + if (CS%answer_date <= 20240330) then + tr_flux_conv(i+1,j,kRa) = tr_flux_conv(i+1,j,kRa) + (wt_a*Tr_flux - Tr_adj_vert) + tr_flux_conv(i+1,j,kRb) = tr_flux_conv(i+1,j,kRb) + (wt_b*Tr_flux + Tr_adj_vert) + else + tr_flux_W(i+1,j,kRa) = tr_flux_W(i+1,j,kRa) + (wt_a*Tr_flux - Tr_adj_vert) + tr_flux_W(i+1,j,kRb) = tr_flux_W(i+1,j,kRb) + (wt_b*Tr_flux + Tr_adj_vert) + endif endif if (associated(Tr(m)%df2d_x)) & Tr(m)%df2d_x(I,j) = Tr(m)%df2d_x(I,j) + Tr_flux * Idt enddo ! Loop over pairings at faces. endif ; enddo ; enddo ! i- & j- loops over zonal faces. -!$OMP parallel do default(none) shared(is,ie,js,je,G,Tr,nkmb,nPv,m,max_kRho,nz,h,h_exclude, & -!$OMP k0b_Lv,k0b_Rv,deep_wt_Lv,k0a_Lv,deep_wt_Rv,k0a_Rv, & -!$OMP hP_Lv,hP_Rv,I_maxitt,khdt_epi_y,Tr_flux_3d, & -!$OMP Tr_adj_vert_L,Tr_adj_vert_R,Idt) & -!$OMP private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & -!$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & -!$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) + !$OMP parallel do default(shared) private(Tr_min_face,Tr_max_face,kLa,kLb,kRa,kRb, & + !$OMP Tr_La,Tr_Lb,Tr_Ra,Tr_Rb,Tr_av_L,wt_b,Tr_av_R, & + !$OMP h_L,h_R,Tr_flux,Tr_adj_vert,wt_a,vol) do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! Determine the fluxes through the meridional faces. @@ -1370,7 +1404,11 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & kRb = kRa ; if (max_kRho(i,j+1) < nz) kRb = max_kRho(i,j+1)+1 Tr_La = Tr_min_face ; Tr_Lb = Tr_La ; Tr_Ra = Tr_La ; Tr_Rb = Tr_La if (h(i,j,kLa) > h_exclude) Tr_La = Tr(m)%t(i,j,kLa) - if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + if ((CS%answer_date <= 20240330) .and. CS%limit_bug) then + if (h(i,j,kLb) > h_exclude) Tr_La = Tr(m)%t(i,j,kLb) + else + if (h(i,j,kLb) > h_exclude) Tr_Lb = Tr(m)%t(i,j,kLb) + endif if (h(i,j+1,kRa) > h_exclude) Tr_Ra = Tr(m)%t(i,j+1,kRa) if (h(i,j+1,kRb) > h_exclude) Tr_Rb = Tr(m)%t(i,j+1,kRb) Tr_min_face = min(Tr_min_face, Tr_La, Tr_Lb, Tr_Ra, Tr_Rb) @@ -1464,42 +1502,69 @@ subroutine tracer_epipycnal_ML_diff(h, dt, Tr, ntr, khdt_epi_x, khdt_epi_y, G, & Tr(m)%df2d_y(i,J) = Tr(m)%df2d_y(i,J) + Tr_flux * Idt enddo ! Loop over pairings at faces. endif ; enddo ; enddo ! i- & j- loops over meridional faces. -!$OMP parallel do default(none) shared(is,ie,js,je,G,nPv,k0b_Lv,k0b_Rv,deep_wt_Lv, & -!$OMP tr_flux_conv,Tr_flux_3d,k0a_Lv,Tr_adj_vert_L,& -!$OMP deep_wt_Rv,k0a_Rv,Tr_adj_vert_R) & -!$OMP private(kLa,kLb,kRa,kRb,wt_b,wt_a) - do i=is,ie ; do J=js-1,je ; if (G%mask2dCv(i,J) > 0.0) then + + !$OMP parallel do default(shared) private(kLa,kLb,kRa,kRb,wt_b,wt_a) + do J=js-1,je ; do i=is,ie ; if (G%mask2dCv(i,J) > 0.0) then ! The non-stride-1 loop order here is to facilitate openMP threading. However, it might be ! suboptimal when openMP threading is not used, at which point it might be better to fuse - ! these loope with those that precede it and thereby eliminate the need for three 3-d arrays. - do k=1,nPv(i,J) - kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) - if (deep_wt_Lv(J)%p(i,k) >= 1.0) then - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k) - else - kLa = k0a_Lv(J)%p(i,k) - wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b - tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) - tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) - endif - if (deep_wt_Rv(J)%p(i,k) >= 1.0) then - tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k) - else - kRa = k0a_Rv(J)%p(i,k) - wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b - tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + & - (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) - tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + & - (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) - endif - enddo + ! this loop with those that precede it and thereby eliminate the need for three 3-d arrays. + if (CS%answer_date <= 20240330) then + do k=1,nPv(i,J) + kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) + if (deep_wt_Lv(J)%p(i,k) >= 1.0) then + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - Tr_flux_3d(i,J,k) + else + kLa = k0a_Lv(J)%p(i,k) + wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_conv(i,j,kLa) = tr_flux_conv(i,j,kLa) - (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) + tr_flux_conv(i,j,kLb) = tr_flux_conv(i,j,kLb) - (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) + endif + if (deep_wt_Rv(J)%p(i,k) >= 1.0) then + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + Tr_flux_3d(i,J,k) + else + kRa = k0a_Rv(J)%p(i,k) + wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_conv(i,j+1,kRa) = tr_flux_conv(i,j+1,kRa) + & + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) + tr_flux_conv(i,j+1,kRb) = tr_flux_conv(i,j+1,kRb) + & + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) + endif + enddo + else + do k=1,nPv(i,J) + kLb = k0b_Lv(J)%p(i,k); kRb = k0b_Rv(J)%p(i,k) + if (deep_wt_Lv(J)%p(i,k) >= 1.0) then + tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + Tr_flux_3d(i,J,k) + else + kLa = k0a_Lv(J)%p(i,k) + wt_b = deep_wt_Lv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_N(i,j,kLa) = tr_flux_N(i,j,kLa) + (wt_a*Tr_flux_3d(i,J,k) + Tr_adj_vert_L(i,J,k)) + tr_flux_N(i,j,kLb) = tr_flux_N(i,j,kLb) + (wt_b*Tr_flux_3d(i,J,k) - Tr_adj_vert_L(i,J,k)) + endif + if (deep_wt_Rv(J)%p(i,k) >= 1.0) then + tr_flux_S(i,j+1,kRb) = tr_flux_S(i,j+1,kRb) + Tr_flux_3d(i,J,k) + else + kRa = k0a_Rv(J)%p(i,k) + wt_b = deep_wt_Rv(J)%p(i,k) ; wt_a = 1.0 - wt_b + tr_flux_S(i,j+1,kRa) = tr_flux_S(i,j+1,kRa) + (wt_a*Tr_flux_3d(i,J,k) - Tr_adj_vert_R(i,J,k)) + tr_flux_S(i,j+1,kRb) = tr_flux_S(i,j+1,kRb) + (wt_b*Tr_flux_3d(i,J,k) + Tr_adj_vert_R(i,J,k)) + endif + enddo + endif endif ; enddo ; enddo + + if (CS%answer_date >= 20240331) then + !$OMP parallel do default(shared) + do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie + tr_flux_conv(i,j,k) = ((tr_flux_W(i,j,k) - tr_flux_E(i,j,k)) + & + (tr_flux_S(i,j,k) - tr_flux_N(i,j,k))) + enddo ; enddo ; enddo + endif + !$OMP parallel do default(shared) do k=1,PEmax_kRho ; do j=js,je ; do i=is,ie if ((G%mask2dT(i,j) > 0.0) .and. (h(i,j,k) > 0.0)) then - Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / & - (h(i,j,k)*G%areaT(i,j)) - tr_flux_conv(i,j,k) = 0.0 + Tr(m)%t(i,j,k) = Tr(m)%t(i,j,k) + tr_flux_conv(i,j,k) / (h(i,j,k)*G%areaT(i,j)) endif enddo ; enddo ; enddo @@ -1546,6 +1611,7 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic ! This include declares and sets the variable "version". # include "version_variable.h" character(len=40) :: mdl = "MOM_tracer_hor_diff" ! This module's name. + integer :: default_answer_date if (associated(CS)) then call MOM_error(WARNING, "tracer_hor_diff_init called with associated control structure.") @@ -1604,6 +1670,21 @@ subroutine tracer_hor_diff_init(Time, G, GV, US, param_file, diag, EOS, diabatic "If true, then recalculate the neutral surfaces if the \n"//& "diffusive CFL is exceeded. If false, assume that the \n"//& "positions of the surfaces do not change \n", default=.false.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "HOR_DIFF_ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic to use for the tracer diffusion. "//& + "Values of 20240330 or below recover the answers from the original form of the "//& + "along-isopycnal mixed layer to interior mixing code, while higher values use "//& + "mathematically equivalent expressions that recover rotational symmetry "//& + "when DIFFUSE_ML_TO_INTERIOR is true.", & + default=20240101, do_not_log=.not.CS%Diffuse_ML_interior) + !### Change the default later to default_answer_date. + call get_param(param_file, mdl, "HOR_DIFF_LIMIT_BUG", CS%limit_bug, & + "If true and the answer date is 20240330 or below, use a rotational symmetry "//& + "breaking bug when limiting the tracer properties in tracer_epipycnal_ML_diff.", & + default=.true., do_not_log=((.not.CS%Diffuse_ML_interior).or.(CS%answer_date>=20240331))) CS%ML_KhTR_scale = 1.0 if (CS%Diffuse_ML_interior) then call get_param(param_file, mdl, "ML_KHTR_SCALE", CS%ML_KhTR_scale, & From 2d121dcc4275bb579ea275815fa79f92cbc6141e Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Jan 2024 09:00:16 -0500 Subject: [PATCH 573/629] (*)Pass dz to user initialize_ALE_sponge calls Pass vertical extents (dz in [Z ~> m]) instead of thicknesses (h in [H ~> m or kg m-2] and use data_h_is_Z flag in calls to initialize_ALE_sponge calls from 5 user modules and avoid extra calls to dz_to_thickness in these routines. All Boussinesq solutions are bitwise identical, but in any non-Boussinesq configurations using ALE sponges, the previous conversion from dz to thickness and back again can change dz in the last bits, so some non-Boussinesq answers could change. --- src/initialization/MOM_state_initialization.F90 | 10 ---------- src/user/DOME2d_initialization.F90 | 12 +----------- src/user/ISOMIP_initialization.F90 | 11 +---------- src/user/RGC_initialization.F90 | 8 ++++---- src/user/dense_water_initialization.F90 | 11 +---------- src/user/dumbbell_initialization.F90 | 11 +---------- 6 files changed, 8 insertions(+), 55 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 0bd155e8e4..4f11233c93 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -1915,7 +1915,6 @@ 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 @@ -2102,7 +2101,6 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t 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)) @@ -2110,13 +2108,6 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t 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, dz, nz_data, Idamp_u, Idamp_v, & data_h_is_Z=.true.) @@ -2132,7 +2123,6 @@ subroutine initialize_sponges_file(G, GV, US, use_temperature, tv, u, v, depth_t deallocate(tmp_S) deallocate(tmp_T) endif - deallocate(h) deallocate(dz) if (sponge_uv) then diff --git a/src/user/DOME2d_initialization.F90 b/src/user/DOME2d_initialization.F90 index c1ec83257d..3903290212 100644 --- a/src/user/DOME2d_initialization.F90 +++ b/src/user/DOME2d_initialization.F90 @@ -9,7 +9,6 @@ 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 @@ -375,7 +374,6 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A 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 :: 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] @@ -466,7 +464,6 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A endif enddo ; enddo - if (use_ALE) then ! Construct a grid (somewhat arbitrarily) to describe the sponge T/S on @@ -502,15 +499,8 @@ subroutine DOME2d_initialize_sponges(G, GV, US, tv, depth_tot, param_file, use_A 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) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, dz, nz, data_h_is_Z=.true.) 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') diff --git a/src/user/ISOMIP_initialization.F90 b/src/user/ISOMIP_initialization.F90 index 3f28da4d5e..d03a07e313 100644 --- a/src/user/ISOMIP_initialization.F90 +++ b/src/user/ISOMIP_initialization.F90 @@ -10,7 +10,6 @@ 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 @@ -458,7 +457,6 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, 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 :: 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] @@ -624,13 +622,6 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, 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 @@ -640,7 +631,7 @@ subroutine ISOMIP_initialize_sponges(G, GV, US, tv, depth_tot, PF, use_ALE, CSp, !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) + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, dz, nz, data_h_is_Z=.true.) ! Now register all of the fields which are damped in the sponge. ! ! By default, momentum is advected vertically within the sponge, but ! diff --git a/src/user/RGC_initialization.F90 b/src/user/RGC_initialization.F90 index 1cf4835efa..6102c2a5ef 100644 --- a/src/user/RGC_initialization.F90 +++ b/src/user/RGC_initialization.F90 @@ -63,7 +63,7 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C real :: U1(SZIB_(G),SZJ_(G),SZK_(GV)) ! A temporary array for u [L T-1 ~> m s-1] real :: V1(SZI_(G),SZJB_(G),SZK_(GV)) ! A temporary array for v [L T-1 ~> m s-1] real :: tmp(SZI_(G),SZJ_(G)) ! A temporary array for tracers. - real :: h(SZI_(G),SZJ_(G),SZK_(GV)) ! A temporary array for thickness at h points [H ~> m or kg m-2] + real :: dz(SZI_(G),SZJ_(G),SZK_(GV)) ! Sponge layer thicknesses in height units [Z ~> m] real :: Idamp(SZI_(G),SZJ_(G)) ! The sponge damping rate at h points [T-1 ~> s-1] real :: TNUDG ! Nudging time scale [T ~> s] real :: pres(SZI_(G)) ! An array of the reference pressure [R L2 T-2 ~> Pa] @@ -153,10 +153,10 @@ subroutine RGC_initialize_sponges(G, GV, US, tv, u, v, depth_tot, PF, use_ALE, C call MOM_read_data(filename, salt_var, S(:,:,:), G%Domain, scale=US%ppt_to_S) if (use_ALE) then - call MOM_read_data(filename, h_var, h(:,:,:), G%Domain, scale=GV%m_to_H) - call pass_var(h, G%domain) + call MOM_read_data(filename, h_var, dz(:,:,:), G%Domain, scale=US%m_to_Z) + call pass_var(dz, G%domain) - call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, h, nz) + call initialize_ALE_sponge(Idamp, G, GV, PF, ACSp, dz, nz, data_h_is_Z=.true.) ! The remaining calls to set_up_sponge_field can be in any order. if ( associated(tv%T) ) call set_up_ALE_sponge_field(T, G, GV, tv%T, ACSp, 'temp', & diff --git a/src/user/dense_water_initialization.F90 b/src/user/dense_water_initialization.F90 index 2daf03ccb1..fbff153e23 100644 --- a/src/user/dense_water_initialization.F90 +++ b/src/user/dense_water_initialization.F90 @@ -9,7 +9,6 @@ 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 @@ -174,7 +173,6 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] 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] @@ -293,15 +291,8 @@ subroutine dense_water_initialize_sponges(G, GV, US, tv, depth_tot, param_file, 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) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, dz, nz, data_h_is_Z=.true.) 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') diff --git a/src/user/dumbbell_initialization.F90 b/src/user/dumbbell_initialization.F90 index 3d968d85d0..0ae9f35e78 100644 --- a/src/user/dumbbell_initialization.F90 +++ b/src/user/dumbbell_initialization.F90 @@ -9,7 +9,6 @@ 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_interface_heights, only : thickness_to_dz use MOM_sponge, only : set_up_sponge_field, initialize_sponge, sponge_CS use MOM_tracer_registry, only : tracer_registry_type @@ -352,7 +351,6 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil real, dimension(SZI_(G),SZJ_(G)) :: Idamp ! inverse damping timescale [T-1 ~> s-1] 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 @@ -460,15 +458,8 @@ subroutine dumbbell_initialize_sponges(G, GV, US, tv, h_in, depth_tot, param_fil endif 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) + call initialize_ALE_sponge(Idamp, G, GV, param_file, ACSp, dz, nz, data_h_is_Z=.true.) 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') From c86358b747c4894719b454637cc21406d57849a6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 20 Jan 2024 06:26:23 -0500 Subject: [PATCH 574/629] (*)Avoiding using RHO_0 in non-Boussinesq debugging When in non-Boussinesq mode, write out mass-based tracer inventories from calls to MOM_tracer_chkinv and mean thicknesses in mass per unit area from calls to MOM_state_stats, rather than the approximate volumes that depend on the Boussinesq reference density. Similarly the thicknesses and transports output by write_u_accel and write_v_accel are in mass per unit area or mass flux per unit face length in non-Boussinesq mode. This is done specifically by using GV%H_to_MKS in place of GV%H_to_m; these are identical in Boussinesq mode, but GV%H_to_MKS avoids rescaling by the Boussinesq reference density in non-Boussinesq mode. Several comments were also updated to reflect these changes. All solutions are identical, but there are changes in the units of several diagnostic output fields that the model can write out when debugging non-Boussinesq mode runs. --- src/core/MOM_checksum_packages.F90 | 13 +++++++------ src/diagnostics/MOM_PointAccel.F90 | 18 ++++++++++-------- src/tracer/MOM_tracer_registry.F90 | 20 ++++++++++++-------- 3 files changed, 29 insertions(+), 22 deletions(-) diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index 4a9df04c4d..dc60e0888f 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -268,10 +268,11 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe ! Local variables real, dimension(G%isc:G%iec, G%jsc:G%jec) :: & tmp_A, & ! The area per cell [m2] (unscaled to permit reproducing sum). - tmp_V, & ! The column-integrated volume [m3] (unscaled to permit reproducing sum) - tmp_T, & ! The column-integrated temperature [degC m3] (unscaled to permit reproducing sum) - tmp_S ! The column-integrated salinity [ppt m3] (unscaled to permit reproducing sum) - real :: Vol, dV ! The total ocean volume and its change [m3] (unscaled to permit reproducing sum). + tmp_V, & ! The column-integrated volume [m3] or mass [kg] (unscaled to permit reproducing sum), + ! depending on whether the Boussinesq approximation is used + tmp_T, & ! The column-integrated temperature [degC m3] or [degC kg] (unscaled to permit reproducing sum) + tmp_S ! The column-integrated salinity [ppt m3] or [ppt kg] (unscaled to permit reproducing sum) + real :: Vol, dV ! The total ocean volume or mass and its change [m3] or [kg] (unscaled to permit reproducing sum). real :: Area ! The total ocean surface area [m2] (unscaled to permit reproducing sum). real :: h_minimum ! The minimum layer thicknesses [H ~> m or kg m-2] real :: T_scale ! The scaling conversion factor for temperatures [degC C-1 ~> 1] @@ -284,7 +285,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe ! assumption we will not turn this on with threads type(stats), save :: oldT, oldS logical, save :: firstCall = .true. - real, save :: oldVol ! The previous total ocean volume [m3] + real, save :: oldVol ! The previous total ocean volume [m3] or mass [kg] character(len=80) :: lMsg integer :: is, ie, js, je, nz, i, j, k @@ -308,7 +309,7 @@ subroutine MOM_state_stats(mesg, u, v, h, Temp, Salt, G, GV, US, allowChange, pe h_minimum = 1.E34*GV%m_to_H do k=1,nz ; do j=js,je ; do i=is,ie if (G%mask2dT(i,j)>0.) then - dV = US%L_to_m**2*G%areaT(i,j)*GV%H_to_m*h(i,j,k) + dV = US%L_to_m**2*G%areaT(i,j)*GV%H_to_MKS*h(i,j,k) tmp_V(i,j) = tmp_V(i,j) + dV if (do_TS .and. h(i,j,k)>0.) then T%minimum = min( T%minimum, T_scale*Temp(i,j,k) ) ; T%maximum = max( T%maximum, T_scale*Temp(i,j,k) ) diff --git a/src/diagnostics/MOM_PointAccel.F90 b/src/diagnostics/MOM_PointAccel.F90 index e9c1092ed7..ab3c104d0f 100644 --- a/src/diagnostics/MOM_PointAccel.F90 +++ b/src/diagnostics/MOM_PointAccel.F90 @@ -95,9 +95,10 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real :: du ! A velocity change [L T-1 ~> m s-1] real :: Inorm(SZK_(GV)) ! The inverse of the normalized velocity change [L T-1 ~> m s-1] real :: e(SZK_(GV)+1) ! Simple estimates of interface heights based on the sum of thicknesses [m] - real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1 or m3 kg-1] + real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] real :: vel_scale ! A scaling factor for velocities [m T s-1 L-1 ~> 1] - real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1 or m3 kg-1] + real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1] + ! or [kg T m-1 s-1 L-1 H-1 ~> 1] real :: temp_scale ! A scaling factor for temperatures [degC C-1 ~> 1] real :: saln_scale ! A scaling factor for salinities [ppt S-1 ~> 1] integer :: yr, mo, day, hr, minute, sec, yearday @@ -108,7 +109,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st integer :: file Angstrom = GV%Angstrom_H + GV%H_subroundoff - h_scale = GV%H_to_m ; vel_scale = US%L_T_to_m_s ; uh_scale = GV%H_to_m*US%L_T_to_m_s + h_scale = GV%H_to_mks ; vel_scale = US%L_T_to_m_s ; uh_scale = h_scale*vel_scale temp_scale = US%C_to_degC ; saln_scale = US%S_to_ppt ! if (.not.associated(CS)) return @@ -232,7 +233,7 @@ subroutine write_u_accel(I, j, um, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(I,j,k) ; enddo endif if (present(str)) then - write(file,'(/,"Stress: ",ES10.3)', advance='no') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) + write(file,'(/,"Stress: ",ES10.3)', advance='no') (uh_scale*GV%RZ_to_H) * (str*dt) endif if (associated(CS%u_accel_bt)) then @@ -435,9 +436,10 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st real :: dv ! A velocity change [L T-1 ~> m s-1] real :: Inorm(SZK_(GV)) ! The inverse of the normalized velocity change [L T-1 ~> m s-1] real :: e(SZK_(GV)+1) ! Simple estimates of interface heights based on the sum of thicknesses [m] - real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1 or m3 kg-1] + real :: h_scale ! A scaling factor for thicknesses [m H-1 ~> 1] or [kg m-2 H-1 ~> 1] real :: vel_scale ! A scaling factor for velocities [m T s-1 L-1 ~> 1] - real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1 or m3 kg-1] + real :: uh_scale ! A scaling factor for transport per unit length [m2 T s-1 L-1 H-1 ~> 1] + ! or [kg T m-1 s-1 L-1 H-1 ~> 1] real :: temp_scale ! A scaling factor for temperatures [degC C-1 ~> 1] real :: saln_scale ! A scaling factor for salinities [ppt S-1 ~> 1] integer :: yr, mo, day, hr, minute, sec, yearday @@ -448,7 +450,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st integer :: file Angstrom = GV%Angstrom_H + GV%H_subroundoff - h_scale = GV%H_to_m ; vel_scale = US%L_T_to_m_s ; uh_scale = GV%H_to_m*US%L_T_to_m_s + h_scale = GV%H_to_mks ; vel_scale = US%L_T_to_m_s ; uh_scale = h_scale*vel_scale temp_scale = US%C_to_degC ; saln_scale = US%S_to_ppt ! if (.not.associated(CS)) return @@ -576,7 +578,7 @@ subroutine write_v_accel(i, J, vm, hin, ADp, CDp, dt, G, GV, US, CS, vel_rpt, st do k=ks,ke ; if (do_k(k)) write(file,'(ES10.3," ")', advance='no') h_scale*hv(i,J,k) ; enddo endif if (present(str)) then - write(file,'(/,"Stress: ",ES10.3)', advance='no') vel_scale*US%Z_to_m * (str*dt / GV%Rho0) + write(file,'(/,"Stress: ",ES10.3)', advance='no') (uh_scale*GV%RZ_to_H) * (str*dt) endif if (associated(CS%v_accel_bt)) then diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index c01419f3f8..8f7f2a280c 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -786,14 +786,16 @@ subroutine tracer_array_chkinv(mesg, G, GV, h, Tr, ntr) integer, intent(in) :: ntr !< number of registered tracers ! Local variables - real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1 or m3 kg-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] - real :: total_inv ! The total amount of tracer [conc m3] + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1] or cell + ! masses to kg [kg H-1 L-2 ~> 1], depending on whether the Boussinesq approximation is used + real :: tr_inv(SZI_(G),SZJ_(G),SZK_(GV)) ! Volumetric or mass-based tracer inventory in + ! each cell [conc m3] or [conc kg] + real :: total_inv ! The total amount of tracer [conc m3] or [conc kg] integer :: is, ie, js, je, nz integer :: i, j, k, m is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - vol_scale = GV%H_to_m*G%US%L_to_m**2 + vol_scale = GV%H_to_MKS*G%US%L_to_m**2 do m=1,ntr do k=1,nz ; do j=js,je ; do i=is,ie tr_inv(i,j,k) = Tr(m)%conc_scale*Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) @@ -814,16 +816,18 @@ subroutine tracer_Reg_chkinv(mesg, G, GV, h, Reg) real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2] ! Local variables - real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1 or m3 kg-1] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: tr_inv ! Volumetric tracer inventory in each cell [conc m3] - real :: total_inv ! The total amount of tracer [conc m3] + real :: vol_scale ! The dimensional scaling factor to convert volumes to m3 [m3 H-1 L-2 ~> 1] or cell + ! masses to kg [kg H-1 L-2 ~> 1], depending on whether the Boussinesq approximation is used + real :: tr_inv(SZI_(G),SZJ_(G),SZK_(GV)) ! Volumetric or mass-based tracer inventory in + ! each cell [conc m3] or [conc kg] + real :: total_inv ! The total amount of tracer [conc m3] or [conc kg] integer :: is, ie, js, je, nz integer :: i, j, k, m if (.not.associated(Reg)) return is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - vol_scale = GV%H_to_m*G%US%L_to_m**2 + vol_scale = GV%H_to_MKS*G%US%L_to_m**2 do m=1,Reg%ntr do k=1,nz ; do j=js,je ; do i=is,ie tr_inv(i,j,k) = Reg%Tr(m)%conc_scale*Reg%Tr(m)%t(i,j,k) * (vol_scale * h(i,j,k) * G%areaT(i,j)*G%mask2dT(i,j)) From 43b2a43055288ca72d960c081401fa07b4eed812 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Mon, 1 Apr 2024 17:48:36 -0400 Subject: [PATCH 575/629] Add units to the descriptions of 141 variables Added units in comments describing about 141 real variables in 7 framework modules. All answers are bitwise identical, and only comments are changed. --- src/framework/MOM_diag_mediator.F90 | 188 ++++++++++++-------- src/framework/MOM_diag_remap.F90 | 6 +- src/framework/MOM_dyn_horgrid.F90 | 28 +-- src/framework/MOM_horizontal_regridding.F90 | 4 +- src/framework/MOM_interpolate.F90 | 32 ++-- src/framework/MOM_intrinsic_functions.F90 | 2 +- src/framework/MOM_string_functions.F90 | 17 +- 7 files changed, 167 insertions(+), 110 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index eeb239859d..18dcd9a825 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -86,8 +86,8 @@ module MOM_diag_mediator !> Contained for down sampled masks type, private :: diag_dsamp - real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes - real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim] + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes [nondim] end type diag_dsamp !> A group of 1D axes that comprise a 1D/2D/3D mesh @@ -130,8 +130,8 @@ module MOM_diag_mediator integer :: id_volume = -1 !< The diag_manager id for volume to be used for cell_measure of variables !! with this axes_grp. ! For masking - real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes - real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes + real, pointer, dimension(:,:) :: mask2d => null() !< Mask for 2d (x-y) axes [nondim] + real, pointer, dimension(:,:,:) :: mask3d => null() !< Mask for 3d axes [nondim] type(diag_dsamp), dimension(2:MAX_DSAMP_LEV) :: dsamp !< Downsample container end type axes_grp @@ -183,7 +183,8 @@ module MOM_diag_mediator character(64) :: debug_str = '' !< For FATAL errors and debugging. type(axes_grp), pointer :: axes => null() !< The axis group for this diagnostic type(diag_type), pointer :: next => null() !< Pointer to the next diagnostic - real :: conversion_factor = 0. !< A factor to multiply data by before posting to FMS, if non-zero. + real :: conversion_factor = 0. !< If non-zero, a factor to multiply data by before posting to FMS, + !! often including factors to undo internal scaling in units of [a A-1 ~> 1] logical :: v_extensive = .false. !< True for vertically extensive fields (vertically integrated). !! False for intensive (concentrations). integer :: xyz_method = 0 !< A 3 digit integer encoding the diagnostics cell method @@ -217,11 +218,11 @@ module MOM_diag_mediator type(axes_grp), dimension(:), allocatable :: remap_axesTi, remap_axesBi, remap_axesCui, remap_axesCvi !>@} - real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points - real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points - real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points - real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points - !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim] + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim] + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim] + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points [nondim] + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i), all [nondim] real, dimension(:,:,:), pointer :: mask3dTL => null() real, dimension(:,:,:), pointer :: mask3dBL => null() real, dimension(:,:,:), pointer :: mask3dCuL => null() @@ -269,11 +270,11 @@ module MOM_diag_mediator type(axes_grp) :: axesZL !< A 1-D z-space axis at layer centers type(axes_grp) :: axesNull !< An axis group for scalars - real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points - real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points - real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points - real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points - !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) + real, dimension(:,:), pointer :: mask2dT => null() !< 2D mask array for cell-center points [nondim] + real, dimension(:,:), pointer :: mask2dBu => null() !< 2D mask array for cell-corner points [nondim] + real, dimension(:,:), pointer :: mask2dCu => null() !< 2D mask array for east-face points [nondim] + real, dimension(:,:), pointer :: mask2dCv => null() !< 2D mask array for north-face points [nondim] + !>@{ 3D mask arrays for diagnostics at layers (mask...L) and interfaces (mask...i) all [nondim] real, dimension(:,:,:), pointer :: mask3dTL => null() real, dimension(:,:,:), pointer :: mask3dBL => null() real, dimension(:,:,:), pointer :: mask3dCuL => null() @@ -293,7 +294,7 @@ module MOM_diag_mediator type(diag_type), dimension(:), allocatable :: diags !< The list of diagnostics integer :: next_free_diag_id !< The next unused diagnostic ID - !> default missing value to be sent to ALL diagnostics registrations + !> default missing value to be sent to ALL diagnostics registrations [various] real :: missing_value = -1.0e+34 !> Number of diagnostic vertical coordinates (remapped) @@ -358,10 +359,13 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh, id_null integer :: id_zl_native, id_zi_native integer :: i, j, nz - real :: zlev(GV%ke), zinter(GV%ke+1) + real :: zlev(GV%ke) ! Numerical values for layer vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. + real :: zinter(GV%ke+1) ! Numerical values for interface vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. logical :: set_vert - real, allocatable, dimension(:) :: IaxB,iax - real, allocatable, dimension(:) :: JaxB,jax + real, allocatable, dimension(:) :: IaxB, iax ! Index-based integer and half-integer i-axis labels [nondim] + real, allocatable, dimension(:) :: JaxB, jax ! Index-based integer and half-integer j-axis labels [nondim] set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical @@ -596,10 +600,19 @@ subroutine set_axes_info_dsamp(G, GV, param_file, diag_cs, id_zl_native, id_zi_n ! Local variables integer :: id_xq, id_yq, id_zl, id_zi, id_xh, id_yh integer :: i, j, nz, dl - real, dimension(:), pointer :: gridLonT_dsamp =>NULL() - real, dimension(:), pointer :: gridLatT_dsamp =>NULL() - real, dimension(:), pointer :: gridLonB_dsamp =>NULL() - real, dimension(:), pointer :: gridLatB_dsamp =>NULL() + real, dimension(:), pointer :: gridLonT_dsamp =>NULL() ! The longitude of downsampled T points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + real, dimension(:), pointer :: gridLatT_dsamp =>NULL() ! The latitude of downsampled T points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + real, dimension(:), pointer :: gridLonB_dsamp =>NULL() ! The longitude of downsampled B points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + real, dimension(:), pointer :: gridLatB_dsamp =>NULL() ! The latitude of downsampled B points for labeling + ! the output axes, often in units of [degrees_N] or + ! [km] or [m] or [gridpoints]. + id_zl = id_zl_native ; id_zi = id_zi_native !Axes group for native downsampled diagnostics @@ -1263,11 +1276,12 @@ subroutine post_data_0d(diag_field_id, field, diag_cs, is_static) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, intent(in) :: field !< real value being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Local variables - real :: locfield + real :: locfield ! The field being offered in arbitrary unscaled units [a] logical :: used, is_stat type(diag_type), pointer :: diag => null() @@ -1303,12 +1317,13 @@ subroutine post_data_1d_k(diag_field_id, field, diag_cs, is_static) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, target, intent(in) :: field(:) !< 1-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. ! Local variables logical :: used ! The return value of send_data is not used for anything. - real, dimension(:), pointer :: locfield => NULL() + real, dimension(:), pointer :: locfield => NULL() ! The field being offered in arbitrary unscaled units [a] logical :: is_stat integer :: k, ks, ke type(diag_type), pointer :: diag => null() @@ -1357,9 +1372,10 @@ subroutine post_data_2d(diag_field_id, field, diag_cs, is_static, mask) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim] ! Local variables type(diag_type), pointer :: diag => null() @@ -1383,19 +1399,20 @@ end subroutine post_data_2d subroutine post_data_2d_low(diag, field, diag_cs, is_static, mask) type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post real, target, intent(in) :: field(:,:) !< 2-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim] ! Local variables - real, dimension(:,:), pointer :: locfield - real, dimension(:,:), pointer :: locmask + real, dimension(:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a] + real, dimension(:,:), pointer :: locmask ! A pointer to the data mask to use [nondim] character(len=300) :: mesg logical :: used, is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, i, j, isv_o,jsv_o - real, dimension(:,:), allocatable, target :: locfield_dsamp - real, dimension(:,:), allocatable, target :: locmask_dsamp + real, dimension(:,:), allocatable, target :: locfield_dsamp ! A downsampled version of locfield [a] + real, dimension(:,:), allocatable, target :: locmask_dsamp ! A downsampled version of locmask [nondim] integer :: dl locfield => NULL() @@ -1529,18 +1546,21 @@ subroutine post_data_3d(diag_field_id, field, diag_cs, is_static, mask, alt_h) integer, intent(in) :: diag_field_id !< The id for an output variable returned by a !! previous call to register_diag_field. real, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), target, intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] real, dimension(:,:,:), & target, optional, intent(in) :: alt_h !< An alternate thickness to use for vertically !! remapping this diagnostic [H ~> m or kg m-2]. ! Local variables type(diag_type), pointer :: diag => null() - real, dimension(:,:,:), allocatable :: remapped_field + real, dimension(:,:,:), allocatable :: remapped_field !< The vertically remapped diagnostic [A ~> a] logical :: staggered_in_x, staggered_in_y, dz_diag_needed, dz_begin_needed - real, dimension(:,:,:), pointer :: h_diag => NULL() + real, dimension(:,:,:), pointer :: h_diag => NULL() !< A pointer to the thickness to use for vertically + !! remapping this diagnostic [H ~> m or kg m-2]. + real, dimension(diag_cs%G%isd:diag_cS%G%ied, diag_cs%G%jsd:diag_cS%G%jed, diag_cs%GV%ke) :: & dz_diag, & ! Layer vertical extents for remapping [Z ~> m] dz_begin ! Layer vertical extents for remapping extensive quantities [Z ~> m] @@ -1697,21 +1717,22 @@ end subroutine post_data_3d subroutine post_data_3d_low(diag, field, diag_cs, is_static, mask) type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post real, target, intent(in) :: field(:,:,:) !< 3-d array being offered for output or averaging + !! in internally scaled arbitrary units [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output logical, optional, intent(in) :: is_static !< If true, this is a static field that is always offered. - real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] ! Local variables - real, dimension(:,:,:), pointer :: locfield - real, dimension(:,:,:), pointer :: locmask + real, dimension(:,:,:), pointer :: locfield ! The field being offered in arbitrary unscaled units [a] + real, dimension(:,:,:), pointer :: locmask ! A pointer to the data mask to use [nondim] character(len=300) :: mesg logical :: used ! The return value of send_data is not used for anything. logical :: staggered_in_x, staggered_in_y logical :: is_stat integer :: cszi, cszj, dszi, dszj integer :: isv, iev, jsv, jev, ks, ke, i, j, k, isv_c, jsv_c, isv_o,jsv_o - real, dimension(:,:,:), allocatable, target :: locfield_dsamp - real, dimension(:,:,:), allocatable, target :: locmask_dsamp + real, dimension(:,:,:), allocatable, target :: locfield_dsamp ! A downsampled version of locfield [a] + real, dimension(:,:,:), allocatable, target :: locmask_dsamp ! A downsampled version of locmask [nondim] integer :: dl locfield => NULL() @@ -1969,10 +1990,10 @@ end subroutine post_product_sum_v !> Post the horizontally area-averaged diagnostic subroutine post_xy_average(diag_cs, diag, field) type(diag_type), intent(in) :: diag !< This diagnostic - real, target, intent(in) :: field(:,:,:) !< Diagnostic field + real, target, intent(in) :: field(:,:,:) !< Diagnostic field in arbitrary units [A ~> a] type(diag_ctrl), intent(in) :: diag_cs !< Diagnostics mediator control structure ! Local variable - real, dimension(size(field,3)) :: averaged_field + real, dimension(size(field,3)) :: averaged_field ! The horizontally averaged field [A ~> a] logical, dimension(size(field,3)) :: averaged_mask logical :: staggered_in_x, staggered_in_y, used integer :: nz, remap_nz, coord @@ -2102,8 +2123,10 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) @@ -2127,11 +2150,13 @@ integer function register_diag_field(module_name, field_name, axes_in, init_time !! Use '' have no method. character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. !! Use '' have no method. - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file - logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] + logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically !! integrated). Default/absent for intensive. ! Local variables - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] type(diag_ctrl), pointer :: diag_cs type(axes_grp), pointer :: remap_axes type(axes_grp), pointer :: axes @@ -2394,8 +2419,10 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) @@ -2419,11 +2446,13 @@ logical function register_diag_field_expand_cmor(dm_id, module_name, field_name, !! Use '' have no method. character(len=*), optional, intent(in) :: v_cell_method !< Specifies the cell method for the vertical direction. !! Use '' have no method. - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] logical, optional, intent(in) :: v_extensive !< True for vertically extensive fields (vertically !! integrated). Default/absent for intensive. ! Local variables - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: this_diag => null() integer :: fms_id, fms_xyave_id @@ -2535,8 +2564,10 @@ integer function register_diag_field_expand_axes(module_name, field_name, axes, character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided !! with post_data calls (not used in MOM?) logical, optional, intent(in) :: verbose !< If true, FMS is verbose (not used in MOM?) @@ -2845,8 +2876,10 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) character(len=*), optional, intent(out):: err_msg !< String into which an error message might be !! placed (not used in MOM?) @@ -2856,10 +2889,12 @@ function register_scalar_field(module_name, field_name, init_time, diag_cs, & character(len=*), optional, intent(in) :: cmor_long_name !< CMOR long name of a field character(len=*), optional, intent(in) :: cmor_units !< CMOR units of a field character(len=*), optional, intent(in) :: cmor_standard_name !< CMOR standardized name associated with a field - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] integer :: dm_id, fms_id type(diag_type), pointer :: diag => null(), cmor_diag => null() character(len=256) :: posted_cmor_units, posted_cmor_standard_name, posted_cmor_long_name @@ -2953,8 +2988,10 @@ function register_static_field(module_name, field_name, axes, & character(len=*), optional, intent(in) :: long_name !< Long name of a field. character(len=*), optional, intent(in) :: units !< Units of a field. character(len=*), optional, intent(in) :: standard_name !< Standardized name associated with a field - real, optional, intent(in) :: missing_value !< A value that indicates missing values. + real, optional, intent(in) :: missing_value !< A value that indicates missing values in + !! output files, in unscaled arbitrary units [a] real, optional, intent(in) :: range(2) !< Valid range of a variable (not used in MOM?) + !! in arbitrary units [a] logical, optional, intent(in) :: mask_variant !< If true a logical mask must be provided with !! post_data calls (not used in MOM?) logical, optional, intent(in) :: do_not_log !< If true, do not log something (not used in MOM?) @@ -2969,10 +3006,12 @@ function register_static_field(module_name, field_name, axes, & character(len=*), optional, intent(in) :: x_cell_method !< Specifies the cell method for the x-direction. character(len=*), optional, intent(in) :: y_cell_method !< Specifies the cell method for the y-direction. character(len=*), optional, intent(in) :: area_cell_method !< Specifies the cell method for area - real, optional, intent(in) :: conversion !< A value to multiply data by before writing to file + real, optional, intent(in) :: conversion !< A value to multiply data by before writing to files, + !! often including factors to undo internal scaling and + !! in units of [a A-1 ~> 1] ! Local variables - real :: MOM_missing_value + real :: MOM_missing_value ! A value used to indicate missing values in output files, in arbitrary units [a] type(diag_ctrl), pointer :: diag_cs => null() type(diag_type), pointer :: diag => null(), cmor_diag => null() integer :: dm_id, fms_id @@ -4115,8 +4154,8 @@ end subroutine downsample_diag_indices_get !! It also determines the diagnostics-compurte indices for the downsampled array !! 3d interface subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) - real, dimension(:,:,:), pointer :: locfield !< Input array pointer - real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + real, dimension(:,:,:), pointer :: locfield !< Input array pointer in arbitrary units [A ~> a] + real, dimension(:,:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: dl !< Level of down sampling @@ -4124,9 +4163,9 @@ subroutine downsample_diag_field_3d(locfield, locfield_dsamp, dl, diag_cs, diag, integer, intent(inout) :: iev !< i-end index for diagnostics integer, intent(inout) :: jsv !< j-start index for diagnostics integer, intent(inout) :: jev !< j-end index for diagnostics - real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:,:) !< If present, use this real array as the data mask [nondim] ! Locals - real, dimension(:,:,:), pointer :: locmask + real, dimension(:,:,:), pointer :: locmask ! A pointer to the mask [nondim] integer :: f1,f2,isv_o,jsv_o locmask => NULL() @@ -4156,8 +4195,8 @@ end subroutine downsample_diag_field_3d !! It also determines the diagnostics-compurte indices for the downsampled array !! 2d interface subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, isv, iev, jsv, jev, mask) - real, dimension(:,:), pointer :: locfield !< Input array pointer - real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array + real, dimension(:,:), pointer :: locfield !< Input array pointer in arbitrary units [A ~> a] + real, dimension(:,:), allocatable, intent(inout) :: locfield_dsamp !< Output (downsampled) array [A ~> a] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: dl !< Level of down sampling @@ -4165,9 +4204,9 @@ subroutine downsample_diag_field_2d(locfield, locfield_dsamp, dl, diag_cs, diag, integer, intent(inout) :: iev !< i-end index for diagnostics integer, intent(inout) :: jsv !< j-start index for diagnostics integer, intent(inout) :: jev !< j-end index for diagnostics - real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask. + real, optional,target, intent(in) :: mask(:,:) !< If present, use this real array as the data mask [nondim]. ! Locals - real, dimension(:,:), pointer :: locmask + real, dimension(:,:), pointer :: locmask ! A pointer to the mask [nondim] integer :: f1,f2,isv_o,jsv_o locmask => NULL() @@ -4231,11 +4270,11 @@ end subroutine downsample_diag_field_2d !! The down sample method is based on the "cell_methods" for the diagnostics as explained !! in the above table subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, diag,isv_o,jsv_o,isv_d,iev_d,jsv_d,jev_d) - real, dimension(:,:,:), pointer :: field_in !< Original field to be down sampled - real, dimension(:,:,:), allocatable :: field_out !< down sampled field + real, dimension(:,:,:), pointer :: field_in !< Original field to be downsampled in arbitrary units [A ~> a] + real, dimension(:,:,:), allocatable :: field_out !< Downsampled field in the same arbtrary units [A ~> a] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: method !< Sampling method - real, dimension(:,:,:), pointer :: mask !< Mask for field + real, dimension(:,:,:), pointer :: mask !< Mask for field [nondim] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: isv_o !< Original i-start index @@ -4248,7 +4287,12 @@ subroutine downsample_field_3d(field_in, field_out, dl, method, mask, diag_cs, d character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 integer :: k,ks,ke - real :: ave,total_weight,weight + real :: ave ! The running sum of the average, in [A ~> a], [A L2 ~> a m2], + ! [A H L ~> a m2 or a kg m-1] or [A H L2 ~> a m3 or a kg] + real :: weight ! The nondimensional, area-, volume- or mass--based weight for an input + ! value [nondim], [L2 ~> m2], [H L ~> m2 or kg m-1] or [H L2 ~> m3 or kg] + real :: total_weight ! The sum of weights contributing to a point [nondim], [L2 ~> m2], + ! [H L ~> m2 or kg m-1] or [H L2 ~> m3 or kg] real :: eps_vol ! A negligibly small volume or mass [H L2 ~> m3 or kg] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_face ! A negligibly small face area [H L ~> m2 or kg m-1] @@ -4388,11 +4432,11 @@ end subroutine downsample_field_3d !! in the above table subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, diag, & isv_o, jsv_o, isv_d, iev_d, jsv_d, jev_d) - real, dimension(:,:), pointer :: field_in !< Original field to be down sampled - real, dimension(:,:), allocatable :: field_out !< Down sampled field + real, dimension(:,:), pointer :: field_in !< Original field to be downsampled in arbitrary units [A ~> a] + real, dimension(:,:), allocatable :: field_out !< Downsampled field in the same arbtrary units [A ~> a] integer, intent(in) :: dl !< Level of down sampling integer, intent(in) :: method !< Sampling method - real, dimension(:,:), pointer :: mask !< Mask for field + real, dimension(:,:), pointer :: mask !< Mask for field [nondim] type(diag_ctrl), intent(in) :: diag_CS !< Structure used to regulate diagnostic output type(diag_type), intent(in) :: diag !< A structure describing the diagnostic to post integer, intent(in) :: isv_o !< Original i-start index @@ -4404,7 +4448,9 @@ subroutine downsample_field_2d(field_in, field_out, dl, method, mask, diag_cs, d ! Locals character(len=240) :: mesg integer :: i,j,ii,jj,i0,j0,f1,f2,f_in1,f_in2 - real :: ave, total_weight, weight + real :: ave ! The running sum of the average, in [A ~> a] or [A L2 ~> a m2] + real :: weight ! The nondimensional or area-weighted weight for an input value [nondim] or [L2 ~> m2] + real :: total_weight ! The sum of weights contributing to a point [nondim] or [L2 ~> m2] real :: eps_area ! A negligibly small area [L2 ~> m2] real :: eps_len ! A negligibly small horizontal length [L ~> m] diff --git a/src/framework/MOM_diag_remap.F90 b/src/framework/MOM_diag_remap.F90 index ace50242a5..bbefa3808b 100644 --- a/src/framework/MOM_diag_remap.F90 +++ b/src/framework/MOM_diag_remap.F90 @@ -183,7 +183,11 @@ subroutine diag_remap_configure_axes(remap_cs, GV, US, param_file) character(len=40) :: mod = "MOM_diag_remap" ! This module's name. character(len=8) :: units character(len=34) :: longname - real, allocatable, dimension(:) :: interfaces, layers + real, allocatable, dimension(:) :: & + interfaces, & ! Numerical values for interface vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. + layers ! Numerical values for layer vertical coordinates, in unscaled units + ! that might be [m], [kg m-3] or [nondim], depending on the coordinate. call initialize_regridding(remap_cs%regrid_cs, GV, US, GV%max_depth, param_file, mod, & trim(remap_cs%vertical_coord_name), "DIAG_COORD", trim(remap_cs%diag_coord_name)) diff --git a/src/framework/MOM_dyn_horgrid.F90 b/src/framework/MOM_dyn_horgrid.F90 index 8c163f710f..b973b08d4b 100644 --- a/src/framework/MOM_dyn_horgrid.F90 +++ b/src/framework/MOM_dyn_horgrid.F90 @@ -133,16 +133,20 @@ module MOM_dyn_horgrid IareaBu !< IareaBu = 1/areaBu [L-2 ~> m-2]. real, pointer, dimension(:) :: gridLatT => NULL() - !< The latitude of T points for the purpose of labeling the output axes. + !< The latitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatT. real, pointer, dimension(:) :: gridLatB => NULL() - !< The latitude of B points for the purpose of labeling the output axes. + !< The latitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_N] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLatBu. real, pointer, dimension(:) :: gridLonT => NULL() - !< The longitude of T points for the purpose of labeling the output axes. + !< The longitude of T points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonT. real, pointer, dimension(:) :: gridLonB => NULL() - !< The longitude of B points for the purpose of labeling the output axes. + !< The longitude of B points for the purpose of labeling the output axes, + !! often in units of [degrees_E] or [km] or [m] or [gridpoints]. !! On many grids this is the same as geoLonBu. character(len=40) :: & ! Except on a Cartesian grid, these are usually some variant of "degrees". @@ -176,10 +180,10 @@ module MOM_dyn_horgrid ! These parameters are run-time parameters that are used during some ! initialization routines (but not all) - real :: south_lat !< The latitude (or y-coordinate) of the first v-line - real :: west_lon !< The longitude (or x-coordinate) of the first u-line - real :: len_lat !< The latitudinal (or y-coord) extent of physical domain - real :: len_lon !< The longitudinal (or x-coord) extent of physical domain + real :: south_lat !< The latitude (or y-coordinate) of the first v-line [degrees_N] or [km] or [m] + real :: west_lon !< The longitude (or x-coordinate) of the first u-line [degrees_E] or [km] or [m] + real :: len_lat !< The latitudinal (or y-coord) extent of physical domain [degrees_N] or [km] or [m] + real :: len_lon !< The longitudinal (or x-coord) extent of physical domain [degrees_E] or [km] or [m] real :: Rad_Earth !< The radius of the planet [m] real :: Rad_Earth_L !< The radius of the planet in rescaled units [L ~> m] real :: max_depth !< The maximum depth of the ocean [Z ~> m] @@ -407,10 +411,10 @@ end subroutine rotate_dyn_horgrid !! grid, both rescaling the depths and recording the new internal depth units. subroutine rescale_dyn_horgrid_bathymetry(G, m_in_new_units) type(dyn_horgrid_type), intent(inout) :: G !< The dynamic horizontal grid type - real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth. + real, intent(in) :: m_in_new_units !< The new internal representation of 1 m depth [m Z-1 ~> 1] ! Local variables - real :: rescale + real :: rescale ! The inverse of m_in_new_units, used in rescaling bathymetry [Z m-1 ~> 1] integer :: i, j, isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed @@ -485,8 +489,8 @@ end subroutine set_derived_dyn_horgrid !> Adcroft_reciprocal(x) = 1/x for |x|>0 or 0 for x=0. function Adcroft_reciprocal(val) result(I_val) - real, intent(in) :: val !< The value being inverted. - real :: I_val !< The Adcroft reciprocal of val. + real, intent(in) :: val !< The value being inverted in abitrary units [A ~> a] + real :: I_val !< The Adcroft reciprocal of val [A-1 ~> a-1]. I_val = 0.0 ; if (val /= 0.0) I_val = 1.0/val end function Adcroft_reciprocal diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index 205dd6d7be..b718f65b5e 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -322,7 +322,7 @@ subroutine horiz_interp_and_extrap_tracer_record(filename, varnam, recnum, G, tr !! interpreted [a] then [A ~> a] real, dimension(:,:), allocatable :: mask_in ! A 2-d mask for extended input grid [nondim] - real :: PI_180 ! A conversion factor from degrees to radians + real :: PI_180 ! A conversion factor from degrees to radians [radians degree-1] integer :: id, jd, kd, jdp ! Input dataset data sizes integer :: i, j, k integer, dimension(4) :: start, count @@ -670,7 +670,7 @@ subroutine horiz_interp_and_extrap_tracer_fms_id(field, Time, G, tr_z, mask_z, & !! on the original grid [a] real, dimension(:,:), allocatable :: mask_in !< A 2-d mask for extended input grid [nondim] - real :: PI_180 ! A conversion factor from degrees to radians + real :: PI_180 ! A conversion factor from degrees to radians [radians degree-1] integer :: id, jd, kd, jdp ! Input dataset data sizes integer :: i, j, k real, dimension(:,:), allocatable :: x_in ! Input file longitudes [radians] diff --git a/src/framework/MOM_interpolate.F90 b/src/framework/MOM_interpolate.F90 index e131e8db9d..c3b767cc4f 100644 --- a/src/framework/MOM_interpolate.F90 +++ b/src/framework/MOM_interpolate.F90 @@ -31,12 +31,12 @@ module MOM_interpolate 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 + real, intent(inout) :: data_in !< The interpolated value in arbitrary units [A ~> a] logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging - real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are - !! multiplied by before it is returned - real :: data_in_pre_scale ! The input data before rescaling - real :: I_scale ! The inverse of scale + real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are + !! multiplied by before it is returned [A a-1 ~> 1] + real :: data_in_pre_scale ! The input data before rescaling [a] + real :: I_scale ! The inverse of scale [a A-1 ~> 1] ! Store the input value in case the scaling factor is perfectly invertable. data_in_pre_scale = data_in @@ -68,7 +68,8 @@ subroutine time_interp_external_2d(field, time, data_in, interp, & verbose, horz_interp, mask_out, turns, 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, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + real, dimension(:,:), intent(inout) :: data_in !< The array in which to store the interpolated + !! values in arbitrary units [A ~> a] integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging type(horiz_interp_type), & @@ -77,11 +78,11 @@ subroutine time_interp_external_2d(field, time, data_in, interp, & optional, intent(out) :: mask_out !< An array that is true where there is valid data integer, optional, intent(in) :: turns !< Number of quarter turns to rotate the data real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are - !! multiplied by before it is returned + !! multiplied by before it is returned [A a-1 ~> 1] - real, allocatable :: data_in_pre_scale(:,:) ! The input data before rescaling - real, allocatable :: data_pre_rot(:,:) ! The unscaled input data before rotation - real :: I_scale ! The inverse of scale + real, allocatable :: data_in_pre_scale(:,:) ! The input data before rescaling [a] + real, allocatable :: data_pre_rot(:,:) ! The unscaled input data before rotation [a] + real :: I_scale ! The inverse of scale [a A-1 ~> 1] integer :: qturns ! The number of quarter turns to rotate the data integer :: i, j @@ -140,7 +141,8 @@ subroutine time_interp_external_3d(field, time, data_in, interp, & verbose, horz_interp, mask_out, turns, 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, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated values + real, dimension(:,:,:), intent(inout) :: data_in !< The array in which to store the interpolated + !! values in arbitrary units [A ~> a] integer, optional, intent(in) :: interp !< A flag indicating the temporal interpolation method logical, optional, intent(in) :: verbose !< If true, write verbose output for debugging type(horiz_interp_type), & @@ -149,11 +151,11 @@ subroutine time_interp_external_3d(field, time, data_in, interp, & optional, intent(out) :: mask_out !< An array that is true where there is valid data integer, optional, intent(in) :: turns !< Number of quarter turns to rotate the data real, optional, intent(in) :: scale !< A scaling factor that new values of data_in are - !! multiplied by before it is returned + !! multiplied by before it is returned [A a-1 ~> 1] - real, allocatable :: data_in_pre_scale(:,:,:) ! The input data before rescaling - real, allocatable :: data_pre_rot(:,:,:) ! The unscaled input data before rotation - real :: I_scale ! The inverse of scale + real, allocatable :: data_in_pre_scale(:,:,:) ! The input data before rescaling [a] + real, allocatable :: data_pre_rot(:,:,:) ! The unscaled input data before rotation [a] + real :: I_scale ! The inverse of scale [a A-1 ~> 1] integer :: qturns ! The number of quarter turns to rotate the data integer :: i, j, k diff --git a/src/framework/MOM_intrinsic_functions.F90 b/src/framework/MOM_intrinsic_functions.F90 index fbb1c28096..ae0a68df5f 100644 --- a/src/framework/MOM_intrinsic_functions.F90 +++ b/src/framework/MOM_intrinsic_functions.F90 @@ -222,7 +222,7 @@ logical function Test_cuberoot(verbose, val) logical, intent(in) :: verbose !< If true, write results to stdout real, intent(in) :: val !< The real value to test, in arbitrary units [A] ! Local variables - real :: diff ! The difference between val and the cube root of its cube. + real :: diff ! The difference between val and the cube root of its cube [A]. diff = val - cuberoot(val)**3 Test_cuberoot = (abs(diff) > 2.0e-15*abs(val)) diff --git a/src/framework/MOM_string_functions.F90 b/src/framework/MOM_string_functions.F90 index 65aa864f4e..cabe0f6e40 100644 --- a/src/framework/MOM_string_functions.F90 +++ b/src/framework/MOM_string_functions.F90 @@ -86,7 +86,7 @@ end function left_ints !> Returns a left-justified string with a real formatted like '(G)' function left_real(val) - real, intent(in) :: val !< The real variable to convert to a string + real, intent(in) :: val !< The real variable to convert to a string, in arbitrary units [A] character(len=32) :: left_real !< The output string integer :: l, ind @@ -139,7 +139,7 @@ end function left_real !> Returns a character string of a comma-separated, compact formatted, reals !! e.g. "1., 2., 5*3., 5.E2" function left_reals(r,sep) - real, intent(in) :: r(:) !< The array of real variables to convert to a string + real, intent(in) :: r(:) !< The array of real variables to convert to a string, in arbitrary units [A] character(len=*), optional, intent(in) :: sep !< The separator between !! successive values, by default it is ', '. character(len=:), allocatable :: left_reals !< The output string @@ -179,10 +179,10 @@ end function left_reals !> Returns True if the string can be read/parsed to give the exact value of "val" function isFormattedFloatEqualTo(str, val) character(len=*), intent(in) :: str !< The string to parse - real, intent(in) :: val !< The real value to compare with + real, intent(in) :: val !< The real value to compare with, in arbitrary units [A] logical :: isFormattedFloatEqualTo ! Local variables - real :: scannedVal + real :: scannedVal ! The value extraced from str, in arbitrary units [A] isFormattedFloatEqualTo=.false. read(str(1:),*,err=987) scannedVal @@ -263,12 +263,12 @@ integer function extract_integer(string, separators, n, missing_value) end function extract_integer -!> Returns the real corresponding to the nth word in the argument. +!> Returns the real corresponding to the nth word in the argument, in arbitrary units [A]. real function extract_real(string, separators, n, missing_value) character(len=*), intent(in) :: string !< String to scan character(len=*), intent(in) :: separators !< Characters to use for delineation integer, intent(in) :: n !< Number of word to extract - real, optional, intent(in) :: missing_value !< Value to assign if word is missing + real, optional, intent(in) :: missing_value !< Value to assign if word is missing, in arbitrary units [A] ! Local variables character(len=20) :: word @@ -314,6 +314,7 @@ logical function string_functions_unit_tests(verbose) logical, intent(in) :: verbose !< If true, write results to stdout ! Local variables integer :: i(5) = (/ -1, 1, 3, 3, 0 /) + ! This is an array of real test values, in arbitrary units [A] real :: r(8) = (/ 0., 1., -2., 1.3, 3.E-11, 3.E-11, 3.E-11, -5.1E12 /) logical :: fail, v fail = .false. @@ -387,8 +388,8 @@ end function localTestI !> True if r1 is not equal to r2. False otherwise. logical function localTestR(verbose,r1,r2) logical, intent(in) :: verbose !< If true, write results to stdout - real, intent(in) :: r1 !< Float - real, intent(in) :: r2 !< Float + real, intent(in) :: r1 !< The first value to compare, in arbitrary units [A] + real, intent(in) :: r2 !< The first value to compare, in arbitrary units [A] localTestR=.false. if (r1/=r2) localTestR=.true. if (localTestR .or. verbose) then From b98acd861d835c0bf5894f872516d2338a4791f4 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 19 Mar 2024 09:35:29 -0400 Subject: [PATCH 576/629] Add units to the descriptions of 115 variables Added or corrected the units in comments describing about 115 real variables scattered across 14 tracer modules and 10 other modules. All answers are bitwise identical, and only comments are changed. --- .../drivers/timing_tests/time_MOM_EOS.F90 | 21 +++++++++----- src/ALE/coord_adapt.F90 | 4 +-- src/ALE/regrid_interp.F90 | 8 ++--- src/core/MOM_open_boundary.F90 | 11 ++++--- src/diagnostics/MOM_spatial_means.F90 | 4 +-- .../lateral/MOM_hor_visc.F90 | 2 +- .../lateral/MOM_internal_tides.F90 | 21 +++++++++----- .../lateral/MOM_mixed_layer_restrat.F90 | 8 ++--- .../stochastic/MOM_stochastics.F90 | 6 ++-- .../vertical/MOM_vert_friction.F90 | 6 ++-- src/tracer/ISOMIP_tracer.F90 | 6 ++-- src/tracer/MOM_CFC_cap.F90 | 29 ++++++++++--------- src/tracer/MOM_OCMIP2_CFC.F90 | 15 +++++----- src/tracer/MOM_neutral_diffusion.F90 | 3 +- src/tracer/MOM_offline_aux.F90 | 2 +- src/tracer/MOM_offline_main.F90 | 6 ++-- src/tracer/MOM_tracer_registry.F90 | 25 +++++++++------- src/tracer/MOM_tracer_types.F90 | 4 ++- src/tracer/boundary_impulse_tracer.F90 | 10 +++---- src/tracer/dyed_obc_tracer.F90 | 4 +-- src/tracer/ideal_age_example.F90 | 2 +- src/tracer/nw2_tracers.F90 | 6 ++-- src/tracer/oil_tracer.F90 | 2 +- src/tracer/pseudo_salt_tracer.F90 | 2 +- 24 files changed, 116 insertions(+), 91 deletions(-) diff --git a/config_src/drivers/timing_tests/time_MOM_EOS.F90 b/config_src/drivers/timing_tests/time_MOM_EOS.F90 index 29bd4a30ab..94e3282511 100644 --- a/config_src/drivers/timing_tests/time_MOM_EOS.F90 +++ b/config_src/drivers/timing_tests/time_MOM_EOS.F90 @@ -28,9 +28,9 @@ program time_MOM_EOS integer, parameter :: nic=23, halo=4, nits=1000, nsamp=400 #endif -real :: times(nsamp) ! For observing the PDF +real :: times(nsamp) ! CPU times for observing the PDF [seconds] -! Arrays to hold timings: +! Arrays to hold timings in [seconds]: ! first axis corresponds to the form of EOS ! second axis corresponds to the function being timed real, dimension(:,:), allocatable :: timings, tmean, tstd, tmin, tmax @@ -100,14 +100,18 @@ subroutine run_suite(EOS_list, nic, halo, nits, timings) integer, intent(in) :: nits !< Number of calls to sample !! (large enough that the CPU timers can resolve !! the loop) - real, intent(out) :: timings(n_eos,n_fns) !< The average time taken for nits calls + real, intent(out) :: timings(n_eos,n_fns) !< The average time taken for nits calls [seconds] !! First index corresponds to EOS !! Second index: 1 = scalar args, !! 2 = array args without halo, !! 3 = array args with halo and "dom". type(EOS_type) :: EOS integer :: e, i, dom(2) - real :: start, finish, T, S, P, rho + real :: start, finish ! CPU times [seconds] + real :: T ! A potential or conservative temperature [degC] + real :: S ! A practical salinity or absolute salinity [ppt] + real :: P ! A pressure [Pa] + real :: rho ! A density [kg m-3] or specific volume [m3 kg-1] real, dimension(nic+2*halo) :: T1, S1, P1, rho1 T = 10. @@ -171,15 +175,18 @@ subroutine run_one(EOS_list, nic, halo, nits, timing) integer, intent(in) :: nits !< Number of calls to sample !! (large enough that the CPU timers can resolve !! the loop) - real, intent(out) :: timing !< The average time taken for nits calls + real, intent(out) :: timing !< The average time taken for nits calls [seconds] !! First index corresponds to EOS !! Second index: 1 = scalar args, !! 2 = array args without halo, !! 3 = array args with halo and "dom". type(EOS_type) :: EOS integer :: i, dom(2) - real :: start, finish - real, dimension(nic+2*halo) :: T1, S1, P1, rho1 + real :: start, finish ! CPU times [seconds] + real, dimension(nic+2*halo) :: T1 ! Potential or conservative temperatures [degC] + real, dimension(nic+2*halo) :: S1 ! A practical salinities or absolute salinities [ppt] + real, dimension(nic+2*halo) :: P1 ! Pressures [Pa] + real, dimension(nic+2*halo) :: rho1 ! Densities [kg m-3] or specific volumes [m3 kg-1] ! Time the scalar interface call EOS_manual_init(EOS, form_of_EOS=EOS_list(5), & diff --git a/src/ALE/coord_adapt.F90 b/src/ALE/coord_adapt.F90 index 32513c8ad3..0e28ae0395 100644 --- a/src/ALE/coord_adapt.F90 +++ b/src/ALE/coord_adapt.F90 @@ -93,10 +93,10 @@ subroutine set_adapt_params(CS, adaptTimeRatio, adaptAlpha, adaptZoom, adaptZoom type(adapt_CS), pointer :: CS !< The control structure for this module real, optional, intent(in) :: adaptTimeRatio !< Ratio of optimisation and diffusion timescales [nondim] real, optional, intent(in) :: adaptAlpha !< Nondimensional coefficient determining - !! how much optimisation to apply + !! how much optimisation to apply [nondim] real, optional, intent(in) :: adaptZoom !< Near-surface zooming depth [H ~> m or kg m-2] real, optional, intent(in) :: adaptZoomCoeff !< Near-surface zooming coefficient [nondim] - real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient + real, optional, intent(in) :: adaptBuoyCoeff !< Stratification-dependent diffusion coefficient [nondim] real, optional, intent(in) :: adaptDrho0 !< Reference density difference for !! stratification-dependent diffusion [R ~> kg m-3] logical, optional, intent(in) :: adaptDoMin !< If true, form a HYCOM1-like mixed layer by diff --git a/src/ALE/regrid_interp.F90 b/src/ALE/regrid_interp.F90 index 641ae7e6c2..b3100fe8ae 100644 --- a/src/ALE/regrid_interp.F90 +++ b/src/ALE/regrid_interp.F90 @@ -305,7 +305,7 @@ subroutine interpolate_grid( n0, h0, x0, ppoly0_E, ppoly0_coefs, & ! Local variables integer :: k ! loop index - real :: t ! current interface target density + real :: t ! current interface target density [A] ! Make sure boundary coordinates of new grid coincide with boundary ! coordinates of previous grid @@ -385,10 +385,10 @@ function get_polynomial_coordinate( N, h, x_g, edge_values, ppoly_coefs, & ! Local variables real :: xi0 ! normalized target coordinate [nondim] real, dimension(DEGREE_MAX) :: a ! polynomial coefficients [A] - real :: numerator - real :: denominator + real :: numerator ! The numerator of an expression [A] + real :: denominator ! The denominator of an expression [A] real :: delta ! Newton-Raphson increment [nondim] -! real :: x ! global target coordinate +! real :: x ! global target coordinate [nondim] real :: eps ! offset used to get away from boundaries [nondim] real :: grad ! gradient during N-R iterations [A] integer :: i, k, iter ! loop indices diff --git a/src/core/MOM_open_boundary.F90 b/src/core/MOM_open_boundary.F90 index 94320a30c7..8394735cb9 100644 --- a/src/core/MOM_open_boundary.F90 +++ b/src/core/MOM_open_boundary.F90 @@ -5028,7 +5028,7 @@ subroutine mask_outside_OBCs(G, US, param_file, OBC) integer, parameter :: cin = 3, cout = 4, cland = -1, cedge = -2 character(len=256) :: mesg ! Message for error messages. real, allocatable, dimension(:,:) :: color, color2 ! For sorting inside from outside, - ! two different ways + ! two different ways [nondim] if (.not. associated(OBC)) return @@ -5136,7 +5136,7 @@ end subroutine mask_outside_OBCs !> flood the cin, cout values subroutine flood_fill(G, color, cin, cout, cland) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside [nondim] integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain integer, intent(in) :: cland !< color for inside the land mask @@ -5196,7 +5196,7 @@ end subroutine flood_fill !> flood the cin, cout values subroutine flood_fill2(G, color, cin, cout, cland) type(dyn_horgrid_type), intent(inout) :: G !< Ocean grid structure - real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside + real, dimension(:,:), intent(inout) :: color !< For sorting inside from outside [nondim] integer, intent(in) :: cin !< color for inside the domain integer, intent(in) :: cout !< color for outside the domain integer, intent(in) :: cland !< color for inside the land mask @@ -5394,7 +5394,10 @@ subroutine update_segment_tracer_reservoirs(G, GV, uhr, vhr, h, OBC, dt, Reg) ! For salinity the units would be [ppt S-1 ~> 1] integer :: i, j, k, m, n, ntr, nz, ntr_id, fd_id integer :: ishift, idir, jshift, jdir - real :: resrv_lfac_out, resrv_lfac_in + real :: resrv_lfac_out ! The reservoir inverse length scale scaling factor for the outward + ! direction per field [nondim] + real :: resrv_lfac_in ! The reservoir inverse length scale scaling factor for the inward + ! direction per field [nondim] real :: b_in, b_out ! The 0 and 1 switch for tracer reservoirs ! 1 if the length scale of reservoir is zero [nondim] real :: a_in, a_out ! The 0 and 1(-1) switch for reservoir source weights diff --git a/src/diagnostics/MOM_spatial_means.F90 b/src/diagnostics/MOM_spatial_means.F90 index 60ad8dfba5..0d656edf6d 100644 --- a/src/diagnostics/MOM_spatial_means.F90 +++ b/src/diagnostics/MOM_spatial_means.F90 @@ -166,7 +166,7 @@ function global_area_integral(var, G, scale, area, tmp_scale) ! In the following comments, [A] is used to indicate the arbitrary, possibly rescaled units of the ! input array while [a] indicates the unscaled (e.g., mks) units that can be used with the reproducing sums real, dimension(SZI_(G),SZJ_(G)) :: tmpForSumming ! An unscaled cell integral [a m2] - real :: scalefac ! An overall scaling factor for the areas and variable. + real :: scalefac ! An overall scaling factor for the areas and variable, perhaps in [m2 a A-1 L-2 ~> 1] real :: temp_scale ! A temporary scaling factor [a A-1 ~> 1] or [1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -493,7 +493,7 @@ subroutine global_j_mean(array, j_mean, G, mask, scale, tmp_scale) !! arbitrary, possibly rescaled units [A ~> a] real, dimension(SZI_(G)), intent(out) :: j_mean !< Global mean of array along its j-axis [a] or [A ~> a] real, dimension(SZI_(G),SZJ_(G)), & - optional, intent(in) :: mask !< An array used for weighting the j-mean + optional, intent(in) :: mask !< An array used for weighting the j-mean [nondim] real, optional, intent(in) :: scale !< A rescaling factor for the output variable [a A-1 ~> 1] !! that converts it back to unscaled (e.g., mks) !! units to enable the use of the reproducing sums diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index a9eade1a6b..ab7a6fa5fc 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -2973,7 +2973,7 @@ end subroutine smooth_x9_h !! input fields have valid values in the first two halo points upon entry. subroutine smooth_x9_uv(G, field_u, field_v, zero_land) type(ocean_grid_type), intent(in) :: G !< Ocean grid - real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed[arbitrary] + real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: field_u !< u-point field to be smoothed [arbitrary] real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: field_v !< v-point field to be smoothed [arbitrary] logical, optional, intent(in) :: zero_land !< If present and false, return the average !! of the surrounding ocean points when diff --git a/src/parameterizations/lateral/MOM_internal_tides.F90 b/src/parameterizations/lateral/MOM_internal_tides.F90 index a8b0d3f813..5b9ce4934c 100644 --- a/src/parameterizations/lateral/MOM_internal_tides.F90 +++ b/src/parameterizations/lateral/MOM_internal_tides.F90 @@ -146,15 +146,20 @@ module MOM_internal_tides !< The internal wave energy density as a function of (i,j,angle,frequency,mode) !! integrated within an angular and frequency band [R Z3 T-2 ~> J m-2] real, allocatable :: En_restart_mode1(:,:,:,:) - !< The internal wave energy density as a function of (i,j,angle,freq) for mode 1 + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 1 [R Z3 T-2 ~> J m-2] real, allocatable :: En_restart_mode2(:,:,:,:) - !< The internal wave energy density as a function of (i,j,angle,freq) for mode 2 + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 2 [R Z3 T-2 ~> J m-2] real, allocatable :: En_restart_mode3(:,:,:,:) - !< The internal wave energy density as a function of (i,j,angle,freq) for mode 3 + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 3 [R Z3 T-2 ~> J m-2] real, allocatable :: En_restart_mode4(:,:,:,:) - !< The internal wave energy density as a function of (i,j,angle,freq) for mode 4 + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 4 [R Z3 T-2 ~> J m-2] real, allocatable :: En_restart_mode5(:,:,:,:) - !< The internal wave energy density as a function of (i,j,angle,freq) for mode 5 + !< The internal wave energy density as a function of (i,j,angle,freq) + !! for mode 5 [R Z3 T-2 ~> J m-2] real, allocatable, dimension(:) :: frequency !< The frequency of each band [T-1 ~> s-1]. @@ -1795,9 +1800,9 @@ subroutine propagate_y(En, speed_y, Cgy_av, dCgy, dt, G, US, Nangle, CS, LB, res real, dimension(G%isd:G%ied,G%JsdB:G%JedB), & intent(in) :: speed_y !< The magnitude of the group velocity at the !! Cv points [L T-1 ~> m s-1]. - real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band. + real, dimension(Nangle), intent(in) :: Cgy_av !< The average y-projection in each angular band [nondim] real, dimension(Nangle), intent(in) :: dCgy !< The difference in y-projections between the - !! edges of each angular band. + !! edges of each angular band [nondim] real, intent(in) :: dt !< Time increment [T ~> s]. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(int_tide_CS), intent(in) :: CS !< Internal tide control structure @@ -2425,7 +2430,7 @@ subroutine register_int_tide_restarts(G, US, param_file, CS, restart_CS) character(64) :: var_name, cfr type(axis_info) :: axes_inttides(2) - real, dimension(:), allocatable :: angles, freqs + real, dimension(:), allocatable :: angles, freqs ! Lables for angles and frequencies [nondim] isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 057943a788..327d18cc7c 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -1936,12 +1936,12 @@ 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) + real, intent(in) :: u !< Values to test in arbitrary units [A] + real, intent(in) :: u_true !< Values to test against (correct answer) [A] character(len=*), intent(in) :: label !< Message - real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true + real, optional, intent(in) :: tol !< The tolerance for differences between u and u_true [A] ! Local variables - real :: tolerance ! The tolerance for differences between u and u_true + real :: tolerance ! The tolerance for differences between u and u_true [A] integer :: k tolerance = 0.0 ; if (present(tol)) tolerance = tol diff --git a/src/parameterizations/stochastic/MOM_stochastics.F90 b/src/parameterizations/stochastic/MOM_stochastics.F90 index 04a29019fa..b6550c04a4 100644 --- a/src/parameterizations/stochastic/MOM_stochastics.F90 +++ b/src/parameterizations/stochastic/MOM_stochastics.F90 @@ -35,9 +35,9 @@ module MOM_stochastics integer :: id_epbl2_wts = -1 !< Diagnostic id for epbl dissipation perturbation ! stochastic patterns real, allocatable :: sppt_wts(:,:) !< Random pattern for ocean SPPT - !! tendencies with a number between 0 and 2 - real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation - real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation + !! tendencies with a number between 0 and 2 [nondim] + real, allocatable :: epbl1_wts(:,:) !< Random pattern for K.E. generation [nondim] + real, allocatable :: epbl2_wts(:,:) !< Random pattern for K.E. dissipation [nondim] type(diag_ctrl), pointer :: diag !< structure used to regulate timing of diagnostic output type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type stochastic_CS diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index ead2cf00cf..824ae22016 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -551,12 +551,12 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB end subroutine vertFPmix -!> Returns the empirical shape-function given sigma. +!> Returns the empirical shape-function given sigma [nondim] real function G_sig(sigma) - real , intent(in) :: sigma !< non-dimensional normalized boundary layer depth [m] + real , intent(in) :: sigma !< Normalized boundary layer depth [nondim] ! local variables - real :: p1, c2, c3 !< parameters used to fit and match empirycal shape-functions. + real :: p1, c2, c3 !< Parameters used to fit and match empirical shape-functions [nondim] ! parabola p1 = 0.287 diff --git a/src/tracer/ISOMIP_tracer.F90 b/src/tracer/ISOMIP_tracer.F90 index fb2a44242f..64db56b96c 100644 --- a/src/tracer/ISOMIP_tracer.F90 +++ b/src/tracer/ISOMIP_tracer.F90 @@ -45,8 +45,8 @@ module ISOMIP_tracer character(len = 200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the MOM tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? - real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out. + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in [conc] (g m-3)? + real :: land_val(NTR) = -1.0 !< The value of tr used where land is masked out [conc]. logical :: use_sponge !< If true, sponges may be applied somewhere in the domain. integer, dimension(NTR) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux @@ -80,7 +80,7 @@ function register_ISOMIP_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [conc] logical :: register_ISOMIP_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke diff --git a/src/tracer/MOM_CFC_cap.F90 b/src/tracer/MOM_CFC_cap.F90 index 489948a63c..ef11739f33 100644 --- a/src/tracer/MOM_CFC_cap.F90 +++ b/src/tracer/MOM_CFC_cap.F90 @@ -95,7 +95,7 @@ function register_CFC_cap(HI, GV, param_file, CS, tr_Reg, restart_CS) ! This include declares and sets the variable "version". # include "version_variable.h" character(len=200) :: inputdir ! The directory where NetCDF input files are. - real, dimension(:,:,:), pointer :: tr_ptr => NULL() + real, dimension(:,:,:), pointer :: tr_ptr => NULL() ! A pointer to a CFC tracer [mol kg-1] character(len=200) :: CFC_BC_file ! filename with cfc11 and cfc12 data character(len=30) :: CFC_BC_var_name ! varname of field in CFC_BC_file character :: m2char @@ -285,10 +285,11 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array [mol kg-1] character(len=*), intent(in) :: name !< The tracer name - real, intent(in) :: land_val !< A value the tracer takes over land - real, intent(in) :: IC_val !< The initial condition value for the tracer + real, intent(in) :: land_val !< A value the tracer takes over land [mol kg-1] + real, intent(in) :: IC_val !< The initial condition value for the + !! tracer [mol kg-1] type(CFC_cap_CS), pointer :: CS !< The control structure returned by a !! previous call to register_CFC_cap. @@ -480,10 +481,10 @@ subroutine CFC_cap_set_forcing(sfc_state, fluxes, day_start, day_interval, G, US ! (saturation concentration) [mol kg-1]. cfc11_atm, & ! CFC11 atm mole fraction [pico mol/mol] cfc12_atm ! CFC12 atm mole fraction [pico mol/mol] - real :: cfc11_atm_nh ! NH value for cfc11_atm - real :: cfc11_atm_sh ! SH value for cfc11_atm - real :: cfc12_atm_nh ! NH value for cfc12_atm - real :: cfc12_atm_sh ! SH value for cfc12_atm + real :: cfc11_atm_nh ! NH value for cfc11_atm [pico mol/mol] + real :: cfc11_atm_sh ! SH value for cfc11_atm [pico mol/mol] + real :: cfc12_atm_nh ! NH value for cfc12_atm [pico mol/mol] + real :: cfc12_atm_sh ! SH value for cfc12_atm [pico mol/mol] real :: ta ! Absolute sea surface temperature [hectoKelvin] real :: sal ! Surface salinity [PSU]. real :: alpha_11 ! The solubility of CFC 11 [mol kg-1 atm-1]. @@ -670,7 +671,9 @@ logical function CFC_cap_unit_tests(verbose) !! information for debugging unit tests ! Local variables - real :: dummy1, dummy2, ta, sal + real :: dummy1, dummy2 ! Test values of Schmidt numbers [nondim] or solubilities [mol kg-1 atm-1] for CFC11 and CFC12 + real :: ta ! A test value of temperature [hectoKelvin] + real :: sal ! A test value of salinity [ppt] character(len=120) :: test_name ! Title of the unit test CFC_cap_unit_tests = .false. @@ -716,12 +719,12 @@ end function CFC_cap_unit_tests logical function compare_values(verbose, test_name, calc, ans, limit) logical, intent(in) :: verbose !< If true, write results to stdout character(len=80), intent(in) :: test_name !< Brief description of the unit test - real, intent(in) :: calc !< computed value - real, intent(in) :: ans !< correct value - real, intent(in) :: limit !< value above which test fails + real, intent(in) :: calc !< computed value in abitrary units [A] + real, intent(in) :: ans !< correct value [A] + real, intent(in) :: limit !< value above which test fails [A] ! Local variables - real :: diff + real :: diff ! Difference in values [A] diff = ans - calc diff --git a/src/tracer/MOM_OCMIP2_CFC.F90 b/src/tracer/MOM_OCMIP2_CFC.F90 index bb312b5a50..50354b5dc7 100644 --- a/src/tracer/MOM_OCMIP2_CFC.F90 +++ b/src/tracer/MOM_OCMIP2_CFC.F90 @@ -102,7 +102,7 @@ function register_OCMIP2_CFC(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir ! The directory where NetCDF input files are. ! This include declares and sets the variable "version". # include "version_variable.h" - real, dimension(:,:,:), pointer :: tr_ptr => NULL() + real, dimension(:,:,:), pointer :: tr_ptr => NULL() ! A pointer to a CFC tracer [mol m-3] real :: a11_dflt(4), a12_dflt(4) ! Default values of the various coefficients real :: d11_dflt(4), d12_dflt(4) ! in the expressions for the solubility and real :: e11_dflt(3), e12_dflt(3) ! Schmidt numbers [various units by element]. @@ -359,10 +359,11 @@ subroutine init_tracer_CFC(h, tr, name, land_val, IC_val, G, GV, US, CS) 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] - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The tracer concentration array + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(out) :: tr !< The CFC tracer concentration array [mol m-3] character(len=*), intent(in) :: name !< The tracer name - real, intent(in) :: land_val !< A value the tracer takes over land - real, intent(in) :: IC_val !< The initial condition value for the tracer + real, intent(in) :: land_val !< A value the tracer takes over land [mol m-3] + real, intent(in) :: IC_val !< The initial condition value for + !! the CRC tracer [mol m-3] type(OCMIP2_CFC_CS), pointer :: CS !< The control structure returned by a !! previous call to register_OCMIP2_CFC. @@ -439,7 +440,7 @@ subroutine OCMIP2_CFC_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: & CFC11_flux, & ! The fluxes of CFC11 and CFC12 into the ocean, in unscaled units of - CFC12_flux ! CFC concentrations times meters per second [CU R Z T-1 ~> CU kg m-2 s-1] + CFC12_flux ! CFC concentrations times a vertical mass flux [mol R Z m-3 T-1 ~> mol kg m-3 s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, idim(4), jdim(4) @@ -545,8 +546,8 @@ subroutine OCMIP2_CFC_surface_state(sfc_state, h, G, GV, US, CS) real :: SST ! Sea surface temperature [degC]. real :: alpha_11 ! The solubility of CFC 11 [mol m-3 pptv-1]. real :: alpha_12 ! The solubility of CFC 12 [mol m-3 pptv-1]. - real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12. - real :: sc_no_term ! A term related to the Schmidt number. + real :: sc_11, sc_12 ! The Schmidt numbers of CFC 11 and CFC 12 [nondim]. + real :: sc_no_term ! A term related to the Schmidt number [nondim]. integer :: i, j, is, ie, js, je, idim(4), jdim(4) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index b64c665c87..094825d031 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -1023,7 +1023,8 @@ subroutine compute_tapering_coeffs(ne, bld_l, bld_r, coeff_l, coeff_r, h_l, h_r) real, dimension(ne), intent(inout) :: coeff_r !< Tapering coefficient, right column [nondim] ! Local variables - real :: min_bld, max_bld ! Min/Max boundary layer depth in two adjacent columns + real :: min_bld ! Minimum of the boundary layer depth in two adjacent columns [H ~> m or kg m-2] + real :: max_bld ! Maximum of the boundary layer depth in two adjacent columns [H ~> m or kg m-2] integer :: dummy1 ! dummy integer real :: dummy2 ! dummy real [nondim] integer :: k_min_l, k_min_r, k_max_l, k_max_r ! Min/max vertical indices in two adjacent columns diff --git a/src/tracer/MOM_offline_aux.F90 b/src/tracer/MOM_offline_aux.F90 index bd105439c7..cf18210cc5 100644 --- a/src/tracer/MOM_offline_aux.F90 +++ b/src/tracer/MOM_offline_aux.F90 @@ -783,7 +783,7 @@ subroutine update_offline_from_arrays(G, GV, nk_input, ridx_sum, mean_file, sum_ real, dimension(:,:,:,:), allocatable, intent(inout) :: salt_all !< Salinity array [S ~> ppt] integer :: i, j, k, is, ie, js, je, nz - real, parameter :: fill_value = 0. + real, parameter :: fill_value = 0. ! The fill value for input arrays [various] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke ! Check that all fields are allocated (this is a redundant check) diff --git a/src/tracer/MOM_offline_main.F90 b/src/tracer/MOM_offline_main.F90 index 06af35cefd..b31ebba7c8 100644 --- a/src/tracer/MOM_offline_main.F90 +++ b/src/tracer/MOM_offline_main.F90 @@ -872,10 +872,8 @@ subroutine offline_advection_layer(fluxes, Time_start, time_interval, G, GV, US, ! Local variables - ! Remaining zonal mass transports [H L2 ~> m3 or kg] - real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhtr_sub - ! Remaining meridional mass transports [H L2 ~> m3 or kg] - real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhtr_sub + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)) :: uhtr_sub ! Remaining zonal mass transports [H L2 ~> m3 or kg] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)) :: vhtr_sub ! Remaining meridional mass transports [H L2 ~> m3 or kg] real, dimension(SZI_(G),SZJB_(G)) :: rem_col_flux ! The summed absolute value of the remaining ! fluxes through the faces of a column or within a column, in mks units [kg] diff --git a/src/tracer/MOM_tracer_registry.F90 b/src/tracer/MOM_tracer_registry.F90 index 8f7f2a280c..0a5a8d4efd 100644 --- a/src/tracer/MOM_tracer_registry.F90 +++ b/src/tracer/MOM_tracer_registry.F90 @@ -74,11 +74,11 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit type(vardesc), optional, intent(in) :: tr_desc !< A structure with metadata about the tracer real, optional, intent(in) :: OBC_inflow !< the tracer for all inflows via OBC for which OBC_in_u - !! or OBC_in_v are not specified (units of tracer CONC) + !! or OBC_in_v are not specified [CU ~> conc] real, dimension(:,:,:), optional, pointer :: OBC_in_u !< tracer at inflows through u-faces of - !! tracer cells (units of tracer CONC) + !! tracer cells [CU ~> conc] real, dimension(:,:,:), optional, pointer :: OBC_in_v !< tracer at inflows through v-faces of - !! tracer cells (units of tracer CONC) + !! tracer cells [CU ~> conc] ! The following are probably not necessary if registry_diags is present and true. real, dimension(:,:,:), optional, pointer :: ad_x !< diagnostic x-advective flux @@ -99,21 +99,24 @@ subroutine register_tracer(tr_ptr, Reg, param_file, HI, GV, name, longname, unit !! [CU H L2 T-1 ~> conc m3 s-1 or conc kg s-1] real, dimension(:,:,:), optional, pointer :: advection_xy !< convergence of lateral advective tracer fluxes + !! [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] logical, optional, intent(in) :: registry_diags !< If present and true, use the registry for !! the diagnostics of this tracer. real, optional, intent(in) :: conc_scale !< A scaling factor used to convert the concentration - !! of this tracer to its desired units. + !! of this tracer to its desired units [conc CU-1 ~> 1] character(len=*), optional, intent(in) :: flux_nameroot !< Short tracer name snippet used construct the !! names of flux diagnostics. character(len=*), optional, intent(in) :: flux_longname !< A word or phrase used construct the long !! names of flux diagnostics. character(len=*), optional, intent(in) :: flux_units !< The units for the fluxes of this tracer. real, optional, intent(in) :: flux_scale !< A scaling factor used to convert the fluxes - !! of this tracer to its desired units. + !! of this tracer to its desired units + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] character(len=*), optional, intent(in) :: convergence_units !< The units for the flux convergence of !! this tracer. real, optional, intent(in) :: convergence_scale !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units. + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] character(len=*), optional, intent(in) :: cmor_tendprefix !< The CMOR name for the layer-integrated !! tendencies of this tracer. integer, optional, intent(in) :: diag_form !< An integer (1 or 2, 1 by default) indicating the @@ -296,7 +299,7 @@ subroutine register_tracer_diagnostics(Reg, h, Time, diag, G, GV, US, use_ALE, u character(len=120) :: cmor_longname ! The CMOR long name of that variable. character(len=120) :: var_lname ! A temporary longname for a diagnostic. character(len=120) :: cmor_var_lname ! The temporary CMOR long name for a diagnostic - real :: conversion ! Temporary term while we address a bug + real :: conversion ! Temporary term while we address a bug [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m, m2, nTr_in integer :: isd, ied, jsd, jed, IsdB, IedB, JsdB, JedB @@ -633,7 +636,7 @@ subroutine postALE_tracer_diagnostics(Reg, G, GV, diag, dt) type(diag_ctrl), intent(in) :: diag !< regulates diagnostic output real, intent(in) :: dt !< total time interval for these diagnostics [T ~> s] - real :: work(SZI_(G),SZJ_(G),SZK_(GV)) + real :: work(SZI_(G),SZJ_(G),SZK_(GV)) ! Variance decay [CU2 T-1 ~> conc2 s-1] real :: Idt ! The inverse of the time step [T-1 ~> s-1] integer :: i, j, k, is, ie, js, je, nz, m, m2 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke @@ -665,8 +668,9 @@ subroutine post_tracer_diagnostics_at_sync(Reg, h, diag_prev, diag, G, GV, dt) type(diag_ctrl), intent(inout) :: diag !< structure to regulate diagnostic output real, intent(in) :: dt !< total time step for tracer updates [T ~> s] - real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) - real :: work2d(SZI_(G),SZJ_(G)) + real :: work3d(SZI_(G),SZJ_(G),SZK_(GV)) ! The time tendency of a diagnostic [CU T-1 ~> conc s-1] + real :: work2d(SZI_(G),SZJ_(G)) ! The vertically integrated time tendency of a diagnostic + ! in [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] real :: Idt ! The inverse of the time step [T-1 ~> s-1] type(tracer_type), pointer :: Tr=>NULL() integer :: i, j, k, is, ie, js, je, nz, m @@ -717,7 +721,8 @@ subroutine post_tracer_transport_diagnostics(G, GV, Reg, h_diag, diag) type(diag_ctrl), intent(in) :: diag !< structure to regulate diagnostic output integer :: i, j, k, is, ie, js, je, nz, m - real :: work2d(SZI_(G),SZJ_(G)) + real :: work2d(SZI_(G),SZJ_(G)) ! The vertically integrated convergence of lateral advective + ! tracer fluxes [CU H T-1 ~> conc m s-1 or conc kg m-2 s-1] type(tracer_type), pointer :: Tr=>NULL() is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/MOM_tracer_types.F90 b/src/tracer/MOM_tracer_types.F90 index bdae8bcee9..861acedb75 100644 --- a/src/tracer/MOM_tracer_types.F90 +++ b/src/tracer/MOM_tracer_types.F90 @@ -68,7 +68,7 @@ module MOM_tracer_types real :: conc_underflow = 0.0 !< A magnitude of tracer concentrations below !! which values should be set to 0. [CU ~> conc] real :: conc_scale = 1.0 !< A scaling factor used to convert the concentrations - !! of this tracer to its desired units. + !! of this tracer to its desired units [conc CU ~> 1] character(len=64) :: cmor_name !< CMOR name of this tracer character(len=64) :: cmor_units !< CMOR physical dimensions of the tracer character(len=240) :: cmor_longname !< CMOR long name of the tracer @@ -79,11 +79,13 @@ module MOM_tracer_types real :: flux_scale = 1.0 !< A scaling factor used to convert the fluxes !! of this tracer to its desired units, !! including a factor compensating for H scaling. + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] character(len=48) :: flux_units = "" !< The units for fluxes of this variable. character(len=48) :: conv_units = "" !< The units for the flux convergence of this tracer. real :: conv_scale = 1.0 !< A scaling factor used to convert the flux !! convergence of this tracer to its desired units, !! including a factor compensating for H scaling. + !! [conc m CU-1 H-1 ~> 1] or [conc kg m-2 CU-1 H-1 ~> 1] character(len=48) :: cmor_tendprefix = "" !< The CMOR variable prefix for tendencies of this !! tracer, required because CMOR does not follow any !! discernable pattern for these names. diff --git a/src/tracer/boundary_impulse_tracer.F90 b/src/tracer/boundary_impulse_tracer.F90 index 17c1f30525..b8ed0632a2 100644 --- a/src/tracer/boundary_impulse_tracer.F90 +++ b/src/tracer/boundary_impulse_tracer.F90 @@ -41,13 +41,13 @@ module boundary_impulse_tracer logical :: coupled_tracers = .false. !< These tracers are not offered to the coupler. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in [CU ~> conc] (g m-3)? logical :: tracers_may_reinit !< If true, boundary_impulse can be initialized if not found in restart file integer, dimension(NTR_MAX) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. integer :: nkml !< Number of layers in mixed layer - real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land + real, dimension(NTR_MAX) :: land_val = -1.0 !< A value to use to fill in tracers over land [CU ~> conc] real :: remaining_source_time !< How much longer (same units as the timestep) to !! inject the tracer at the surface [T ~> s] @@ -80,8 +80,8 @@ function register_boundary_impulse_tracer(HI, GV, US, param_file, CS, tr_Reg, re ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. ! This include declares and sets the variable "version". # include "version_variable.h" - real, pointer :: tr_ptr(:,:,:) => NULL() - real, pointer :: rem_time_ptr => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [CU ~> conc] + real, pointer :: rem_time_ptr => NULL() ! The ramaining injection time [T ~> s] logical :: register_boundary_impulse_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke @@ -235,7 +235,7 @@ subroutine boundary_impulse_tracer_column_physics(h_old, h_new, ea, eb, fluxes, ! Local variables integer :: i, j, k, is, ie, js, je, nz, m - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: h_work ! Used so that h can be modified [H ~> m or kg m-2] is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke diff --git a/src/tracer/dyed_obc_tracer.F90 b/src/tracer/dyed_obc_tracer.F90 index 92e10187a6..0d04936c26 100644 --- a/src/tracer/dyed_obc_tracer.F90 +++ b/src/tracer/dyed_obc_tracer.F90 @@ -34,7 +34,7 @@ module dyed_obc_tracer character(len=200) :: tracer_IC_file !< The full path to the IC file, or " " to initialize internally. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this subroutine in [conc] integer, allocatable, dimension(:) :: ind_tr !< Indices returned by atmos_ocn_coupler_flux if it is used and the !! surface tracer concentrations are to be provided to the coupler. @@ -66,7 +66,7 @@ function register_dyed_obc_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=200) :: inputdir character(len=48) :: flux_units ! The units for tracer fluxes, usually ! kg(tracer) kg(water)-1 m3 s-1 or kg(tracer) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [conc] logical :: register_dyed_obc_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 8492437cb6..1d04e94589 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -91,7 +91,7 @@ function register_ideal_age_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=40) :: mdl = "ideal_age_example" ! This module's name. character(len=200) :: inputdir ! The directory where the input files are. character(len=48) :: var_name ! The variable's name. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [years] logical :: register_ideal_age_tracer logical :: do_ideal_age, do_vintage, do_ideal_age_dated, do_BL_residence integer :: isd, ied, jsd, jed, nz, m diff --git a/src/tracer/nw2_tracers.F90 b/src/tracer/nw2_tracers.F90 index 3c8fbe4ae8..b4e652a58a 100644 --- a/src/tracer/nw2_tracers.F90 +++ b/src/tracer/nw2_tracers.F90 @@ -33,7 +33,7 @@ module nw2_tracers integer :: ntr = 0 !< The number of tracers that are actually used. type(time_type), pointer :: Time => NULL() !< A pointer to the ocean model's clock. type(tracer_registry_type), pointer :: tr_Reg => NULL() !< A pointer to the tracer registry - real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in g m-3? + real, pointer :: tr(:,:,:,:) => NULL() !< The array of tracers used in this package, in [conc] (g m-3)? real, allocatable , dimension(:) :: restore_rate !< The rate at which the tracer is damped toward !! its target profile [T-1 ~> s-1] type(diag_ctrl), pointer :: diag => NULL() !< A structure that is used to @@ -60,7 +60,7 @@ logical function register_nw2_tracers(HI, GV, US, param_file, CS, tr_Reg, restar # include "version_variable.h" character(len=40) :: mdl = "nw2_tracers" ! This module's name. character(len=8) :: var_name ! The variable's name. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [conc] integer :: isd, ied, jsd, jed, nz, m, ig integer :: n_groups ! Number of groups of three tracers (i.e. # tracers/3) real, allocatable, dimension(:) :: timescale_in_days ! Damping timescale [days] @@ -216,7 +216,7 @@ subroutine nw2_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US integer :: i, j, k, m real :: dt_x_rate ! dt * restoring rate [nondim] real :: rscl ! z* scaling factor [nondim] - real :: target_value ! tracer value + real :: target_value ! tracer target value for damping [conc] ! if (.not.associated(CS)) return diff --git a/src/tracer/oil_tracer.F90 b/src/tracer/oil_tracer.F90 index 40d6f27b44..22310b5802 100644 --- a/src/tracer/oil_tracer.F90 +++ b/src/tracer/oil_tracer.F90 @@ -92,7 +92,7 @@ function register_oil_tracer(HI, GV, US, param_file, CS, tr_Reg, restart_CS) character(len=3) :: name_tag ! String for creating identifying oils character(len=48) :: flux_units ! The units for tracer fluxes, here ! kg(oil) s-1 or kg(oil) m-3 kg(water) s-1. - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [kg m-3] logical :: register_oil_tracer integer :: isd, ied, jsd, jed, nz, m isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 843d725839..1185f70d22 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -73,7 +73,7 @@ function register_pseudo_salt_tracer(HI, GV, param_file, CS, tr_Reg, restart_CS) character(len=48) :: var_name ! The variable's name. ! This include declares and sets the variable "version". # include "version_variable.h" - real, pointer :: tr_ptr(:,:,:) => NULL() + real, pointer :: tr_ptr(:,:,:) => NULL() ! The tracer concentration [ppt] logical :: register_pseudo_salt_tracer integer :: isd, ied, jsd, jed, nz isd = HI%isd ; ied = HI%ied ; jsd = HI%jsd ; jed = HI%jed ; nz = GV%ke From 5b9ae52885be017519eb12a010fbb957db5e1595 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 12 Apr 2024 16:19:58 -0400 Subject: [PATCH 577/629] Disable codecov upload requirement This patch removes the code coverage upload requirement. Constraints around codecov.io upload rules have made it impossible to keep this as a requirement. However, we will still attempt an upload, which should be more successful for accounts with a stored URL token, such as NOAA-GFDL. --- .github/workflows/coverage.yml | 18 ++---------------- 1 file changed, 2 insertions(+), 16 deletions(-) diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 5cd5f91baa..1f5a64ac56 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -31,14 +31,7 @@ jobs: - name: Run (single processor) unit tests run: make run.unit - - name: Report unit test coverage to CI (PR) - if: github.event_name == 'pull_request' - run: make report.cov.unit REQUIRE_COVERAGE_UPLOAD=true - env: - CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - - - name: Report unit test coverage to CI (Push) - if: github.event_name != 'pull_request' + - name: Report unit test coverage to CI run: make report.cov.unit env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} @@ -49,14 +42,7 @@ jobs: - name: Run coverage tests run: make -j -k run.cov - - name: Report coverage to CI (PR) - if: github.event_name == 'pull_request' - run: make report.cov REQUIRE_COVERAGE_UPLOAD=true - env: - CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} - - - name: Report coverage to CI (Push) - if: github.event_name != 'pull_request' + - name: Report coverage to CI run: make report.cov env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} From 6f1c79eb6101529e1534fb27ff23b74bd3b38f69 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 2 Apr 2024 14:55:26 -0400 Subject: [PATCH 578/629] CPP expression parser for makedep This patch adds a relatively robust parser for C preprocessor expressions inside of an #if statement. The following are supported: * Nearly all operators, including arithmetic, logical, and bitwise, * Parentheses within expressions, * defined() evaluations. The following are explicitly not supported: * Function macros, * Multiline preprocessors. No doubt there are other lingering issues, but this is comprehensive enough to handle both MOM6 as well as current and legacy FMS source codes. Existing Makefile.dep output files appear to be mostly unchanged. One rule (data_override.o) had its arguments reordered but is otherwise unchanged. mpp_data.o had its rule corrected to use mpp_util_mpi.inc rather than mpp_util_nocomm.inc. Some fixes and adjustments were made to the overall makedep source: * Input macros (-D) are now stored as key-value dicts, rather than simply a list of macro names. * Input macros are now passed to all scan_fortran_file() calls, rather than just the Fortran source. * Input macros are now correctly passed to FMS makedep. Previously, these were omitted from the Makefile generation. * Previously, #if blocks were always set to True, even though the comments indicated that they were always set to False. Given that neither of these was ever correct, it's amazing that we were able to survive this long without prior incident. The motivation for this PR comes from issues with Makefile generation in FMS. Older versions of FMS were unable to correctly resolve their dependencies in fft.f90 on certain systems (perhaps caused by filesystem peculiarities). Newer versions of FMS were unable to handle the #if block default from True to False. Inevitably, we threw up our hands and solved the underlying problem. --- ac/deps/Makefile.fms.in | 2 +- ac/makedep | 205 +++++++++++++++++++++++++++++++++++++--- 2 files changed, 195 insertions(+), 12 deletions(-) diff --git a/ac/deps/Makefile.fms.in b/ac/deps/Makefile.fms.in index 71c46f082a..e4617f1428 100644 --- a/ac/deps/Makefile.fms.in +++ b/ac/deps/Makefile.fms.in @@ -23,4 +23,4 @@ ARFLAGS = @ARFLAGS@ .PHONY: depend depend: Makefile.dep Makefile.dep: - $(PYTHON) $(MAKEDEP) -o Makefile.dep -e -x libFMS.a -s @srcdir@/test_fms @srcdir@ + $(PYTHON) $(MAKEDEP) $(DEFS) -o Makefile.dep -e -x libFMS.a -s @srcdir@/test_fms @srcdir@ diff --git a/ac/makedep b/ac/makedep index e37f35aca5..4c9cc9229b 100755 --- a/ac/makedep +++ b/ac/makedep @@ -10,7 +10,8 @@ import re import sys -# Pre-compile re searches +# Fortran tokenization + re_module = re.compile(r"^ *module +([a-z_0-9]+)") re_use = re.compile(r"^ *use +([a-z_0-9]+)") re_cpp_define = re.compile(r"^ *# *define +[_a-zA-Z][_a-zA-Z0-9]") @@ -32,6 +33,80 @@ re_procedure = re.compile( ) +# Preprocessor expression tokenization +cpp_scanner = re.Scanner([ + (r'defined', lambda scanner, token: token), + (r'[_A-Za-z][_0-9a-zA-Z]*', lambda scanner, token: token), + (r'[0-9]+', lambda scanner, token: token), + (r'\(', lambda scanner, token: token), + (r'\)', lambda scanner, token: token), + (r'\*', lambda scanner, token: token), + (r'/', lambda scanner, token: token), + (r'\+', lambda scanner, token: token), + (r'-', lambda scanner, token: token), + (r'!', lambda scanner, token: token), + (r'>>', lambda scanner, token: token), + (r'>=', lambda scanner, token: token), + (r'>', lambda scanner, token: token), + (r'<<', lambda scanner, token: token), + (r'<=', lambda scanner, token: token), + (r'<', lambda scanner, token: token), + (r'==', lambda scanner, token: token), + (r'&&', lambda scanner, token: token), + (r'&', lambda scanner, token: token), + (r'\|\|', lambda scanner, token: token), + (r'\|', lambda scanner, token: token), + (r'^\#if', None), + (r'\s+', None), +]) + + +cpp_operate = { + '!': lambda x: not x, + '*': lambda x, y: x * y, + '/': lambda x, y: x // y, + '+': lambda x, y: x + y, + '-': lambda x, y: x - y, + '>>': lambda x, y: x >> y, + '<<': lambda x, y: x << y, + '==': lambda x, y: x == y, + '>': lambda x, y: x > y, + '>=': lambda x, y: x >= y, + '<': lambda x, y: x < y, + '<=': lambda x, y: x <= y, + '&': lambda x, y: x & y, + '^': lambda x, y: x ^ y, + '|': lambda x, y: x | y, + '&&': lambda x, y: x and y, + '||': lambda x, y: x or y, +} + + +cpp_op_rank = { + '(': 13, + '!': 12, + '*': 11, + '/': 11, + '+': 10, + '-': 10, + '>>': 9, + '<<': 9, + '>': 8, + '>=': 8, + '<': 8, + '<=': 8, + '==': 7, + '&': 6, + '^': 5, + '|': 4, + '&&': 2, + '||': 2, + ')': 1, + '$': 1, + None: 0, +} + + def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, link_externals, defines): """Create "makefile" after scanning "src_dis".""" @@ -105,7 +180,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, all_modules += mods for f in c_files: - _, _, cpp, inc, _, _ = scan_fortran_file(f) + _, _, cpp, inc, _, _ = scan_fortran_file(f, defines) # maps object file to .h files included o2h[object_file(f)] = cpp externals.append(object_file(f)) @@ -158,7 +233,7 @@ def create_deps(src_dirs, skip_dirs, makefile, debug, exec_target, fc_rule, ] missing_mods = [m for m in o2uses[o] if m not in all_modules] - incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F) + incs, inc_used = nested_inc(o2h[o] + o2inc[o], f2F, defines) inc_mods = [u for u in inc_used if u not in found_mods and u in all_modules] incdeps = sorted(set([f2F[f] for f in incs if f in f2F])) @@ -250,7 +325,7 @@ def link_obj(obj, o2uses, mod2o, all_modules): return sorted(set(olst)) -def nested_inc(inc_files, f2F): +def nested_inc(inc_files, f2F, defines): """List of all files included by "inc_files", either by #include or F90 include.""" hlst = [] @@ -260,7 +335,7 @@ def nested_inc(inc_files, f2F): if hfile not in f2F.keys(): return - _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile]) + _, used, cpp, inc, _, _ = scan_fortran_file(f2F[hfile], defines) # Record any module updates inside of include files used_mods.update(used) @@ -286,7 +361,8 @@ def scan_fortran_file(src_file, defines=None): cpp_defines = defines if defines is not None else [] - cpp_macros = [define.split('=')[0] for define in cpp_defines] + #cpp_macros = [define.split('=')[0] for define in cpp_defines] + cpp_macros = dict([t.split('=') for t in cpp_defines]) cpp_group_stack = [] with io.open(src_file, 'r', errors='replace') as file: @@ -328,9 +404,9 @@ def scan_fortran_file(src_file, defines=None): if match: cpp_group_stack.append(cpp_exclude) - # XXX: Don't attempt to parse #if statements, but store the state. - # if/endif stack. For now, assume that these always fail. - cpp_exclude = False + cpp_expr_value = cpp_expr_eval(line, cpp_macros) + + cpp_exclude = not cpp_expr_value # Complement #else condition group match = re_cpp_else.match(line) @@ -351,8 +427,14 @@ def scan_fortran_file(src_file, defines=None): # Activate a new macro (ignoring the value) match = re_cpp_define.match(line) if match: - new_macro = line.lstrip()[1:].split()[1] - cpp_macros.append(new_macro) + tokens = line.strip()[1:].split(maxsplit=2) + macro = tokens[1] + value = tokens[2] if tokens[2:] else None + if '(' in macro: + # TODO: Actual handling of function macros + macro, arg = macro.split('(', maxsplit=1) + value = '(' + arg + value + cpp_macros[macro] = value # Deactivate a macro match = re_cpp_undef.match(line) @@ -441,6 +523,107 @@ def add_suff(lst, suff): return [f + suff for f in lst] +def cpp_expr_eval(expr, macros=None): + if macros is None: + macros = {} + + results, remainder = cpp_scanner.scan(expr) + + # Abort if any characters are not tokenized + if remainder: + print('There are untokenized characters!') + print('Expression:', repr(expr)) + print('Tokens:', results) + print('Unscanned:', remainder) + raise + + # Add an "end of line" character to force evaluation of the final tokens. + results.append('$') + + stack = [] + prior_op = None + + tokens = iter(results) + for tok in tokens: + # Evaluate "defined()" statements + if tok == 'defined': + tok = next(tokens) + + parens = tok == '(' + if parens: + tok = next(tokens) + + # NOTE: Any key in `macros` is considered to be set, even if the + # value is None. + value = tok in macros + + # Negation + while prior_op == '!': + op = stack.pop() + assert op == '!' + value = cpp_operate[op](value) + prior_op = stack[-1] if stack else None + + stack.append(value) + + if parens: + tok = next(tokens) + assert tok == ')' + + elif tok.isdigit(): + value = int(tok) + stack.append(value) + + elif tok.isidentifier(): + # "Identifiers that are not macros, which are all considered to be + # the number zero." (CPP manual, 4.2.2) + value = macros.get(tok, '0') + if value.isdigit(): + value = int(value) + stack.append(value) + + elif tok in cpp_op_rank.keys(): + while cpp_op_rank[tok] <= cpp_op_rank[prior_op]: + + # Skip unary prefix operators (only '!' at the moment) + if tok == '!': + break + + second = stack.pop() + op = stack.pop() + first = stack.pop() + + value = cpp_operate[op](first, second) + prior_op = stack[-1] if stack else None + + if prior_op == '(': + prior_op = None + if tok == ')': + stack.pop() + + stack.append(value) + + if tok == ')': + prior_op = stack[-2] if stack and len(stack) > 1 else None + else: + stack.append(tok) + prior_op = tok + + if prior_op in ('(',): + prior_op = None + + else: + print("Unsupported token:", tok) + raise + + # Remove the tail value + eol = stack.pop() + assert eol == '$' + value = stack.pop() + + return value + + # Parse arguments parser = argparse.ArgumentParser( description="Generate make dependencies for F90 source code." From 3a3baf12f74fd5235a3d3ed0df01d53ca015f6db Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 2 Apr 2024 18:12:13 -0400 Subject: [PATCH 579/629] (*)Fix Stokes drift spectrum rescaling Eliminated unneeded rescaling factors when setting the surface Stokes drift spectrum variables (UStk_Hb and VStk_Hb) from forces%[UV]Stkb in Update_Surface_Waves. This bug appears to have been introduced when merging in code that updates the Stokes drifts that was added on one branch (dev/ncar) separately from changes in how these Stokes drifts are scaled in the mech_forcing type on anther branch (dev/gfdl), although it might just have been an oversight during refactoring. All answers are bitwise identical when no dimensional rescaling is being used, but answers could change for some uncommon cases using the Stokes drift spectrum when dimensional rescaling is applied. --- src/user/MOM_wave_interface.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/user/MOM_wave_interface.F90 b/src/user/MOM_wave_interface.F90 index 9a951cf655..656ff5b569 100644 --- a/src/user/MOM_wave_interface.F90 +++ b/src/user/MOM_wave_interface.F90 @@ -717,8 +717,8 @@ subroutine Update_Surface_Waves(G, GV, US, Time_present, dt, CS, forces) do i=G%isc,G%iec !CS%Omega_w2x(i,j) = forces%omega_w2x(i,j) do b=1,CS%NumBands - CS%UStk_Hb(i,j,b) = US%m_s_to_L_T*forces%UStkb(i,j,b) - CS%VStk_Hb(i,j,b) = US%m_s_to_L_T*forces%VStkb(i,j,b) + CS%UStk_Hb(i,j,b) = forces%UStkb(i,j,b) + CS%VStk_Hb(i,j,b) = forces%VStkb(i,j,b) enddo enddo enddo From 6c44c5f3843928c9b7b22aa8178148b0bb36e8ca Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Thu, 4 Apr 2024 16:12:37 -0400 Subject: [PATCH 580/629] Fix for using tidal amplitude in determining the BBL thickness Setting `BBL_USE_TIDAL_BG` in OM5_b003 revealed non-conservation and non-reproducibility across layouts. A scalar variable was correctly being set based on the tidal amplitude but was being used after a break between loops. - Replaced the scalar variable U_bg_sq with a vector u2_bg(:) that is set to either a constant or the square of the tidal amplitude. - The module parameter CS%drag_bg_vel was not set if using the tidal amplitude but WAS being used for conditionals. We now set it to 1e30 because it should NOT be used or impact the solution. Setting it to zero, or anything meaningful would allow code to use it inadvertently. This "constant" does not need to satisfy any dimensional testing. --- .../vertical/MOM_set_viscosity.F90 | 75 ++++++++++++------- 1 file changed, 47 insertions(+), 28 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e601fdf2f7..e16a57d970 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -59,6 +59,7 @@ module MOM_set_visc real :: drag_bg_vel !< An assumed unresolved background velocity for !! calculating the bottom drag [L T-1 ~> m s-1]. !! Runtime parameter `DRAG_BG_VEL`. + !! Should not be used if BBL_USE_TIDAL_BG is True. real :: BBL_thick_min !< The minimum bottom boundary layer thickness [Z ~> m]. !! This might be Kv / (cdrag * drag_bg_vel) to give !! Kv as the minimum near-bottom viscosity. @@ -229,11 +230,8 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) real :: BBL_thick_max ! A huge upper bound on the boundary layer thickness [Z ~> m]. real :: kv_bbl ! The bottom boundary layer viscosity [H Z T-1 ~> m2 s-1 or Pa s] real :: C2f ! C2f = 2*f at velocity points [T-1 ~> s-1]. - - real :: U_bg_sq ! The square of an assumed background - ! velocity, for calculating the mean - ! magnitude near the bottom for use in the - ! quadratic bottom drag [L2 T-2 ~> m2 s-2]. + real :: u2_bg(SZIB_(G)) ! The square of an assumed background velocity, for calculating the mean + ! magnitude near the bottom for use in the quadratic bottom drag [L2 T-2 ~> m2 s-2]. real :: hwtot ! Sum of the thicknesses used to calculate ! the near-bottom velocity magnitude [H ~> m or kg m-2]. real :: I_hwtot ! The Adcroft reciprocal of hwtot [H-1 ~> m-1 or m2 kg-1]. @@ -338,7 +336,6 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) use_BBL_EOS = associated(tv%eqn_of_state) .and. CS%BBL_use_EOS OBC => CS%OBC - U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H @@ -422,7 +419,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) !$OMP parallel do default(private) shared(u,v,h,dz,tv,visc,G,GV,US,CS,Rml,nz,nkmb,nkml,K2, & !$OMP Isq,Ieq,Jsq,Jeq,h_neglect,dz_neglect,Rho0x400_G, & - !$OMP U_bg_sq,cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & + !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL, & !$OMP cdrag_L_to_H,cdrag_RL_to_H,use_BBL_EOS,BBL_thick_max, & !$OMP OBC,D_u,D_v,mask_u,mask_v,pbv) do j=Jsq,Jeq ; do m=1,2 @@ -591,6 +588,19 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) htot_vel = 0.0 ; hwtot = 0.0 ; hutot = 0.0 dztot_vel = 0.0 ; dzwtot = 0.0 Thtot = 0.0 ; Shtot = 0.0 ; SpV_htot = 0.0 + + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + if (m==1) then + u2_bg(I) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + else + u2_bg(i) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + endif + else + u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel + endif do k=nz,1,-1 if (htot_vel>=CS%Hbbl) exit ! terminate the k loop @@ -606,18 +616,10 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if ((.not.CS%linear_drag) .and. (hweight >= 0.0)) then ; if (m==1) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - if (CS%BBL_use_tidal_bg) then - U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & - G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) - endif - hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + hutot = hutot + hweight * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I)) else u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - if (CS%BBL_use_tidal_bg) then - U_bg_sq = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & - G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) - endif - hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + hutot = hutot + hweight * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i)) endif ; endif if (use_BBL_EOS .and. (hweight >= 0.0)) then @@ -798,6 +800,19 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then ; C2f = G%CoriolisBu(I,J-1) + G%CoriolisBu(I,J) else ; C2f = G%CoriolisBu(I-1,J) + G%CoriolisBu(I,J) ; endif + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + if (m==1) then + u2_bg(I) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + else + u2_bg(i) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + endif + else + u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel + endif + ! The thickness of a rotation limited BBL ignoring stratification is ! h_f ~ Cn u* / f (limit of KW99 eq. 2.20 for N->0). ! The buoyancy limit of BBL thickness (h_N) is already in the variable htot from above. @@ -809,7 +824,7 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) ! xp = 1/2 + sqrt( 1/4 + (2 f h_N/u*)^2 ) ! To avoid dividing by zero if u*=0 then ! xp u* = 1/2 u* + sqrt( 1/4 u*^2 + (2 f h_N)^2 ) - if (CS%cdrag * U_bg_sq <= 0.0) then + if (CS%cdrag * u2_bg(i) <= 0.0) then ! This avoids NaNs and overflows, and could be used in all cases, ! but is not bitwise identical to the current code. ustH = ustar(i) ; root = sqrt(0.25*ustH**2 + (htot*C2f)**2) @@ -957,12 +972,12 @@ subroutine set_viscous_BBL(u, v, h, tv, visc, G, GV, US, CS, pbv) if (m==1) then if (Rayleigh > 0.0) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + U_bg_sq) + visc%Ray_u(I,j,k) = Rayleigh * sqrt(u(I,j,k)*u(I,j,k) + v_at_u*v_at_u + u2_bg(I)) else ; visc%Ray_u(I,j,k) = 0.0 ; endif else if (Rayleigh > 0.0) then u_at_v = set_u_at_v(u, h, G, GV, i, j, k, mask_u, OBC) - visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + U_bg_sq) + visc%Ray_v(i,J,k) = Rayleigh * sqrt(v(i,J,k)*v(i,J,k) + u_at_v*u_at_v + u2_bg(i)) else ; visc%Ray_v(i,J,k) = 0.0 ; endif endif @@ -1992,9 +2007,9 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) real :: frac_used ! The fraction of the present layer that contributes to Dh and Ddz [nondim] real :: Dh ! The increment in layer thickness from the present layer [H ~> m or kg m-2]. real :: Ddz ! The increment in height change from the present layer [Z ~> m]. - real :: U_bg_sq ! The square of an assumed background velocity, for - ! calculating the mean magnitude near the top for use in - ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. + real :: u2_bg(SZIB_(G)) ! The square of an assumed background velocity, for + ! calculating the mean magnitude near the top for use in + ! the quadratic surface drag [L2 T-2 ~> m2 s-2]. real :: h_tiny ! A very small thickness [H ~> m or kg m-2]. Layers that are less than ! h_tiny can not be the deepest in the viscous mixed layer. real :: absf ! The absolute value of f averaged to velocity points [T-1 ~> s-1]. @@ -2025,7 +2040,6 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) associated(forces%frac_shelf_v)) ) return Rho0x400_G = 400.0*(GV%H_to_RZ / (US%L_to_Z**2 * GV%g_Earth)) - U_bg_sq = CS%drag_bg_vel * CS%drag_bg_vel cdrag_sqrt = sqrt(CS%cdrag) cdrag_sqrt_H = cdrag_sqrt * US%L_to_m * GV%m_to_H cdrag_sqrt_H_RL = cdrag_sqrt * US%L_to_Z * GV%RZ_to_H @@ -2099,7 +2113,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & - !$OMP js,je,OBC,Isq,Ieq,nz,nkml,U_star_2d,U_bg_sq,mask_v, & + !$OMP js,je,OBC,Isq,Ieq,nz,nkml,U_star_2d,mask_v, & !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do j=js,je ! u-point loop if (CS%dynamic_viscous_ML) then @@ -2251,7 +2265,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.CS%linear_drag) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) - hutot = hutot + hweight * sqrt(u(I,j,k)**2 + v_at_u**2 + U_bg_sq) + hutot = hutot + hweight * sqrt(u(I,j,k)**2 + v_at_u**2 + u2_bg(I)) endif if (use_EOS) then Thtot(I) = Thtot(I) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i+1,j,k)) @@ -2369,7 +2383,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) !$OMP parallel do default(private) shared(u,v,h,dz,tv,forces,visc,dt,G,GV,US,CS,use_EOS,dt_Rho0, & !$OMP nonBous_ML,h_neglect,dz_neglect,h_tiny,g_H_Rho0, & - !$OMP is,ie,OBC,Jsq,Jeq,nz,nkml,U_bg_sq,U_star_2d,mask_u, & + !$OMP is,ie,OBC,Jsq,Jeq,nz,nkml,U_star_2d,mask_u, & !$OMP cdrag_sqrt,cdrag_sqrt_H,cdrag_sqrt_H_RL,Rho0x400_G) do J=Jsq,Jeq ! v-point loop if (CS%dynamic_viscous_ML) then @@ -2523,7 +2537,7 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.CS%linear_drag) then u_at_v = set_u_at_v(u, h, G, GV, i, J, k, mask_u, OBC) - hutot = hutot + hweight * sqrt(v(i,J,k)**2 + u_at_v**2 + U_bg_sq) + hutot = hutot + hweight * sqrt(v(i,J,k)**2 + u_at_v**2 + u2_bg(i)) endif if (use_EOS) then Thtot(i) = Thtot(i) + hweight * 0.5 * (tv%T(i,j,k) + tv%T(i,j+1,k)) @@ -2967,6 +2981,11 @@ subroutine set_visc_init(Time, G, GV, US, param_file, diag, visc, CS, restart_CS call get_param(param_file, mdl, "TIDEAMP_VARNAME", tideamp_var, & "The name of the tidal amplitude variable in the input file.", & default="tideamp") + ! This value is here only to detect whether it is inadvertently used. CS%drag_bg_vel should + ! not be used if CS%BBL_use_tidal_bg is True. For this reason, we do not apply dimensions, + ! nor dimensional testing in this mode. If we ever detect a dimensional sensitivity to + ! this parameter, in this mode, then it means it is being used inappropriately. + CS%drag_bg_vel = 1.e30 else call get_param(param_file, mdl, "DRAG_BG_VEL", CS%drag_bg_vel, & "DRAG_BG_VEL is either the assumed bottom velocity (with "//& From f7a4491b5b5e3f08ebaa128cb15e2fcde9ba9d91 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 5 Apr 2024 10:41:25 -0400 Subject: [PATCH 581/629] Perf: Better error report for failed parsing Print the line and its tokenization in parse_perf.py if the tokenization fails for any reason. This is most likely to occur if the fourth token is not an integer. This is possibly a platform-dependent issue, and not something easily replicated on any machine we are using, so it is easier to simply integrate it into the codebase. --- .testing/tools/parse_perf.py | 13 ++++++++++--- 1 file changed, 10 insertions(+), 3 deletions(-) diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py index b86b1cc106..7cbffd995d 100755 --- a/.testing/tools/parse_perf.py +++ b/.testing/tools/parse_perf.py @@ -58,9 +58,16 @@ def parse_perf_report(perf_data_path): # get per-symbol count else: - tokens = line.split() - symbol = tokens[2] - period = int(tokens[3]) + try: + tokens = line.split() + symbol = tokens[2] + period = int(tokens[3]) + except ValueError: + print("parse_perf.py: Error extracting symbol count", + file=sys.stderr) + print("line:", repr(line), file=sys.stderr) + print("tokens:", tokens, file=sys.stderr) + raise profile[event_name]['symbol'][symbol] = period From 1c4d0dc886b720ffad55d8ef7d2c3ec342326b63 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 5 Apr 2024 09:00:47 -0400 Subject: [PATCH 582/629] Better document variable units in 3 user modules Added descriptions or added or corrected the units in the descriptions of 72 variables in the Neverworld_initialization and basin_builder modules. This includes minor refactoring to avoid reusing scalar variables with completely different units. Also refactored tidal_bay_set_OBC_data by moving the multiplication by rescaling factors at one point so that the units of a variable agree with their documented units. All answers are bitwise identical. --- src/user/Neverworld_initialization.F90 | 75 +++++++++++------------ src/user/basin_builder.F90 | 82 ++++++++++++++------------ src/user/tidal_bay_initialization.F90 | 4 +- 3 files changed, 83 insertions(+), 78 deletions(-) diff --git a/src/user/Neverworld_initialization.F90 b/src/user/Neverworld_initialization.F90 index 05de663d46..6885b6881a 100644 --- a/src/user/Neverworld_initialization.F90 +++ b/src/user/Neverworld_initialization.F90 @@ -34,12 +34,12 @@ module Neverworld_initialization subroutine Neverworld_initialize_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth in the units of depth_max [A] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units [A] ! Local variables - real :: PI ! 3.1415926... calculated as 4*atan(1) + real :: PI ! 3.1415926... calculated as 4*atan(1) [nondim] real :: x, y ! Lateral positions normalized by the domain size [nondim] ! This include declares and sets the variable "version". # include "version_variable.h" @@ -84,9 +84,9 @@ end subroutine Neverworld_initialize_topography !> Returns the value of a cosine-bell function evaluated at x/L real function cosbell(x, L) - real , intent(in) :: x !< non-dimensional position [nondim] - real , intent(in) :: L !< non-dimensional width [nondim] - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< Position in arbitrary units [A] + real , intent(in) :: L !< Width in arbitrary units [A] + real :: PI !< 3.1415926... calculated as 4*atan(1) [nondim] PI = 4.0*atan(1.0) cosbell = 0.5 * (1 + cos(PI*MIN(ABS(x/L),1.0))) @@ -95,9 +95,9 @@ end function cosbell !> Returns the value of a sin-spike function evaluated at x/L real function spike(x, L) - real , intent(in) :: x !< non-dimensional position [nondim] - real , intent(in) :: L !< non-dimensional width [nondim] - real :: PI !< 3.1415926... calculated as 4*atan(1) + real , intent(in) :: x !< Position in arbitrary units [A] + real , intent(in) :: L !< Width in arbitrary units [A] + real :: PI !< 3.1415926... calculated as 4*atan(1) [nondim] PI = 4.0*atan(1.0) spike = (1 - sin(PI*MIN(ABS(x/L),0.5))) @@ -108,9 +108,9 @@ end function spike !! If clip is present the top of the cone is cut off at "clip", which !! effectively defaults to 1. real function cone(x, x0, L, clip) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] real, optional, intent(in) :: clip !< clipping height of cone [nondim] cone = max( 0., 1. - abs(x - x0) / L ) @@ -119,10 +119,10 @@ end function cone !> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. real function scurve(x, x0, L) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] - real :: s + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) scurve = ( 3. - 2.*s ) * ( s * s ) @@ -132,14 +132,14 @@ end function scurve !> Returns a "coastal" profile. real function cstprof(x, x0, L, lf, bf, sf, sh) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< width of profile in arbitrary units [A] real, intent(in) :: lf !< fraction of width that is "land" [nondim] real, intent(in) :: bf !< fraction of width that is "beach" [nondim] real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: s + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) @@ -147,12 +147,12 @@ end function cstprof !> Distance between points x,y and a line segment (x0,y0) and (x0,y1). real function dist_line_fixed_x(x, y, x0, y0, y1) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment [nondim] - real, intent(in) :: y0 !< y-position of line segment end[nondim] - real, intent(in) :: y1 !< y-position of line segment end[nondim] - real :: dx, yr, dy + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment end in arbitrary units [A] + real, intent(in) :: y1 !< y-position of line segment end in arbitrary units [A] + real :: dx, yr, dy ! Relative positions in arbitrary units [A] dx = x - x0 yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 @@ -162,11 +162,11 @@ end function dist_line_fixed_x !> Distance between points x,y and a line segment (x0,y0) and (x1,y0). real function dist_line_fixed_y(x, y, x0, x1, y0) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment end[nondim] - real, intent(in) :: x1 !< x-position of line segment end[nondim] - real, intent(in) :: y0 !< y-position of line segment [nondim] + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: x1 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment in arbitrary units [A] dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y @@ -180,7 +180,7 @@ real function NS_coast(lon, lat, lon0, lat0, lat1, dlon, sh) real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] real, intent(in) :: dlon !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [nondim] r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) @@ -195,7 +195,7 @@ real function EW_coast(lon, lat, lon0, lon1, lat0, dlat, sh) real, intent(in) :: lat0 !< Latitude of coast [degrees_N] real, intent(in) :: dlat !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [nondim] r = dist_line_fixed_y( lon, lat, lon0, lon1, lat0 ) EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) @@ -210,7 +210,7 @@ real function NS_ridge(lon, lat, lon0, lat0, lat1, dlon, rh) real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] - real :: r + real :: r ! A distance from a point [degrees] r = dist_line_fixed_x( lon, lat, lon0, lat0, lat1 ) NS_ridge = 1. - rh * cone(r, 0., dlon) @@ -226,12 +226,13 @@ real function circ_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness, ridg real, intent(in) :: ring_radius !< Radius of ring [degrees] real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: frac_ht ! The fractional height of the topography [nondim] r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle - r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height - circ_ridge = 1. - r ! Fractional depths (1-frac_ridge_height) .. 1 + frac_ht = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_ridge = 1. - frac_ht ! Fractional depths (1-frac_ridge_height) .. 1 end function circ_ridge !> This subroutine initializes layer thicknesses for the Neverworld test case, diff --git a/src/user/basin_builder.F90 b/src/user/basin_builder.F90 index 42083b2672..705925a97d 100644 --- a/src/user/basin_builder.F90 +++ b/src/user/basin_builder.F90 @@ -27,13 +27,13 @@ module basin_builder subroutine basin_builder_topography(D, G, param_file, max_depth) type(dyn_horgrid_type), intent(in) :: G !< The dynamic horizontal grid type real, dimension(G%isd:G%ied,G%jsd:G%jed), & - intent(out) :: D !< Ocean bottom depth in the units of depth_max + intent(out) :: D !< Ocean bottom depth in the units of depth_max [A] type(param_file_type), intent(in) :: param_file !< Parameter file structure - real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units + real, intent(in) :: max_depth !< Maximum ocean depth in arbitrary units [A] ! Local variables character(len=17) :: pname1, pname2 ! For construction of parameter names character(len=20) :: funcs ! Basin build function - real, dimension(20) :: pars ! Parameters for each function + real, dimension(20) :: pars ! Parameters for each function [various] real :: lon ! Longitude [degrees_E] real :: lat ! Latitude [degrees_N] integer :: i, j, n, n_funcs @@ -161,9 +161,9 @@ end subroutine basin_builder_topography !! If clip is present the top of the cone is cut off at "clip", which !! effectively defaults to 1. real function cone(x, x0, L, clip) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] real, optional, intent(in) :: clip !< clipping height of cone [nondim] cone = max( 0., 1. - abs(x - x0) / L ) @@ -172,10 +172,10 @@ end function cone !> Returns an s-curve s(x) s.t. s(x0)<=0, s(x0+L)>=1 and cubic in between. real function scurve(x, x0, L) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< half-width of base of cone [nondim] - real :: s + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< half-width of base of cone in arbitrary units [A] + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) scurve = ( 3. - 2.*s ) * ( s * s ) @@ -183,14 +183,14 @@ end function scurve !> Returns a "coastal" profile. real function cstprof(x, x0, L, lf, bf, sf, sh) - real, intent(in) :: x !< non-dimensional coordinate [nondim] - real, intent(in) :: x0 !< position of peak [nondim] - real, intent(in) :: L !< width of profile [nondim] + real, intent(in) :: x !< Coordinate in arbitrary units [A] + real, intent(in) :: x0 !< position of peak in arbitrary units [A] + real, intent(in) :: L !< width of profile in arbitrary units [A] real, intent(in) :: lf !< fraction of width that is "land" [nondim] real, intent(in) :: bf !< fraction of width that is "beach" [nondim] real, intent(in) :: sf !< fraction of width that is "continental slope" [nondim] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: s + real :: s ! A rescaled position [nondim] s = max( 0., min( 1.,( x - x0 ) / L ) ) cstprof = sh * scurve(s-lf,0.,bf) + (1.-sh) * scurve(s - (1.-sf),0.,sf) @@ -198,12 +198,12 @@ end function cstprof !> Distance between points x,y and a line segment (x0,y0) and (x0,y1). real function dist_line_fixed_x(x, y, x0, y0, y1) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment [nondim] - real, intent(in) :: y0 !< y-position of line segment end[nondim] - real, intent(in) :: y1 !< y-position of line segment end[nondim] - real :: dx, yr, dy + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment end in arbitrary units [A] + real, intent(in) :: y1 !< y-position of line segment end in arbitrary units [A] + real :: dx, yr, dy ! Relative positions in arbitrary units [A] dx = x - x0 yr = min( max(y0,y1), max( min(y0,y1), y ) ) ! bound y by y0,y1 @@ -213,11 +213,11 @@ end function dist_line_fixed_x !> Distance between points x,y and a line segment (x0,y0) and (x1,y0). real function dist_line_fixed_y(x, y, x0, x1, y0) - real, intent(in) :: x !< non-dimensional x-coordinate [nondim] - real, intent(in) :: y !< non-dimensional y-coordinate [nondim] - real, intent(in) :: x0 !< x-position of line segment end[nondim] - real, intent(in) :: x1 !< x-position of line segment end[nondim] - real, intent(in) :: y0 !< y-position of line segment [nondim] + real, intent(in) :: x !< X-coordinate in arbitrary units [A] + real, intent(in) :: y !< Y-coordinate in arbitrary units [A] + real, intent(in) :: x0 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: x1 !< x-position of line segment end in arbitrary units [A] + real, intent(in) :: y0 !< y-position of line segment in arbitrary units [A] dist_line_fixed_y = dist_line_fixed_x(y, x, y0, x0, x1) end function dist_line_fixed_y @@ -230,10 +230,11 @@ real function angled_coast(lon, lat, lon_eq, lat_mer, dr, sh) real, intent(in) :: lat_mer !< Latitude intersection with Prime Meridian [degrees_N] real, intent(in) :: dr !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: I_dr ! The inverse of a distance [degrees-1] - r = 1/sqrt( lat_mer*lat_mer + lon_eq*lon_eq ) - r = r * ( lat_mer*lon + lon_eq*lat - lon_eq*lat_mer) + I_dr = 1/sqrt( lat_mer*lat_mer + lon_eq*lon_eq ) + r = I_dr * ( lat_mer*lon + lon_eq*lat - lon_eq*lat_mer) angled_coast = cstprof(r, 0., dr, 0.125, 0.125, 0.5, sh) end function angled_coast @@ -246,7 +247,7 @@ real function NS_coast(lon, lat, lonC, lat0, lat1, dlon, sh) real, intent(in) :: lat1 !< Latitude of coast end [degrees_N] real, intent(in) :: dlon !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) NS_coast = cstprof(r, 0., dlon, 0.125, 0.125, 0.5, sh) @@ -261,7 +262,7 @@ real function EW_coast(lon, lat, latC, lon0, lon1, dlat, sh) real, intent(in) :: lon1 !< Longitude of coast end [degrees_E] real, intent(in) :: dlat !< "Radius" of coast profile [degrees] real, intent(in) :: sh !< depth of shelf as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_y( lon, lat, lon0, lon1, latC ) EW_coast = cstprof(r, 0., dlat, 0.125, 0.125, 0.5, sh) @@ -276,7 +277,7 @@ real function NS_conic_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) NS_conic_ridge = 1. - rh * cone(r, 0., dlon) @@ -291,7 +292,7 @@ real function NS_scurve_ridge(lon, lat, lonC, lat0, lat1, dlon, rh) real, intent(in) :: lat1 !< Latitude of ridge end [degrees_N] real, intent(in) :: dlon !< "Radius" of ridge profile [degrees] real, intent(in) :: rh !< depth of ridge as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] r = dist_line_fixed_x( lon, lat, lonC, lat0, lat1 ) NS_scurve_ridge = 1. - rh * (1. - scurve(r, 0., dlon) ) @@ -306,12 +307,13 @@ real function circ_conic_ridge(lon, lat, lon0, lat0, ring_radius, ring_thickness real, intent(in) :: ring_radius !< Radius of ring [degrees] real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: frac_ht ! The fractional height of the topography [nondim] r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle - r = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height - circ_conic_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 + frac_ht = cone(r, 0., ring_thickness, ridge_height) ! 0 .. frac_ridge_height + circ_conic_ridge = 1. - frac_ht ! nondim depths (1-frac_ridge_height) .. 1 end function circ_conic_ridge !> A circular ridge with cutoff scurve profile @@ -323,13 +325,15 @@ real function circ_scurve_ridge(lon, lat, lon0, lat0, ring_radius, ring_thicknes real, intent(in) :: ring_radius !< Radius of ring [degrees] real, intent(in) :: ring_thickness !< Radial thickness of ring [degrees] real, intent(in) :: ridge_height !< Ridge height as fraction of full depth [nondim] - real :: r + real :: r ! A relative position [degrees] + real :: s ! A function of the normalized position [nondim] + real :: frac_ht ! The fractional height of the topography [nondim] r = sqrt( (lon - lon0)**2 + (lat - lat0)**2 ) ! Pseudo-distance from a point r = abs( r - ring_radius) ! Pseudo-distance from a circle - r = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1 - r = r * ridge_height ! 0 .. frac_ridge_height - circ_scurve_ridge = 1. - r ! nondim depths (1-frac_ridge_height) .. 1 + s = 1. - scurve(r, 0., ring_thickness) ! 0 .. 1 + frac_ht = s * ridge_height ! 0 .. frac_ridge_height + circ_scurve_ridge = 1. - frac_ht ! nondim depths (1-frac_ridge_height) .. 1 end function circ_scurve_ridge end module basin_builder diff --git a/src/user/tidal_bay_initialization.F90 b/src/user/tidal_bay_initialization.F90 index 37a908d3a8..c2ca2565ce 100644 --- a/src/user/tidal_bay_initialization.F90 +++ b/src/user/tidal_bay_initialization.F90 @@ -110,7 +110,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) enddo endif enddo ; enddo - total_area = reproducing_sum(my_area) + total_area = US%m_to_Z*US%m_to_L * reproducing_sum(my_area) my_flux = - CS%tide_flow * SIN(2.0*PI*time_sec / CS%tide_period) do n = 1, OBC%number_of_segments @@ -118,7 +118,7 @@ subroutine tidal_bay_set_OBC_data(OBC, CS, G, GV, US, h, Time) if (.not. segment%on_pe) cycle - segment%normal_vel_bt(:,:) = my_flux / (US%m_to_Z*US%m_to_L*total_area) + segment%normal_vel_bt(:,:) = my_flux / total_area segment%SSH(:,:) = cff_eta enddo ! end segment loop From 0efe83d7433ac8aa89636257c262446b19ef34b2 Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Fri, 14 Jul 2023 12:59:12 -0400 Subject: [PATCH 583/629] Proto-type cricital latitude modification of Henyey - Adds maximum latitude above which to reduce the background diffusion to the minimum value. --- src/parameterizations/vertical/MOM_bkgnd_mixing.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 index ee04f3f195..4c0baf3d26 100644 --- a/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 +++ b/src/parameterizations/vertical/MOM_bkgnd_mixing.F90 @@ -59,6 +59,8 @@ module MOM_bkgnd_mixing real :: N0_2Omega !< ratio of the typical Buoyancy frequency to !! twice the Earth's rotation period, used with the !! Henyey scaling from the mixing [nondim] + real :: Henyey_max_lat !< A latitude poleward of which the Henyey profile + !! is returned to the minimum diffusivity [degN] real :: prandtl_bkgnd !< Turbulent Prandtl number used to convert !! vertical background diffusivity into viscosity [nondim] real :: Kd_tanh_lat_scale !< A nondimensional scaling for the range of @@ -282,6 +284,10 @@ subroutine bkgnd_mixing_init(Time, G, GV, US, param_file, diag, CS, physical_OBL call get_param(param_file, mdl, "OMEGA", CS%omega, & "The rotation rate of the earth.", & units="s-1", default=7.2921e-5, scale=US%T_to_s) + call get_param(param_file, mdl, "HENYEY_MAX_LAT", CS%Henyey_max_lat, & + "A latitude poleward of which the Henyey profile "//& + "is returned to the minimum diffusivity", & + units="degN", default=95.0) endif call get_param(param_file, mdl, "KD_TANH_LAT_FN", CS%Kd_tanh_lat_fn, & @@ -447,6 +453,7 @@ subroutine calculate_bkgnd_mixing(h, tv, N2_lay, Kd_lay, Kd_int, Kv_bkgnd, j, G, I_x30 = 2.0 / invcosh(CS%N0_2Omega*2.0) ! This is evaluated at 30 deg. do i=is,ie abs_sinlat = abs(sin(G%geoLatT(i,j)*deg_to_rad)) + if (abs(G%geoLatT(i,j))>CS%Henyey_max_lat) abs_sinlat = min_sinlat Kd_sfc(i) = max(CS%Kd_min, CS%Kd * & ((abs_sinlat * invcosh(CS%N0_2Omega / max(min_sinlat, abs_sinlat))) * I_x30) ) enddo From 01b2ea9ba0aa7473a68270700e140e11bf01fd77 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 26 Oct 2023 11:21:25 -0400 Subject: [PATCH 584/629] Document units of 34 real variables in vertFPmix Added standard-format unit descriptions for 34 real variables in comments in the subroutine vertPFmix. Another 6 comments were added noting dimensionally inconsistent expressions in vertFPmix. Only comments are changed and all answers are bitwise identical. --- .../vertical/MOM_vert_friction.F90 | 23 ++++++++++++++----- 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/src/parameterizations/vertical/MOM_vert_friction.F90 b/src/parameterizations/vertical/MOM_vert_friction.F90 index 824ae22016..c26ee4ac75 100644 --- a/src/parameterizations/vertical/MOM_vert_friction.F90 +++ b/src/parameterizations/vertical/MOM_vert_friction.F90 @@ -234,11 +234,15 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: omega_tau2w_u !< angle between mtm flux and wind at u-pts [rad] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: omega_tau2w_v !< angle between mtm flux and wind at v-pts [rad] - real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp, omega_tmp !< constants and dummy variables - real :: du, dv, depth, sigma, Wind_x, Wind_y !< intermediate variables - real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh !< intermediate variables - real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables - real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles + real :: pi, Cemp_CG, tmp, cos_tmp, sin_tmp !< constants and dummy variables [nondim] + real :: omega_tmp !< A dummy angle [radians] + real :: du, dv !< Velocity increments [L T-1 ~> m s-1] + real :: depth !< Cumulative layer thicknesses [H ~> m or kg m=2] + real :: sigma !< Fractional depth in the mixed layer [nondim] + real :: Wind_x, Wind_y !< intermediate wind stress componenents [L2 T-2 ~> m2 s-2] + real :: taux, tauy, tauxDG, tauyDG, tauxDGup, tauyDGup, ustar2, tauh !< intermediate variables [L2 T-2 ~> m2 s-2] + real :: tauNLup, tauNLdn, tauNL_CG, tauNL_DG, tauNL_X, tauNL_Y, tau_MAG !< intermediate variables [L2 T-2 ~> m2 s-2] + real :: omega_w2s, omega_tau2s, omega_s2x, omega_tau2x, omega_tau2w, omega_s2w !< intermediate angles [radians] integer :: kblmin, kbld, kp1, k, nz !< vertical indices integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq ! horizontal indices @@ -321,6 +325,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB enddo if (CS%debug) then + !### These checksum calls are missing necessary dimensional scaling factors. call uvchksum("surface tau[xy]_[uv] ", taux_u, tauy_v, G%HI, haloshift=1, scalar_pair=.true.) call uvchksum("ustar2", ustar2_u, ustar2_v, G%HI, haloshift=0, scalar_pair=.true.) call uvchksum(" hbl", hbl_u , hbl_v , G%HI, haloshift=0, scalar_pair=.true.) @@ -427,6 +432,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB kbld = min( (kbl_u(I,j)) , (nz-2) ) if ( tau_u(I,j,kbld+2) > tau_u(I,j,kbld+1) ) kbld = kbld + 1 + !### This expression is dimensionally inconsistent. tauh = tau_u(I,j,kbld+1) + GV%H_subroundoff ! surface boundary conditions depth = 0. @@ -437,6 +443,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB ! linear stress mag tau_MAG = (ustar2_u(I,j) * (1.-sigma) ) + (tauh * sigma ) + !### The following expressions are dimensionally inconsistent. cos_tmp = tauxDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) sin_tmp = tauyDG_u(I,j,k+1) / (tau_u(I,j,k+1) + GV%H_subroundoff) @@ -457,6 +464,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB tauNLdn = tauNL_X ! nonlocal increment and update to uold + !### The following expression is dimensionally inconsistent and missing parentheses. du = (tauNLup - tauNLdn) * (dt/CS%h_u(I,j,k) + GV%H_subroundoff) ui(I,j,k) = uold(I,j,k) + du uold(I,j,k) = du @@ -496,6 +504,7 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB ! linear stress tau_MAG = (ustar2_v(i,J) * (1.-sigma)) + (tauh * sigma) + !### The following expressions are dimensionally inconsistent. cos_tmp = tauxDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) sin_tmp = tauyDG_v(i,J,k+1) / (tau_v(i,J,k+1) + GV%H_subroundoff) @@ -514,6 +523,8 @@ subroutine vertFPmix(ui, vi, uold, vold, hbl_h, h, forces, dt, G, GV, US, CS, OB tauNL_X = (tauNL_DG * cos_tmp - tauNL_CG * sin_tmp) tauNL_Y = (tauNL_DG * sin_tmp + tauNL_CG * cos_tmp) tauNLdn = tauNL_Y + !### The following expression is dimensionally inconsistent, [L T-1] vs. [L2 H-1 T-1] on the right, + ! and it is inconsistent with the counterpart expression for du. dv = (tauNLup - tauNLdn) * (dt/(CS%h_v(i,J,k)) ) vi(i,J,k) = vold(i,J,k) + dv vold(i,J,k) = dv @@ -2634,7 +2645,7 @@ subroutine vertvisc_init(MIS, Time, G, GV, US, param_file, diag, ADp, dirs, & # include "version_variable.h" character(len=40) :: mdl = "MOM_vert_friction" ! This module's name. character(len=40) :: thickness_units - real :: Kv_mks ! KVML in MKS + real :: Kv_mks ! KVML in MKS [m2 s-1] if (associated(CS)) then call MOM_error(WARNING, "vertvisc_init called with an associated "// & From aac5bb846361bae2c808fb1fa8d9c38564937786 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 25 Apr 2024 22:30:42 -0400 Subject: [PATCH 585/629] Replace db array default values with real literals The default values for the database transfer functions were incorrectly assiged as integer literals, recast to types using real32/64 but actually corresponding to whatever integer kind equals real32/64. We now simply assign it a literal value of -1. and rely on the compiler to handle the recasting. Although none of these functions were intended to be used, and -1 would probably be eventually cast into an appropriate real type, it is better to get this correct. Thanks to Keith Lindsay for suggesting this change. --- .../database_comms/database_client_interface.F90 | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/config_src/external/database_comms/database_client_interface.F90 b/config_src/external/database_comms/database_client_interface.F90 index 8f52df6617..8b05b83daf 100644 --- a/config_src/external/database_comms/database_client_interface.F90 +++ b/config_src/external/database_comms/database_client_interface.F90 @@ -317,7 +317,7 @@ function unpack_tensor_float_1d(self, name, data, dims) result(code) integer :: code code = -1 - data(:) = -1_real32 + data(:) = -1. end function unpack_tensor_float_1d !> Unpack a 32-bit real 2d tensor from the database @@ -329,7 +329,7 @@ function unpack_tensor_float_2d(self, name, data, dims) result(code) integer :: code code = -1 - data(:,:) = -1_real32 + data(:,:) = -1. end function unpack_tensor_float_2d !> Unpack a 32-bit real 3d tensor from the database @@ -341,7 +341,7 @@ function unpack_tensor_float_3d(self, name, data, dims) result(code) integer :: code code = -1 - data(:,:,:) = -1_real32 + data(:,:,:) = -1. end function unpack_tensor_float_3d !> Unpack a 32-bit real 4d tensor from the database @@ -353,7 +353,7 @@ function unpack_tensor_float_4d(self, name, data, dims) result(code) integer :: code code = -1 - data(:,:,:,:) = -1_real32 + data(:,:,:,:) = -1. end function unpack_tensor_float_4d !> Unpack a 64-bit real 1d tensor from the database @@ -365,7 +365,7 @@ function unpack_tensor_double_1d(self, name, data, dims) result(code) integer :: code code = -1 - data(:) = -1_real64 + data(:) = -1. end function unpack_tensor_double_1d !> Unpack a 64-bit real 2d tensor from the database @@ -377,7 +377,7 @@ function unpack_tensor_double_2d(self, name, data, dims) result(code) integer :: code code = -1 - data(:,:) = -1_real64 + data(:,:) = -1. end function unpack_tensor_double_2d !> Unpack a 64-bit real 3d tensor from the database @@ -389,7 +389,7 @@ function unpack_tensor_double_3d(self, name, data, dims) result(code) integer :: code code = -1 - data(:,:,:) = -1_real64 + data(:,:,:) = -1. end function unpack_tensor_double_3d !> Unpack a 64-bit real 4d tensor from the database @@ -401,7 +401,7 @@ function unpack_tensor_double_4d(self, name, data, dims) result(code) integer :: code code = -1 - data(:,:,:,:) = -1_real64 + data(:,:,:,:) = -1. end function unpack_tensor_double_4d !> Unpack a 32-bit integer 1d tensor from the database From 4058462f14d3b6ca2d0ebca8bd59b3e4877967e6 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 31 Mar 2024 12:44:26 -0400 Subject: [PATCH 586/629] Refactoring density integrals for efficiency Refactored 4 routines (int_density_generic_pcm, int_density_generic_ppm, int_spec_vol_generic_pcm and int_spec_vol_generic_plm) in density integrals for greater computational efficiency by doing fewer calls to the equation of state routines but calculating entire rows of densities at subgrid locations with each each call, replicating what was already being done int_density_dz_generic_plm. To accomplish this, a number of variables now use larger arrays than previously. The total computational cost of the non-Boussinesq pressure gradient force calculation was more than 50% greater with the previous code in some tests. All answers are bitwise identical. --- src/core/MOM_density_integrals.F90 | 1241 ++++++++++++++++------------ 1 file changed, 716 insertions(+), 525 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index 9fed528e71..b73524e362 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -141,14 +141,21 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & real, optional, intent(in) :: Z_0p !< The height at which the pressure is 0 [Z ~> m] ! Local variables - real :: T5(5), S5(5) ! Temperatures and salinities at five quadrature points [C ~> degC] and [S ~> ppt] - real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] - real :: r5(5) ! Densities at five quadrature points [R ~> kg m-3] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid locations [R ~> kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations [R ~> kg m-3] real :: rho_anom ! The depth averaged density anomaly [R ~> kg m-3] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] real :: dz ! The layer thickness [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] real :: z0pres ! The height at which the pressure is zero [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] @@ -162,7 +169,10 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & logical :: do_massWeight ! Indicates whether to do mass weighting. logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation ! of density anomalies. - integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: is, ie, js, je, Isq, Ieq, Jsq, Jeq, i, j, m, n, pos ! These array bounds work for the indexing convention of the input arrays, but ! on the computational domain defined for the output arrays. @@ -188,123 +198,169 @@ subroutine int_density_dz_generic_pcm(T, S, z_t, z_b, rho_ref, rho_0, G_e, HI, & "dz_neglect must be present if useMassWghtInterp is present and true.") endif ; endif - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dz = z_t(i,j) - z_b(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + dz = z_t(i,j) - z_b(i,j) + do n=1,5 + T5(i*5+n) = T(i,j) ; S5(i*5+n) = S(i,j) + p5(i*5+n) = -GxRho*((z_t(i,j) - z0pres) - 0.25*real(n-1)*dz) + enddo enddo + if (use_rho_ref) then - call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else - call calculate_density(T5, S5, p5, r5, EOS) - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5) endif - dpa(i,j) = G_e*dz*rho_anom - ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of - ! the pressure anomaly. - if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - enddo ; enddo + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + if (.not.use_rho_ref) rho_anom = rho_anom - rho_ref + dz = z_t(i,j) - z_b(i,j) + dpa(i,j) = G_e*dz*rho_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the pressure anomaly. + if (present(intz_dpa)) intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + 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 + 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 + + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + 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 + dz_x(m,i) = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) + pos = i*15+(m-2)*5 + T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + p15(pos+1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - z0pres) + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + enddo + enddo + + if (use_rho_ref) then + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15, rho_ref=rho_ref) else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15) endif - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - 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 - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i+1,j) - z_b(i+1,j)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - p5(1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i+1,j)) - z0pres) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) + GxRho*0.25*dz - enddo + do I=Isq,Ieq + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + ! Use Boole's rule to estimate the pressure anomaly change. if (use_rho_ref) then - call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) + do m=2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + enddo else - call calculate_density(T5, S5, p5, r5, EOS) - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref ) + do m=2,4 + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_x(m,i)*( C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref ) + enddo endif + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + 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 + + do m=2,4 + ! T, S, and z are interpolated in the horizontal. The z interpolation + ! is linear, but for T and S it may be thickness weighted. + 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 + dz_y(m,i) = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) + pos = i*15+(m-2)*5 + T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + p15(pos+1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - z0pres) + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + enddo enddo - ! Use Boole's rule to integrate the bottom pressure anomaly values in x. - 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 + if (use_rho_ref) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) else - hWt_LL = 1.0 ; hWt_LR = 0.0 ; hWt_RR = 1.0 ; hWt_RL = 0.0 + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15) endif - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - do m=2,4 - ! T, S, and z are interpolated in the horizontal. The z interpolation - ! is linear, but for T and S it may be thickness weighted. - 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 - dz = wt_L*(z_t(i,j) - z_b(i,j)) + wt_R*(z_t(i,j+1) - z_b(i,j+1)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - p5(1) = -GxRho*((wt_L*z_t(i,j) + wt_R*z_t(i,j+1)) - z0pres) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) - p5(n) = p5(n-1) + GxRho*0.25*dz + do i=is,ie + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + ! Use Boole's rule to estimate the pressure anomaly change. + do m=2,4 + pos = i*15+(m-2)*5 + if (use_rho_ref) then + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3))) + else + intz(m) = G_e*dz_y(m,i)*( C1_90*(7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) - rho_ref ) + endif enddo - if (use_rho_ref) then - call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3))) - else - call calculate_density(T5, S5, p5, r5, EOS) - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - rho_ref ) - endif - + ! 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 - ! 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 + enddo ; endif end subroutine int_density_dz_generic_pcm @@ -414,10 +470,9 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & logical :: use_rho_ref ! Pass rho_ref to the equation of state for more accurate calculation ! of density anomalies. logical :: use_varT, use_varS, use_covarTS ! Logicals for SGS variances fields - integer, dimension(2) :: EOSdom_q5 ! The 5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB @@ -456,8 +511,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & enddo ! Set the loop ranges for equation of state calculations at various points. - EOSdom_q5(1) = 1 ; EOSdom_q5(2) = (ieq-isq+2)*5 - EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(ieq-isq+1) + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) ! 1. Compute vertical integrals @@ -475,12 +530,12 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & if (use_varS) S25(i*5+1:i*5+5) = tv%varS(i,j,k) enddo if (use_Stanley_eos) then - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, EOSdom_q5, rho_ref=rho_ref) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else if (use_rho_ref) then - call calculate_density(T5, S5, p5, r5, EOS, EOSdom_q5, rho_ref=rho_ref) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else - call calculate_density(T5, S5, p5, r5, EOS, EOSdom_q5) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5) u5(:) = r5(:) - rho_ref endif endif @@ -491,8 +546,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) dpa(i,j) = G_e*dz(i)*rho_anom if (present(intz_dpa)) then - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) endif @@ -504,8 +559,8 @@ subroutine int_density_dz_generic_plm(k, tv, T_t, T_b, S_t, S_b, e, rho_ref, & - rho_ref dpa(i,j) = G_e*dz(i)*rho_anom if (present(intz_dpa)) then - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. intz_dpa(i,j) = 0.5*G_e*dz(i)**2 * & (rho_anom - C1_90*(16.0*(u5(i*5+4)-u5(i*5+2)) + 7.0*(u5(i*5+5)-u5(i*5+1))) ) endif @@ -774,13 +829,26 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & ! a parabolic interpolation is used to compute intermediate values. ! Local variables - real :: T5(5) ! Temperatures along a line of subgrid locations [C ~> degC] - real :: S5(5) ! Salinities along a line of subgrid locations [S ~> ppt] - real :: T25(5) ! SGS temperature variance along a line of subgrid locations [C2 ~> degC2] - real :: TS5(5) ! SGS temperature-salinity covariance along a line of subgrid locations [C S ~> degC ppt] - real :: S25(5) ! SGS salinity variance along a line of subgrid locations [S2 ~> ppt2] - real :: p5(5) ! Pressures at five quadrature points [R L2 T-2 ~> Pa] - real :: r5(5) ! Density anomalies from rho_ref at quadrature points [R ~> kg m-3] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: T25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS5((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S25((5*HI%iscB+1):(5*(HI%iecB+2))) ! SGS salinity variance along a line of subgrid locations [S2 ~> ppt2] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: r5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Densities anomalies along a line of subgrid + ! locations [R ~> kg m-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: T215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temperature variance along a line of subgrid + ! locations [C2 ~> degC2] + real :: TS15((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS temp-salt covariance along a line of subgrid + ! locations [C S ~> degC ppt] + real :: S215((15*HI%iscB+1):(15*(HI%iecB+1))) ! SGS salinity variance along a line of subgrid + ! locations [S2 ~> ppt2] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: r15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Densities at an array of subgrid locations [R ~> kg m-3] real :: wt_t(5), wt_b(5) ! Top and bottom weights [nondim] real :: rho_anom ! The integrated density anomaly [R ~> kg m-3] real :: w_left, w_right ! Left and right weights [nondim] @@ -790,6 +858,8 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: GxRho ! The gravitational acceleration times density [R L2 Z-1 T-2 ~> kg m-2 s-2] real :: I_Rho ! The inverse of the Boussinesq density [R-1 ~> m3 kg-1] real :: dz ! Layer thicknesses at tracer points [Z ~> m] + real :: dz_x(5,HI%iscB:HI%iecB) ! Layer thicknesses along an x-line of subgrid locations [Z ~> m] + real :: dz_y(5,HI%isc:HI%iec) ! Layer thicknesses along a y-line of subgrid locations [Z ~> m] real :: massWeightToggle ! A non-dimensional toggle factor (0 or 1) [nondim] real :: Ttl, Tbl, Tml, Ttr, Tbr, Tmr ! Temperatures at the velocity cell corners [C ~> degC] real :: Stl, Sbl, Sml, Str, Sbr, Smr ! Salinities at the velocity cell corners [S ~> ppt] @@ -801,9 +871,12 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & real :: hWght ! A topographically limited thickness weight [Z ~> m] real :: hL, hR ! Thicknesses to the left and right [Z ~> m] real :: iDenom ! The denominator of the thickness weight expressions [Z-2 ~> m-2] - integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos logical :: use_PPM ! If false, assume zero curvature in reconstruction, i.e. PLM - logical :: use_varT, use_varS, use_covarTS + logical :: use_varT, use_varS, use_covarTS ! Logicals for SGS variances fields Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB @@ -824,226 +897,277 @@ subroutine int_density_dz_generic_ppm(k, tv, T_t, T_b, S_t, S_b, e, & use_covarTS = .false. use_varS = .false. if (use_stanley_eos) then - use_varT = associated(tv%varT) - use_covarTS = associated(tv%covarTS) - use_varS = associated(tv%varS) + use_varT = associated(tv%varT) + use_covarTS = associated(tv%covarTS) + use_varS = associated(tv%varS) endif T25(:) = 0. TS5(:) = 0. S25(:) = 0. + T215(:) = 0. + TS15(:) = 0. + S215(:) = 0. do n = 1, 5 wt_t(n) = 0.25 * real(5-n) wt_b(n) = 1.0 - wt_t(n) enddo + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + ! 1. Compute vertical integrals - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - if (use_PPM) then - ! Curvature coefficient of the parabolas - s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) - t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) - endif - dz = e(i,j,K) - e(i,j,K+1) - do n=1,5 - p5(n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) - ! Salinity and temperature points are reconstructed with PPM - S5(n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + if (use_PPM) then + ! Curvature coefficient of the parabolas + s6 = 3.0 * ( 2.0*tv%S(i,j,k) - ( S_t(i,j,k) + S_b(i,j,k) ) ) + t6 = 3.0 * ( 2.0*tv%T(i,j,k) - ( T_t(i,j,k) + T_b(i,j,k) ) ) + endif + dz = e(i,j,K) - e(i,j,K+1) + do n=1,5 + p5(I*5+n) = -GxRho*((e(i,j,K) - z0pres) - 0.25*real(n-1)*dz) + ! Salinity and temperature points are reconstructed with PPM + S5(I*5+n) = wt_t(n) * S_t(i,j,k) + wt_b(n) * ( S_b(i,j,k) + s6 * wt_t(n) ) + T5(I*5+n) = wt_t(n) * T_t(i,j,k) + wt_b(n) * ( T_b(i,j,k) + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T25(I*5+1:I*5+5) = tv%varT(i,j,k) + if (use_covarTS) TS5(I*5+1:I*5+5) = tv%covarTS(i,j,k) + if (use_varS) S25(I*5+1:I*5+5) = tv%varS(i,j,k) + endif enddo + if (use_stanley_eos) then - if (use_varT) T25(:) = tv%varT(i,j,k) - if (use_covarTS) TS5(:) = tv%covarTS(i,j,k) - if (use_varS) S25(:) = tv%varS(i,j,k) - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, EOSdom_h5, rho_ref=rho_ref) else - call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + call calculate_density(T5, S5, p5, r5, EOS, EOSdom_h5, rho_ref=rho_ref) endif - ! Use Boole's rule to estimate the pressure anomaly change. - rho_anom = C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) - dpa(i,j) = G_e*dz*rho_anom - if (present(intz_dpa)) then - ! Use a Boole's-rule-like fifth-order accurate estimate of - ! the double integral of the pressure anomaly. - intz_dpa(i,j) = 0.5*G_e*dz**2 * & - (rho_anom - C1_90*(16.0*(r5(4)-r5(2)) + 7.0*(r5(5)-r5(1))) ) - endif - enddo ; enddo ! end loops on j and i + do i=Isq,Ieq+1 + dz = e(i,j,K) - e(i,j,K+1) + ! Use Boole's rule to estimate the pressure anomaly change. + rho_anom = C1_90*(7.0*(r5(i*5+1)+r5(i*5+5)) + 32.0*(r5(i*5+2)+r5(i*5+4)) + 12.0*r5(i*5+3)) + dpa(i,j) = G_e*dz*rho_anom + if (present(intz_dpa)) then + ! Use a Boole's-rule-like fifth-order accurate estimate of + ! the double integral of the pressure anomaly. + intz_dpa(i,j) = 0.5*G_e*dz**2 * & + (rho_anom - C1_90*(16.0*(r5(i*5+4)-r5(i*5+2)) + 7.0*(r5(i*5+5)-r5(i*5+1))) ) + endif + enddo ! end loop on i + enddo ! end loop on j ! 2. Compute horizontal integrals in the x direction - if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec ; do I=Isq,Ieq - ! Corner values of T and S - ! 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, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) - if (hWght > 0.) then - hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff - hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom - Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom - Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom - Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom - Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom - Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom - else - Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) - Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) - Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) - Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) - endif - - do m=2,4 - w_left = wt_t(m) ; w_right = wt_b(m) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*Ttl + w_right*Ttr - T_mn = w_left*Tml + w_right*Tmr - T_bot = w_left*Tbl + w_right*Tbr - - S_top = w_left*Stl + w_right*Str - S_mn = w_left*Sml + w_right*Smr - S_bot = w_left*Sbl + w_right*Sbr - - ! Pressure - dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) - p5(1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres) - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo - - ! Parabolic reconstructions in the vertical for T and S - if (use_PPM) then - ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) - t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) - endif - do n=1,5 - S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) - enddo - if (use_stanley_eos) then - if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) - if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) - if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + if (present(intx_dpa)) then ; do j=HI%jsc,HI%jec + do I=Isq,Ieq + ! Corner values of T and S + ! 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, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i+1,j,K), -bathyT(i+1,j)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i+1,j,K) - e(i+1,j,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i+1,j,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i+1,j,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i+1,j,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i+1,j,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i+1,j,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i+1,j,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i+1,j,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i+1,j,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i+1,j,k) + (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i+1,j,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i+1,j,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i+1,j,k) ) * iDenom else - call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i+1,j,k); Tbr = T_b(i+1,j,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i+1,j,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i+1,j,k); Sbr = S_b(i+1,j,k) + Sml = tv%S(i,j,k); Smr = tv%S(i+1,j,k) endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) - enddo ! m - intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) - ! Use Boole's rule to integrate the bottom pressure anomaly values in x. - intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr - enddo ; enddo ; endif + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr - ! 3. Compute horizontal integrals in the y direction - if (present(inty_dpa)) then ; do J=Jsq,Jeq ; do i=HI%isc,HI%iec - ! Corner values of T and S - ! 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, almost like thickness - ! weighting. - ! Note: To work in terrain following coordinates we could offset - ! this distance by the layer thickness to replicate other models. - hWght = massWeightToggle * & - max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) - if (hWght > 0.) then - hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff - hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff - hWght = hWght * ( (hL-hR)/(hL+hR) )**2 - iDenom = 1./( hWght*(hR + hL) + hL*hR ) - Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom - Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom - Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom - Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom - Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom - Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom - Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom - Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom - Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom - Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom - Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom - Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom + ! Pressure + dz_x(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i+1,j,K) - e(i+1,j,K+1)) + + pos = i*15+(m-2)*5 + p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i+1,j,K)) - z0pres) + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_x(m,i) + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + if (use_stanley_eos) then + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i+1,j,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i+1,j,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i+1,j,k) + endif + if (use_stanley_eos) then + call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + else + call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + endif + enddo + enddo + + if (use_stanley_eos) then + call calculate_density(T15, S15, p15, T215, TS15, S215, r15, EOS, EOSdom_q15, rho_ref=rho_ref) else - Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) - Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) - Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) - Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) + call calculate_density(T15, S15, p15, r15, EOS, EOSdom_q15, rho_ref=rho_ref) endif - do m=2,4 - w_left = wt_t(m) ; w_right = wt_b(m) - - ! Salinity and temperature points are linearly interpolated in - ! the horizontal. The subscript (1) refers to the top value in - ! the vertical profile while subscript (5) refers to the bottom - ! value in the vertical profile. - T_top = w_left*Ttl + w_right*Ttr - T_mn = w_left*Tml + w_right*Tmr - T_bot = w_left*Tbl + w_right*Tbr - - S_top = w_left*Stl + w_right*Str - S_mn = w_left*Sml + w_right*Smr - S_bot = w_left*Sbl + w_right*Sbr - - ! Pressure - dz = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) - p5(1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres) - do n=2,5 - p5(n) = p5(n-1) + GxRho*0.25*dz - enddo + do I=Isq,Ieq + do m=2,4 + pos = i*15+(m-2)*5 + ! Use Boole's rule to estimate the pressure anomaly change. + intz(m) = G_e*dz_x(m,i)*( C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i+1,j) - ! Parabolic reconstructions in the vertical for T and S - if (use_PPM) then - ! Coefficients of the parabolas - s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) - t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) - endif - do n=1,5 - S5(n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) - T5(n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) - enddo + ! Use Boole's rule to integrate the bottom pressure anomaly values in x. + intx_dpa(I,j) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) - if (use_stanley_eos) then - if (use_varT) T25(:) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) - if (use_covarTS) TS5(:) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) - if (use_varS) S25(:) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) - call calculate_density(T5, S5, p5, T25, TS5, S25, r5, EOS, rho_ref=rho_ref) + enddo + enddo ; endif + + ! 3. Compute horizontal integrals in the y direction + if (present(inty_dpa)) then ; do J=Jsq,Jeq + do i=HI%isc,HI%iec + ! Corner values of T and S + ! 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, almost like thickness + ! weighting. + ! Note: To work in terrain following coordinates we could offset + ! this distance by the layer thickness to replicate other models. + hWght = massWeightToggle * & + max(0., -bathyT(i,j)-e(i,j+1,K), -bathyT(i,j+1)-e(i,j,K)) + if (hWght > 0.) then + hL = (e(i,j,K) - e(i,j,K+1)) + dz_subroundoff + hR = (e(i,j+1,K) - e(i,j+1,K+1)) + dz_subroundoff + hWght = hWght * ( (hL-hR)/(hL+hR) )**2 + iDenom = 1./( hWght*(hR + hL) + hL*hR ) + Ttl = ( (hWght*hR)*T_t(i,j+1,k) + (hWght*hL + hR*hL)*T_t(i,j,k) ) * iDenom + Tbl = ( (hWght*hR)*T_b(i,j+1,k) + (hWght*hL + hR*hL)*T_b(i,j,k) ) * iDenom + Tml = ( (hWght*hR)*tv%T(i,j+1,k)+ (hWght*hL + hR*hL)*tv%T(i,j,k) ) * iDenom + Ttr = ( (hWght*hL)*T_t(i,j,k) + (hWght*hR + hR*hL)*T_t(i,j+1,k) ) * iDenom + Tbr = ( (hWght*hL)*T_b(i,j,k) + (hWght*hR + hR*hL)*T_b(i,j+1,k) ) * iDenom + Tmr = ( (hWght*hL)*tv%T(i,j,k) + (hWght*hR + hR*hL)*tv%T(i,j+1,k) ) * iDenom + Stl = ( (hWght*hR)*S_t(i,j+1,k) + (hWght*hL + hR*hL)*S_t(i,j,k) ) * iDenom + Sbl = ( (hWght*hR)*S_b(i,j+1,k) + (hWght*hL + hR*hL)*S_b(i,j,k) ) * iDenom + Sml = ( (hWght*hR)*tv%S(i,j+1,k)+ (hWght*hL + hR*hL)*tv%S(i,j,k) ) * iDenom + Str = ( (hWght*hL)*S_t(i,j,k) + (hWght*hR + hR*hL)*S_t(i,j+1,k) ) * iDenom + Sbr = ( (hWght*hL)*S_b(i,j,k) + (hWght*hR + hR*hL)*S_b(i,j+1,k) ) * iDenom + Smr = ( (hWght*hL)*tv%S(i,j,k) + (hWght*hR + hR*hL)*tv%S(i,j+1,k) ) * iDenom else - call calculate_density(T5, S5, p5, r5, EOS, rho_ref=rho_ref) + Ttl = T_t(i,j,k); Tbl = T_b(i,j,k); Ttr = T_t(i,j+1,k); Tbr = T_b(i,j+1,k) + Tml = tv%T(i,j,k); Tmr = tv%T(i,j+1,k) + Stl = S_t(i,j,k); Sbl = S_b(i,j,k); Str = S_t(i,j+1,k); Sbr = S_b(i,j+1,k) + Sml = tv%S(i,j,k); Smr = tv%S(i,j+1,k) endif - ! Use Boole's rule to estimate the pressure anomaly change. - intz(m) = G_e*dz*( C1_90*(7.0*(r5(1)+r5(5)) + 32.0*(r5(2)+r5(4)) + 12.0*r5(3)) ) - enddo ! m - intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) + do m=2,4 + w_left = wt_t(m) ; w_right = wt_b(m) + + ! Salinity and temperature points are linearly interpolated in + ! the horizontal. The subscript (1) refers to the top value in + ! the vertical profile while subscript (5) refers to the bottom + ! value in the vertical profile. + T_top = w_left*Ttl + w_right*Ttr + T_mn = w_left*Tml + w_right*Tmr + T_bot = w_left*Tbl + w_right*Tbr + + S_top = w_left*Stl + w_right*Str + S_mn = w_left*Sml + w_right*Smr + S_bot = w_left*Sbl + w_right*Sbr + + ! Pressure + dz_y(m,i) = w_left*(e(i,j,K) - e(i,j,K+1)) + w_right*(e(i,j+1,K) - e(i,j+1,K+1)) + + pos = i*15+(m-2)*5 + p15(pos+1) = -GxRho*((w_left*e(i,j,K) + w_right*e(i,j+1,K)) - z0pres) + do n=2,5 + p15(pos+n) = p15(pos+n-1) + GxRho*0.25*dz_y(m,i) + enddo + + ! Parabolic reconstructions in the vertical for T and S + if (use_PPM) then + ! Coefficients of the parabolas + s6 = 3.0 * ( 2.0*S_mn - ( S_top + S_bot ) ) + t6 = 3.0 * ( 2.0*T_mn - ( T_top + T_bot ) ) + endif + do n=1,5 + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * ( S_bot + s6 * wt_t(n) ) + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * ( T_bot + t6 * wt_t(n) ) + enddo + + if (use_stanley_eos) then + if (use_varT) T215(pos+1:pos+5) = w_left*tv%varT(i,j,k) + w_right*tv%varT(i,j+1,k) + if (use_covarTS) TS15(pos+1:pos+5) = w_left*tv%covarTS(i,j,k) + w_right*tv%covarTS(i,j+1,k) + if (use_varS) S215(pos+1:pos+5) = w_left*tv%varS(i,j,k) + w_right*tv%varS(i,j+1,k) + endif + enddo + enddo + + if (use_stanley_eos) then + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + T215(15*HI%isc+1:), TS15(15*HI%isc+1:), S215(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) + else + call calculate_density(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + r15(15*HI%isc+1:), EOS, EOSdom_h15, rho_ref=rho_ref) + endif - ! Use Boole's rule to integrate the bottom pressure anomaly values in y. - inty_dpa(i,J) = C1_90*(7.0*(intz(1)+intz(5)) + 32.0*(intz(2)+intz(4)) + 12.0*intz(3)) + do i=HI%isc,HI%iec + do m=2,4 + ! Use Boole's rule to estimate the pressure anomaly change. + pos = i*15+(m-2)*5 + intz(m) = G_e*dz_y(m,i)*( C1_90*( 7.0*(r15(pos+1)+r15(pos+5)) + & + 32.0*(r15(pos+2)+r15(pos+4)) + & + 12.0*r15(pos+3)) ) + enddo ! m + intz(1) = dpa(i,j) ; intz(5) = dpa(i,j+1) - enddo ; enddo ; endif + ! Use Boole's rule to integrate the bottom pressure anomaly values in y. + 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_generic_ppm @@ -1161,12 +1285,19 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! series for log(1-eps/1+eps) that assumes that |eps| < 0.34. ! Local variables - 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 :: T5((5*HI%isd+1):(5*(HI%ied+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%isd+1):(5*(HI%ied+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: p5((5*HI%isd+1):(5*(HI%ied+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: a5((5*HI%isd+1):(5*(HI%ied+2))) ! Specific volumes anomalies along a line of subgrid + ! locations [R-1 ~> m3 kg-3] + real :: T15((15*HI%isd+1):(15*(HI%ied+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%isd+1):(15*(HI%ied+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: p15((15*HI%isd+1):(15*(HI%ied+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: a15((15*HI%isd+1):(15*(HI%ied+1))) ! Specific volumes at an array of subgrid locations [R ~> kg m-3] real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] + real :: dp_x(5,SZIB_(HI)) ! The pressure change through a layer along an x-line of subgrid locations [Z ~> m] + real :: dp_y(5,SZI_(HI)) ! The pressure change through a layer along a y-line of subgrid locations [Z ~> m] 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] @@ -1178,7 +1309,10 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d ! 5 sub-column locations [L2 T-2 ~> m2 s-2] logical :: do_massWeight ! Indicates whether to do mass weighting. real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] - integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, halo + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state + integer :: Isq, Ieq, Jsq, Jeq, ish, ieh, jsh, jeh, i, j, m, n, pos, halo Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB halo = 0 ; if (present(halo_size)) halo = MAX(halo_size,0) @@ -1195,110 +1329,146 @@ subroutine int_spec_vol_dp_generic_pcm(T, S, p_t, p_b, alpha_ref, HI, EOS, US, d "dP_neglect must be present if useMassWghtInterp is present and true.") endif ; endif - do j=jsh,jeh ; do i=ish,ieh - dp = p_b(i,j) - p_t(i,j) - do n=1,5 - T5(n) = T(i,j) ; S5(n) = S(i,j) - p5(n) = p_b(i,j) - 0.25*real(n-1)*dp + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(ieh-ish+1) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + + do j=jsh,jeh + do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + pos = 5*i + do n=1,5 + T5(pos+n) = T(i,j) ; S5(pos+n) = S(i,j) + p5(pos+n) = p_b(i,j) - 0.25*real(n-1)*dp + enddo enddo - call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + call calculate_spec_vol(T5(5*ish+1:), S5(5*ish+1:), p5(5*ish+1:), a5(5*ish+1:), EOS, & + EOSdom_h5, spv_ref=alpha_ref) - ! Use Boole's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo + do i=ish,ieh + dp = p_b(i,j) - p_t(i,j) + ! Use Boole's rule to estimate the interface height anomaly change. + pos = 5*i + alpha_anom = C1_90*(7.0*(a5(pos+1)+a5(pos+5)) + 32.0*(a5(pos+2)+a5(pos+4)) + 12.0*a5(pos+3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(pos+4)-a5(pos+2)) + 7.0*(a5(pos+5)-a5(pos+1))) ) + 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 + 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 + 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 + pos = i*15+(m-2)*5 - ! T, S, and p are interpolated in the horizontal. The p interpolation - ! is linear, but for T and S it may be thickness weighted. - p5(1) = wt_L*p_b(i,j) + wt_R*p_b(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)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p15(pos+1) = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + dp_x(m,I) = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i+1,j) - p_t(i+1,j)) + T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i+1,j) + S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i+1,j) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - 0.25*dp + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) - 0.25*dp_x(m,I) + enddo enddo - call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + enddo + + call calculate_spec_vol(T15(15*Isq+1:), S15(15*Isq+1:), p15(15*Isq+1:), & + a15(15*Isq+1:), EOS, EOSdom_q15, spv_ref=alpha_ref) - ! Use Boole's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) + do I=Isq,Ieq + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + ! Use Boole's rule to estimate the interface height anomaly change. + do m=2,4 + pos = i*15+(m-2)*5 + intp(m) = dp_x(m,I)*( C1_90*(7.0*(a15(pos+1)+a15(pos+5)) + 32.0*(a15(pos+2)+a15(pos+4)) + & + 12.0*a15(pos+3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) enddo - ! Use Boole's rule to integrate the interface height anomaly values in x. - 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 + 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 + 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 + + 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 + pos = i*15+(m-2)*5 - 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. - p5(1) = wt_L*p_b(i,j) + wt_R*p_b(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)) - T5(1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) - S5(1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) - do n=2,5 - T5(n) = T5(1) ; S5(n) = S5(1) ; p5(n) = p5(n-1) - 0.25*dp + ! T, S, and p are interpolated in the horizontal. The p interpolation + ! is linear, but for T and S it may be thickness weighted. + p15(pos+1) = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + dp_y(m,i) = wt_L*(p_b(i,j) - p_t(i,j)) + wt_R*(p_b(i,j+1) - p_t(i,j+1)) + T15(pos+1) = wtT_L*T(i,j) + wtT_R*T(i,j+1) + S15(pos+1) = wtT_L*S(i,j) + wtT_R*S(i,j+1) + do n=2,5 + T15(pos+n) = T15(pos+1) ; S15(pos+n) = S15(pos+1) + p15(pos+n) = p15(pos+n-1) - 0.25*dp_y(m,i) + enddo enddo - call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) + enddo + + call calculate_spec_vol(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + a15(15*HI%isc+1:), EOS, EOSdom_h15, spv_ref=alpha_ref) + + do i=HI%isc,HI%iec - ! Use Boole's rule to estimate the interface height anomaly change. - intp(m) = dp*( C1_90*(7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4)) + & - 12.0*a5(3))) + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + ! Use Boole's rule to estimate the interface height anomaly change. + do m=2,4 + pos = i*15+(m-2)*5 + intp(m) = dp_y(m,i)*( C1_90*(7.0*(a15(pos+1)+a15(pos+5)) + 32.0*(a15(pos+2)+a15(pos+4)) + & + 12.0*a15(pos+3))) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in y. + inty_dza(i,j) = C1_90*(7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4)) + & + 12.0*intp(3)) enddo - ! Use Boole's rule to integrate the interface height anomaly values in y. - 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 + enddo ; endif end subroutine int_spec_vol_dp_generic_pcm @@ -1358,14 +1528,15 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 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. - 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 :: T15(15) ! Temperatures at fifteen interior quadrature points [C ~> degC] - real :: S15(15) ! Salinities at fifteen interior quadrature points [S ~> ppt] - real :: p15(15) ! Pressures at fifteen quadrature points [R L2 T-2 ~> Pa] - real :: a15(15) ! Specific volumes at fifteen quadrature points [R-1 ~> m3 kg-1] + real :: T5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Temperatures along a line of subgrid locations [C ~> degC] + real :: S5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Salinities along a line of subgrid locations [S ~> ppt] + real :: p5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Pressures along a line of subgrid locations [R L2 T-2 ~> Pa] + real :: a5((5*HI%iscB+1):(5*(HI%iecB+2))) ! Specific volumes anomalies along a line of subgrid + ! locations [R-1 ~> m3 kg-3] + real :: T15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Temperatures at an array of subgrid locations [C ~> degC] + real :: S15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Salinities at an array of subgrid locations [S ~> ppt] + real :: p15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Pressures at an array of subgrid locations [R L2 T-2 ~> Pa] + real :: a15((15*HI%iscB+1):(15*(HI%iecB+1))) ! Specific volumes at an array of subgrid locations [R ~> kg m-3] real :: wt_t(5), wt_b(5) ! Weights of top and bottom values at quadrature points [nondim] real :: T_top, T_bot ! Horizontally interpolated temperature at the cell top and bottom [C ~> degC] real :: S_top, S_bot ! Horizontally interpolated salinity at the cell top and bottom [S ~> ppt] @@ -1373,7 +1544,7 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, real :: alpha_anom ! The depth averaged specific density anomaly [R-1 ~> m3 kg-1] real :: dp ! The pressure change through a layer [R L2 T-2 ~> Pa] - real :: dp_90(2:4) ! The pressure change through a layer divided by 90 [R L2 T-2 ~> Pa] + real :: dp_90(2:4,SZIB_(HI)) ! The pressure change through a layer divided by 90 [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] @@ -1385,6 +1556,9 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, ! 5 sub-column locations [L2 T-2 ~> m2 s-2] real, parameter :: C1_90 = 1.0/90.0 ! A rational constant [nondim] logical :: do_massWeight ! Indicates whether to do mass weighting. + integer, dimension(2) :: EOSdom_h5 ! The 5-point h-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_q15 ! The 3x5-point q-point i-computational domain for the equation of state + integer, dimension(2) :: EOSdom_h15 ! The 3x5-point h-point i-computational domain for the equation of state integer :: Isq, Ieq, Jsq, Jeq, i, j, m, n, pos Isq = HI%IscB ; Ieq = HI%IecB ; Jsq = HI%JscB ; Jeq = HI%JecB @@ -1397,140 +1571,157 @@ subroutine int_spec_vol_dp_generic_plm(T_t, T_b, S_t, S_b, p_t, p_b, alpha_ref, wt_b(n) = 1.0 - wt_t(n) enddo + ! Set the loop ranges for equation of state calculations at various points. + EOSdom_h5(1) = 1 ; EOSdom_h5(2) = 5*(Ieq-Isq+2) + EOSdom_q15(1) = 1 ; EOSdom_q15(2) = 15*(Ieq-Isq+1) + EOSdom_h15(1) = 1 ; EOSdom_h15(2) = 15*(HI%iec-HI%isc+1) + ! 1. Compute vertical integrals - do j=Jsq,Jeq+1 ; do i=Isq,Ieq+1 - dp = p_b(i,j) - p_t(i,j) - do n=1,5 ! T, S and p are linearly interpolated in the vertical. - p5(n) = wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j) - S5(n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) - T5(n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + do j=Jsq,Jeq+1 + do i=Isq,Ieq+1 + do n=1,5 ! T, S and p are linearly interpolated in the vertical. + p5(i*5+n) = wt_t(n) * p_t(i,j) + wt_b(n) * p_b(i,j) + S5(i*5+n) = wt_t(n) * S_t(i,j) + wt_b(n) * S_b(i,j) + T5(i*5+n) = wt_t(n) * T_t(i,j) + wt_b(n) * T_b(i,j) + enddo enddo - call calculate_spec_vol(T5, S5, p5, a5, EOS, spv_ref=alpha_ref) - - ! Use Boole's rule to estimate the interface height anomaly change. - alpha_anom = C1_90*((7.0*(a5(1)+a5(5)) + 32.0*(a5(2)+a5(4))) + 12.0*a5(3)) - dza(i,j) = dp*alpha_anom - ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of - ! the interface height anomaly. - if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & - (alpha_anom - C1_90*(16.0*(a5(4)-a5(2)) + 7.0*(a5(5)-a5(1))) ) - enddo ; enddo + call calculate_spec_vol(T5, S5, p5, a5, EOS, EOSdom_h5, spv_ref=alpha_ref) + do i=Isq,Ieq+1 + ! Use Boole's rule to estimate the interface height anomaly change. + dp = p_b(i,j) - p_t(i,j) + alpha_anom = C1_90*((7.0*(a5(i*5+1)+a5(i*5+5)) + 32.0*(a5(i*5+2)+a5(i*5+4))) + 12.0*a5(i*5+3)) + dza(i,j) = dp*alpha_anom + ! Use a Boole's-rule-like fifth-order accurate estimate of the double integral of + ! the interface height anomaly. + if (present(intp_dza)) intp_dza(i,j) = 0.5*dp**2 * & + (alpha_anom - C1_90*(16.0*(a5(i*5+4)-a5(i*5+2)) + 7.0*(a5(i*5+5)-a5(i*5+1))) ) + enddo + enddo ! 2. Compute horizontal integrals in the x direction - 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, almost like thickness - ! weighting. Note: To work in terrain following coordinates we could - ! offset this distance by the layer thickness to replicate other models. - 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 + 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, almost like thickness + ! weighting. Note: To work in terrain following coordinates we could + ! offset this distance by the layer thickness to replicate other models. + 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 - 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. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + 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. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i+1,j) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i+1,j) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i+1,j) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i+1,j) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i+1,j) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i+1,j) + dp_90(m,I) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = i*15+(m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo enddo enddo - call calculate_spec_vol(T15, S15, p15, a15, EOS, spv_ref=alpha_ref) + call calculate_spec_vol(T15, S15, p15, a15, EOS, EOSdom_q15, spv_ref=alpha_ref) - intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) - do m=2,4 - ! Use Boole's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m)*((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + do I=Isq,Ieq + intp(1) = dza(i,j) ; intp(5) = dza(i+1,j) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = I*15+(m-2)*5 + intp(m) = dp_90(m,I)*((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + intx_dza(I,j) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) enddo - ! Use Boole's rule to integrate the interface height anomaly values in x. - 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 + enddo ; endif ! 3. Compute horizontal integrals in the y direction - 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, like 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 + 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, like 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 - 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. - P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) - P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) - T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) - T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) - S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) - S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) - dp_90(m) = C1_90*(P_bot - P_top) - - ! Salinity, temperature and pressure with linear interpolation in the vertical. - pos = (m-2)*5 - do n=1,5 - p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot - S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot - T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + 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. + P_top = wt_L*p_t(i,j) + wt_R*p_t(i,j+1) + P_bot = wt_L*p_b(i,j) + wt_R*p_b(i,j+1) + T_top = wtT_L*T_t(i,j) + wtT_R*T_t(i,j+1) + T_bot = wtT_L*T_b(i,j) + wtT_R*T_b(i,j+1) + S_top = wtT_L*S_t(i,j) + wtT_R*S_t(i,j+1) + S_bot = wtT_L*S_b(i,j) + wtT_R*S_b(i,j+1) + dp_90(m,i) = C1_90*(P_bot - P_top) + + ! Salinity, temperature and pressure with linear interpolation in the vertical. + pos = i*15+(m-2)*5 + do n=1,5 + p15(pos+n) = wt_t(n) * P_top + wt_b(n) * P_bot + S15(pos+n) = wt_t(n) * S_top + wt_b(n) * S_bot + T15(pos+n) = wt_t(n) * T_top + wt_b(n) * T_bot + enddo enddo enddo - call calculate_spec_vol(T15, S15, p15, a15, EOS, spv_ref=alpha_ref) + call calculate_spec_vol(T15(15*HI%isc+1:), S15(15*HI%isc+1:), p15(15*HI%isc+1:), & + a15(15*HI%isc+1:), EOS, EOSdom_h15, spv_ref=alpha_ref) - intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) - do m=2,4 - ! Use Boole's rule to estimate the interface height anomaly change. - ! The integrals at the ends of the segment are already known. - pos = (m-2)*5 - intp(m) = dp_90(m) * ((7.0*(a15(pos+1)+a15(pos+5)) + & - 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + do i=HI%isc,HI%iec + intp(1) = dza(i,j) ; intp(5) = dza(i,j+1) + do m=2,4 + ! Use Boole's rule to estimate the interface height anomaly change. + ! The integrals at the ends of the segment are already known. + pos = i*15+(m-2)*5 + intp(m) = dp_90(m,i) * ((7.0*(a15(pos+1)+a15(pos+5)) + & + 32.0*(a15(pos+2)+a15(pos+4))) + 12.0*a15(pos+3)) + enddo + ! Use Boole's rule to integrate the interface height anomaly values in x. + inty_dza(i,J) = C1_90*((7.0*(intp(1)+intp(5)) + 32.0*(intp(2)+intp(4))) + & + 12.0*intp(3)) enddo - ! Use Boole's rule to integrate the interface height anomaly values in x. - 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 + enddo ; endif end subroutine int_spec_vol_dp_generic_plm From 25989ad0b8e6cb3aeb52fe0bc387aefa352afe32 Mon Sep 17 00:00:00 2001 From: claireyung <61528379+claireyung@users.noreply.github.com> Date: Wed, 1 May 2024 17:47:26 -0700 Subject: [PATCH 587/629] Allow ALE boundary extrapolation behaviour to differ at initialisation and in model run Adds INIT_BOUNDARY_EXTRAP parameter and function, so that REMAP_BOUNDARY_EXTRAP can just be used in the initialisation and not in the model dynamics, as required for an ice shelf in ALE mode. Background: When an ice shelf is initialised in ALE mode, MOM_state_initialization first initialises the ocean thickness and T/S with topography, but without an ice shelf. It then calls the function trim_for_ice, which takes in input of the ice shelf pressure, and in turn calls cut_off_column_top which truncates the columns (and adds vanishing layers) to account for the pressure of the ice depressing the free surface. The output of this is a grid with the ice shelf boundary treated in a ALE z-coordinate fashion with vanishing layers at the surface, and @adcroft's upcoming changes will make T and S consistent to the grid. However, after adding the ice shelf, we still need to regrid and remap onto our desired ALE coordinate, for example sigma coordinates. This can be done with regrid_accelerate in MOM_state_initialization or by the block controlled by REMAP_AFTER_INITIALIZATION in MOM.F90 We want the initialisation to use boundary extrapolation in the remapping so that the boundary cells preserve the desired initialisation profile when remapped to their target coordinate. This is controlled by REMAP_BOUNDARY_EXTRAP, except this runtime parameter modifies the control structure for the dynamic part of the model run too, which is bad because it means extrema are not preserved in the ALE remapping and can lead to non-sensible values of tracers. Changes: * Added runtime parameter INIT_BOUNDARY_EXTRAP and set the ALE control structure to use that instead of REMAP_BOUNDARY_EXTRAP at first. The default of INIT_BOUNDARY_EXTRAP is REMAP_BOUNDARY_EXTRAP to preserve answers (though it is not recommended to use REMAP_BOUNDARY_EXTRAP during model dynamics...) * After ALE regrid/remap in MOM.F90 (final initialisation step using ALE), reset the boundary extrapolation flag in the ALE control structure to go back to REMAP_BOUNDARY_EXTRAP. This PR combined with @adcroft's upcoming changes should make the initialisation of the ocean thickness and TS in an ALE ice shelf cavity perfect, when the new flag INIT_BOUNDARY_EXTRAP = True and old flag REMAP_BOUNDARY_EXTRAP = False. --- src/ALE/MOM_ALE.F90 | 24 +++++++++++++++++++++--- src/core/MOM.F90 | 8 ++++++-- 2 files changed, 27 insertions(+), 5 deletions(-) diff --git a/src/ALE/MOM_ALE.F90 b/src/ALE/MOM_ALE.F90 index 543d77a0f3..a083402fde 100644 --- a/src/ALE/MOM_ALE.F90 +++ b/src/ALE/MOM_ALE.F90 @@ -40,7 +40,7 @@ module MOM_ALE use MOM_remapping, only : remapping_core_h, remapping_core_w use MOM_remapping, only : remappingSchemesDoc, remappingDefaultScheme use MOM_remapping, only : interpolate_column, reintegrate_column -use MOM_remapping, only : remapping_CS, dzFromH1H2 +use MOM_remapping, only : remapping_CS, dzFromH1H2, remapping_set_param use MOM_string_functions, only : uppercase, extractWord, extract_integer use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chkinv use MOM_unit_scaling, only : unit_scale_type @@ -147,6 +147,7 @@ module MOM_ALE public pre_ALE_adjustments public ALE_remap_init_conds public ALE_register_diags +public ALE_set_extrap_boundaries ! 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 @@ -176,6 +177,7 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) logical :: force_bounds_in_subcell logical :: local_logical logical :: remap_boundary_extrap + logical :: init_boundary_extrap type(hybgen_regrid_CS), pointer :: hybgen_regridCS => NULL() ! Control structure for hybgen regridding ! for sharing parameters. @@ -225,6 +227,10 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) call get_param(param_file, mdl, "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & "If true, values at the interfaces of boundary cells are "//& "extrapolated instead of piecewise constant", default=.false.) + call get_param(param_file, mdl, "INIT_BOUNDARY_EXTRAP", init_boundary_extrap, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant during initialization."//& + "Defaults to REMAP_BOUNDARY_EXTRAP.", default=remap_boundary_extrap) call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & "This sets the default value for the various _ANSWER_DATE parameters.", & default=99991231) @@ -237,13 +243,13 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) if (.not.GV%Boussinesq) CS%answer_date = max(CS%answer_date, 20230701) call initialize_remapping( CS%remapCS, string, & - boundary_extrapolation=remap_boundary_extrap, & + boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & answer_date=CS%answer_date) call initialize_remapping( CS%vel_remapCS, vel_string, & - boundary_extrapolation=remap_boundary_extrap, & + boundary_extrapolation=init_boundary_extrap, & check_reconstruction=check_reconstruction, & check_remapping=check_remapping, & force_bounds_in_subcell=force_bounds_in_subcell, & @@ -308,6 +314,18 @@ subroutine ALE_init( param_file, GV, US, max_depth, CS) if (CS%show_call_tree) call callTree_leave("ALE_init()") end subroutine ALE_init +!> Sets the boundary extrapolation set for the remapping type. +subroutine ALE_set_extrap_boundaries( param_file, CS) + type(param_file_type), intent(in) :: param_file !< Parameter file + type(ALE_CS), pointer :: CS !< Module control structure + + logical :: remap_boundary_extrap + call get_param(param_file, "MOM_ALE", "REMAP_BOUNDARY_EXTRAP", remap_boundary_extrap, & + "If true, values at the interfaces of boundary cells are "//& + "extrapolated instead of piecewise constant", default=.false.) + call remapping_set_param(CS%remapCS, boundary_extrapolation=remap_boundary_extrap) +end subroutine ALE_set_extrap_boundaries + !> Initialize diagnostics for the ALE module. subroutine ALE_register_diags(Time, G, GV, US, diag, CS) type(time_type),target, intent(in) :: Time !< Time structure diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 9dbf7ec3c6..fb53c638db 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -56,6 +56,7 @@ module MOM use MOM_ALE, only : ALE_remap_tracers, ALE_remap_velocities use MOM_ALE, only : ALE_remap_set_h_vel, ALE_remap_set_h_vel_via_dz use MOM_ALE, only : ALE_update_regrid_weights, pre_ALE_diagnostics, ALE_register_diags +use MOM_ALE, only : ALE_set_extrap_boundaries use MOM_ALE_sponge, only : rotate_ALE_sponge, update_ALE_sponge_field use MOM_barotropic, only : Barotropic_CS use MOM_boundary_update, only : call_OBC_register, OBC_register_end, update_OBC_CS @@ -3120,8 +3121,11 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & endif endif endif - if ( CS%use_ALE_algorithm ) call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) - + if ( CS%use_ALE_algorithm ) then + call ALE_set_extrap_boundaries (param_file, CS%ALE_CSp) + call callTree_waypoint("returned from ALE_init() (initialize_MOM)") + call ALE_updateVerticalGridType( CS%ALE_CSp, GV ) + endif ! The basic state variables have now been fully initialized, so update their halos and ! calculate any derived thermodynmics quantities. From 46fd6e6d658e5eee8d9166e4bf039254fcc70edb Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 20 Apr 2024 08:19:39 -0400 Subject: [PATCH 588/629] +Rotationally symmetric KPP_smooth_BLD option Added the option of using rotationally symmetric expressions in KPP_smooth_BLD(). This is enabled by setting the new runtime parameter KPP%ANSWER_DATE to a value of 20240501 or higher. For now the default is to use the older symmetry-breaking expressions, but the default value for KPP%ANSWER_DATE should be revised to use DEFAULT_ANSWER_DATE. By default, all answers are bitwise identical but there is a new entry in some MOM_parameter_doc files. --- .../vertical/MOM_CVMix_KPP.F90 | 31 ++++++++++++++++--- 1 file changed, 26 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 index 8e95edd563..f480c655d7 100644 --- a/src/parameterizations/vertical/MOM_CVMix_KPP.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_KPP.F90 @@ -119,6 +119,10 @@ module MOM_CVMix_KPP !! enhancement with KPP [Z ~> m] logical :: STOKES_MIXING !< Flag if model is mixing down Stokes gradient !! This is relevant for which current to use in RiB + integer :: answer_date !< The vintage of the order of arithmetic in the CVMix KPP + !! calculations. Values below 20240501 recover the answers + !! from early in 2024, while higher values use expressions + !! that have been refactored for rotational symmetry. !> CVMix parameters type(CVMix_kpp_params_type), pointer :: KPP_params => NULL() @@ -199,6 +203,7 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) character(len=20) :: langmuir_mixing_opt = 'NONE' !< Langmuir mixing option to be passed to CVMix, e.g., LWF16 character(len=20) :: langmuir_entrainment_opt = 'NONE' !< Langmuir entrainment option to be !! passed to CVMix, e.g., LWF16 + integer :: default_answer_date ! The default setting for the various ANSWER_DATE flags. logical :: CS_IS_ONE=.false. !< Logical for setting Cs based on Non-local logical :: lnoDGat1=.false. !< True => G'(1) = 0 (shape function) !! False => compute G'(1) as in LMD94 @@ -217,6 +222,10 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) if (.not. KPP_init) return allocate(CS) + call get_param(paramFile, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call openParameterBlock(paramFile,'KPP') call get_param(paramFile, mdl, 'PASSIVE', CS%passiveMode, & 'If True, puts KPP into a passive-diagnostic mode.', & @@ -471,6 +480,12 @@ logical function KPP_init(paramFile, G, GV, US, diag, Time, CS, passive) units="m", default=1.0, scale=US%m_to_Z) endif + call get_param(paramFile, mdl, "ANSWER_DATE", CS%answer_date, & + "The vintage of the order of arithmetic in the CVMix KPP calculations. Values "//& + "below 20240501 recover the answers from early in 2024, while higher values "//& + "use expressions that have been refactored for rotational symmetry.", & + default=20240101) !### Change to: default=default_answer_date) + call closeParameterBlock(paramFile) call get_param(paramFile, mdl, 'DEBUG', CS%debug, default=.False., do_not_log=.True.) @@ -1390,11 +1405,17 @@ subroutine KPP_smooth_BLD(CS, G, GV, US, dz) wn = 0.125 * G%mask2dT(i,j+1) wc = 1.0 - (ww+we+wn+ws) - CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & - + ww * OBLdepth_prev(i-1,j) & - + we * OBLdepth_prev(i+1,j) & - + ws * OBLdepth_prev(i,j-1) & - + wn * OBLdepth_prev(i,j+1) + if (CS%answer_date < 20240501) then + CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ww * OBLdepth_prev(i-1,j) & + + we * OBLdepth_prev(i+1,j) & + + ws * OBLdepth_prev(i,j-1) & + + wn * OBLdepth_prev(i,j+1) + else + CS%OBLdepth(i,j) = wc * OBLdepth_prev(i,j) & + + ((ww * OBLdepth_prev(i-1,j) + we * OBLdepth_prev(i+1,j)) & + + (ws * OBLdepth_prev(i,j-1) + wn * OBLdepth_prev(i,j+1))) + endif ! Apply OBLdepth smoothing at a cell only if the OBLdepth gets deeper via smoothing. if (CS%deepen_only) CS%OBLdepth(i,j) = max(CS%OBLdepth(i,j), OBLdepth_prev(i,j)) From a3e9e1c9d7f2c263a802564077a133f8a78b30a1 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 20 Apr 2024 07:08:15 -0400 Subject: [PATCH 589/629] (*)Revise 13 diagnostics for rotational symmetry Refactored 10 diagnostics related to terms in the kinetic energy budgets and 2 diagnostics of nonlinear relative-vorticity related accelerations to respect rotational symmetry. These diagnostics are mathematically equivalent but will change at roundoff due to changes in the order of arithmetic. Only diagnostics are changed, and the solutions themselves are bitwise identical in all cases. --- src/core/MOM_CoriolisAdv.F90 | 16 +++++++-------- src/diagnostics/MOM_diagnostics.F90 | 20 +++++++++---------- .../lateral/MOM_Zanna_Bolton.F90 | 4 ++-- 3 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/core/MOM_CoriolisAdv.F90 b/src/core/MOM_CoriolisAdv.F90 index 056b171ba8..00a289ab9a 100644 --- a/src/core/MOM_CoriolisAdv.F90 +++ b/src/core/MOM_CoriolisAdv.F90 @@ -902,20 +902,20 @@ subroutine CorAdCalc(u, v, h, uh, vh, CAu, CAv, OBC, AD, G, GV, US, CS, pbv, Wav if (associated(AD%rv_x_u)) then do J=Jsq,Jeq ; do i=is,ie AD%rv_x_u(i,J,k) = -G%IdyCv(i,J) * C1_12 * & - ((q2(I,J) + q2(I-1,J) + q2(I-1,J-1)) * uh(I-1,j,k) + & - (q2(I-1,J) + q2(I,J) + q2(I,J-1)) * uh(I,j,k) + & - (q2(I-1,J) + q2(I,J+1) + q2(I,J)) * uh(I,j+1,k) + & - (q2(I,J) + q2(I-1,J+1) + q2(I-1,J)) * uh(I-1,j+1,k)) + (((((q2(I,J) + q2(I-1,J-1)) + q2(I-1,J)) * uh(I-1,j,k)) + & + (((q2(I-1,J) + q2(I,J+1)) + q2(I,J)) * uh(I,j+1,k))) + & + ((((q2(I-1,J) + q2(I,J-1)) + q2(I,J)) * uh(I,j,k))+ & + (((q2(I,J) + q2(I-1,J+1)) + q2(I-1,J)) * uh(I-1,j+1,k)))) enddo ; enddo endif if (associated(AD%rv_x_v)) then do j=js,je ; do I=Isq,Ieq AD%rv_x_v(I,j,k) = G%IdxCu(I,j) * C1_12 * & - ((q2(I+1,J) + q2(I,J) + q2(I,J-1)) * vh(i+1,J,k) + & - (q2(I-1,J) + q2(I,J) + q2(I,J-1)) * vh(i,J,k) + & - (q2(I-1,J-1) + q2(I,J) + q2(I,J-1)) * vh(i,J-1,k) + & - (q2(I+1,J-1) + q2(I,J) + q2(I,J-1)) * vh(i+1,J-1,k)) + (((((q2(I+1,J) + q2(I,J-1)) + q2(I,J)) * vh(i+1,J,k)) + & + (((q2(I-1,J-1) + q2(I,J)) + q2(I,J-1)) * vh(i,J-1,k))) + & + ((((q2(I-1,J) + q2(I,J-1)) + q2(I,J)) * vh(i,J,k)) + & + (((q2(I+1,J-1) + q2(I,J)) + q2(I,J-1)) * vh(i+1,J-1,k)))) enddo ; enddo endif endif diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index aeb25bc351..167b2e81f3 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -999,7 +999,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_dKEdt, KE_term, CS%diag) @@ -1018,7 +1018,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%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)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo if (CS%id_PE_to_KE > 0) call post_data(CS%id_PE_to_KE, KE_term, CS%diag) @@ -1037,7 +1037,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%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)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_BT, KE_term, CS%diag) @@ -1056,13 +1056,13 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS enddo ; enddo do j=js,je ; do i=is,ie KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & - * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + * ((uh(I,j,k) - uh(I-1,j,k)) + (vh(i,J,k) - vh(i,J-1,k))) enddo ; enddo if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_Coradv, KE_term, CS%diag) @@ -1085,13 +1085,13 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS enddo ; enddo do j=js,je ; do i=is,ie KE_h(i,j) = -KE(i,j,k) * G%IareaT(i,j) & - * (uh(I,j,k) - uh(I-1,j,k) + vh(i,J,k) - vh(i,J-1,k)) + * ((uh(I,j,k) - uh(I-1,j,k)) + (vh(i,J,k) - vh(i,J-1,k))) enddo ; enddo if (.not.G%symmetric) & call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_adv, KE_term, CS%diag) @@ -1110,7 +1110,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%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)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_visc, KE_term, CS%diag) @@ -1167,7 +1167,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%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)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_horvisc, KE_term, CS%diag) @@ -1189,7 +1189,7 @@ subroutine calculate_energy_diagnostics(u, v, h, uh, vh, ADp, CDp, G, GV, US, CS call do_group_pass(CS%pass_KE_uv, G%domain) do j=js,je ; do i=is,ie KE_term(i,j,k) = KE_h(i,j) + 0.5 * G%IareaT(i,j) & - * (KE_u(I,j) + KE_u(I-1,j) + KE_v(i,J) + KE_v(i,J-1)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo call post_data(CS%id_KE_dia, KE_term, CS%diag) diff --git a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 index b49d123377..f472118e7d 100644 --- a/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 +++ b/src/parameterizations/lateral/MOM_Zanna_Bolton.F90 @@ -1083,7 +1083,7 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) 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)) + * ((KE_u(I,j) + KE_u(I-1,j)) + (KE_v(i,J) + KE_v(i,J-1))) enddo ; enddo enddo @@ -1096,4 +1096,4 @@ subroutine compute_energy_source(u, v, h, fx, fy, G, GV, CS) end subroutine compute_energy_source -end module MOM_Zanna_Bolton \ No newline at end of file +end module MOM_Zanna_Bolton From efe1b4a9f038345ba2a799023171034a0046a462 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 5 May 2024 09:47:59 -0400 Subject: [PATCH 590/629] +Fix multiple bugs when MEKE_GM_SRC_ALT is True Fix several bugs when MEKE_GM_SRC_ALT is True, including corrections to two dimensional rescaling factors, and optionally fix a bug that sets a limit only on positive slopes but leaving negative slopes unlimited. This bug is corrected when the new runtime parameter MEKE_GM_SRC_ALT_SLOPE_BUG is false. Additionally there is a new runtime parameter MEKE_GM_SRC_ANSWER_DATE that specifies the use of rotationally symmetric expressions for PE_release_h when it is set to 20240601 or higher, but it should be noted that rotational symmetry also requires that MEKE_GM_SRC_ALT_SLOPE_BUG is false. Four new checksum calls were also added to verify the correctness of the calculation of MEKE%GM_src when MEKE_GM_SRC_ALT and DEBUG are true. By default, all answers are bitwise identical but there are two new runtime parameters in some MOM_parameter_doc files. --- .../lateral/MOM_thickness_diffuse.F90 | 75 ++++++++++++++++--- 1 file changed, 63 insertions(+), 12 deletions(-) diff --git a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 index c510acdf0d..178e6f76e2 100644 --- a/src/parameterizations/lateral/MOM_thickness_diffuse.F90 +++ b/src/parameterizations/lateral/MOM_thickness_diffuse.F90 @@ -82,7 +82,14 @@ module MOM_thickness_diffuse !! used for MEKE [H ~> m or kg m-2]. When the total depth is less !! than this, the diffusivity is scaled away. logical :: GM_src_alt !< If true, use the GM energy conversion form S^2*N^2*kappa rather - !! than the streamfunction for the GM source term. + !! than the streamfunction for the GM source term for MEKE. + integer :: MEKE_src_answer_date !< The vintage of the expressions in the GM energy conversion + !! calculation when MEKE_GM_SRC_ALT is true. Values below 20240601 + !! recover the answers from the original implementation, while higher + !! values use expressions that satisfy rotational symmetry. + logical :: MEKE_src_slope_bug !< If true, use a bug that limits the positive values, but not the + !! negative values, of the slopes used when MEKE_GM_SRC_ALT is true. + !! When this is true, it breaks rotational symmetry. logical :: use_GM_work_bug !< If true, use the incorrect sign for the !! top-level work tendency on the top layer. real :: Stanley_det_coeff !< The coefficient correlating SGS temperature variance with the mean @@ -635,12 +642,12 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV ! interface of a layer that is within a layer [nondim]. 0 m] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & - Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [nondim] + Slope_y_PE, & ! 3D array of neutral slopes at v-points, set equal to Slope (below) [Z L-1 ~> nondim] hN2_y_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency ! at v-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], ! used for calculating the potential energy release real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & - Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [nondim] + Slope_x_PE, & ! 3D array of neutral slopes at u-points, set equal to Slope (below) [Z L-1 ~> nondim] hN2_x_PE ! Harmonic mean of thicknesses around the interfaces times the buoyancy frequency ! at u-points with unit conversion factors [H L2 Z-2 T-2 ~> m s-2 or kg m-2 s-2], ! used for calculating the potential energy release @@ -998,7 +1005,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV int_slope_u(I,j,K) * ((e(i+1,j,K)-e(i,j,K)) * G%IdxCu(I,j)) slope2_Ratio_u(I,K) = (1.0 - int_slope_u(I,j,K)) * slope2_Ratio_u(I,K) - Slope_x_PE(I,j,k) = MIN(Slope,CS%slope_max) + if (CS%MEKE_src_slope_bug) then + Slope_x_PE(I,j,k) = MIN(Slope, CS%slope_max) + else + Slope_x_PE(I,j,k) = Slope + if (Slope > CS%slope_max) Slope_x_PE(I,j,k) = CS%slope_max + if (Slope < -CS%slope_max) Slope_x_PE(I,j,k) = -CS%slope_max + endif if (CS%id_slope_x > 0) CS%diagSlopeX(I,j,k) = Slope ! Estimate the streamfunction at each interface [H L2 T-1 ~> m3 s-1 or kg s-1]. @@ -1313,7 +1326,13 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV int_slope_v(i,J,K) * ((e(i,j+1,K)-e(i,j,K)) * G%IdyCv(i,J)) slope2_Ratio_v(i,K) = (1.0 - int_slope_v(i,J,K)) * slope2_Ratio_v(i,K) - Slope_y_PE(i,J,k) = MIN(Slope,CS%slope_max) + if (CS%MEKE_src_slope_bug) then + Slope_y_PE(i,J,k) = MIN(Slope, CS%slope_max) + else + Slope_y_PE(i,J,k) = Slope + if (Slope > CS%slope_max) Slope_y_PE(i,J,k) = CS%slope_max + if (Slope < -CS%slope_max) Slope_y_PE(i,J,k) = -CS%slope_max + endif if (CS%id_slope_y > 0) CS%diagSlopeY(I,j,k) = Slope Sfn_unlim_v(i,K) = -((KH_v(i,J,K)*G%dx_Cv(i,J))*Slope) @@ -1550,14 +1569,33 @@ subroutine thickness_diffuse_full(h, e, Kh_u, Kh_v, tv, uhD, vhD, cg1, dt, G, GV enddo ; enddo ; endif if (find_work .and. CS%GM_src_alt) then ; if (allocated(MEKE%GM_src)) then - do j=js,je ; do i=is,ie ; do k=nz,1,-1 - PE_release_h = -0.25 * (GV%H_to_RZ*US%L_to_Z**2) * & + if (CS%MEKE_src_answer_date >= 20240601) then + do j=js,je ; do i=is,ie ; do k=nz,1,-1 + PE_release_h = -0.25 * GV%H_to_RZ * & + ( (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & + Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k)) + & + (Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & + Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) ) + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h + enddo ; enddo ; enddo + else + do j=js,je ; do i=is,ie ; do k=nz,1,-1 + PE_release_h = -0.25 * GV%H_to_RZ * & (KH_u(I,j,k)*(Slope_x_PE(I,j,k)**2) * hN2_x_PE(I,j,k) + & Kh_u(I-1,j,k)*(Slope_x_PE(I-1,j,k)**2) * hN2_x_PE(I-1,j,k) + & Kh_v(i,J,k)*(Slope_y_PE(i,J,k)**2) * hN2_y_PE(i,J,k) + & Kh_v(i,J-1,k)*(Slope_y_PE(i,J-1,k)**2) * hN2_y_PE(i,J-1,k)) - MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h - enddo ; enddo ; enddo + MEKE%GM_src(i,j) = MEKE%GM_src(i,j) + PE_release_h + enddo ; enddo ; enddo + endif + if (CS%debug) then + call hchksum(MEKE%GM_src, 'MEKE%GM_src', G%HI, scale=US%RZ3_T3_to_W_m2*US%L_to_Z**2) + call uvchksum("KH_[uv]", Kh_u, Kh_v, G%HI, scale=US%L_to_m**2*US%s_to_T, & + scalar_pair=.true.) + call uvchksum("Slope_[xy]_PE", Slope_x_PE, Slope_y_PE, G%HI, scale=US%Z_to_L) + call uvchksum("hN2_[xy]_PE", hN2_x_PE, hN2_y_PE, G%HI, scale=GV%H_to_mks*US%L_to_Z**2*US%s_to_T**2, & + scalar_pair=.true.) + endif endif ; endif if (CS%id_slope_x > 0) call post_data(CS%id_slope_x, CS%diagSlopeX, CS%diag) @@ -2224,9 +2262,25 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "If true, write out verbose debugging data.", & default=.false., debuggingParam=.true.) + call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & + "This sets the default value for the various _ANSWER_DATE parameters.", & + default=99991231, do_not_log=.true.) + call get_param(param_file, mdl, "MEKE_GM_SRC_ALT", CS%GM_src_alt, & "If true, use the GM energy conversion form S^2*N^2*kappa rather "//& "than the streamfunction for the GM source term.", default=.false.) + call get_param(param_file, mdl, "MEKE_GM_SRC_ANSWER_DATE", CS%MEKE_src_answer_date, & + "The vintage of the expressions in the GM energy conversion calculation when "//& + "MEKE_GM_SRC_ALT is true. Values below 20240601 recover the answers from the "//& + "original implementation, while higher values use expressions that satisfy "//& + "rotational symmetry.", & + default=20240101, do_not_log=.not.CS%GM_src_alt) ! ### Change default to default_answer_date. + call get_param(param_file, mdl, "MEKE_GM_SRC_ALT_SLOPE_BUG", CS%MEKE_src_slope_bug, & + "If true, use a bug that limits the positive values, but not the negative values, "//& + "of the slopes used when MEKE_GM_SRC_ALT is true. When this is true, it breaks "//& + "all of the symmetry rules that MOM6 is supposed to obey.", & + default=.true., do_not_log=.not.CS%GM_src_alt) ! ### Change default to False. + call get_param(param_file, mdl, "MEKE_GEOMETRIC", CS%MEKE_GEOMETRIC, & "If true, uses the GM coefficient formulation from the GEOMETRIC "//& "framework (Marshall et al., 2012).", default=.false.) @@ -2238,9 +2292,6 @@ subroutine thickness_diffuse_init(Time, G, GV, US, param_file, diag, CDp, CS) "The nondimensional coefficient governing the efficiency of the GEOMETRIC "//& "thickness diffusion.", units="nondim", default=0.05) - call get_param(param_file, mdl, "DEFAULT_ANSWER_DATE", default_answer_date, & - "This sets the default value for the various _ANSWER_DATE parameters.", & - default=99991231) call get_param(param_file, mdl, "MEKE_GEOMETRIC_ANSWER_DATE", CS%MEKE_GEOM_answer_date, & "The vintage of the expressions in the MEKE_GEOMETRIC calculation. "//& "Values below 20190101 recover the answers from the original implementation, "//& From a200f5f3b31f2e2d1ee69880ace46b2c876c7e57 Mon Sep 17 00:00:00 2001 From: alex-huth Date: Fri, 3 May 2024 17:42:54 -0400 Subject: [PATCH 591/629] Added missing values for vector u2_bg(:) within set_viscous_ML Vector u2_bg(:) was introduced in commit 6c44c5f38 (Fix for using tidal amplitude in determining the BBL thickness, 2024-04-04). It replaces a scalar in set_viscous_ML, but was not defined, causing crashes. This commit sets the values of u2_bg(:) to match those given given in set_viscous_BBL. --- .../vertical/MOM_set_viscosity.F90 | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e16a57d970..c103cbc71b 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2265,6 +2265,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.CS%linear_drag) then v_at_u = set_v_at_u(v, h, G, GV, i, j, k, mask_v, OBC) + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + u2_bg(I) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i+1,j)*(CS%tideamp(i+1,j)*CS%tideamp(i+1,j)) ) + else + u2_bg(I) = CS%drag_bg_vel * CS%drag_bg_vel + endif hutot = hutot + hweight * sqrt(u(I,j,k)**2 + v_at_u**2 + u2_bg(I)) endif if (use_EOS) then @@ -2537,6 +2544,13 @@ subroutine set_viscous_ML(u, v, h, tv, forces, visc, dt, G, GV, US, CS) if (.not.CS%linear_drag) then u_at_v = set_u_at_v(u, h, G, GV, i, J, k, mask_u, OBC) + ! Set the "back ground" friction velocity scale to either the tidal amplitude or place-holder constant + if (CS%BBL_use_tidal_bg) then + u2_bg(i) = 0.5*( G%mask2dT(i,j)*(CS%tideamp(i,j)*CS%tideamp(i,j))+ & + G%mask2dT(i,j+1)*(CS%tideamp(i,j+1)*CS%tideamp(i,j+1)) ) + else + u2_bg(i) = CS%drag_bg_vel * CS%drag_bg_vel + endif hutot = hutot + hweight * sqrt(v(i,J,k)**2 + u_at_v**2 + u2_bg(i)) endif if (use_EOS) then From 1829b7f4c302e8cd7621cb7936bfc7b6df7cd513 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 7 May 2024 16:36:53 -0400 Subject: [PATCH 592/629] Makedep: Better handling of parentheses The makedep tool was updated to handle parentheses in preprocessor expressions. The expression `#if (defined a)` could not be parsed due to poor ad-hoc handling of parentheses, making it impossible to build the AM2-based coupled models with makedep, The tool has has been significantly overhauled to include better overall unary operator support. * `defined` is now more of an operation than an exception, since it is pushed to the stack like any other operator. * Parentheses are now handled as "operators", with `)` triggering an operator stack push and `(` conducting the actual operation (in this case simply returning the contents). * In order to handle the possibility of macros within parentheses, macros are now evaluated only immediately before used in expressions, rather than the instant they are first encountered. This redesign has allowed for many edge cases to be consolidated into the general purpose parser, greatly simplifying the code. --- ac/makedep | 94 +++++++++++++++++++++++++----------------------------- 1 file changed, 43 insertions(+), 51 deletions(-) diff --git a/ac/makedep b/ac/makedep index 4c9cc9229b..e0d350857e 100755 --- a/ac/makedep +++ b/ac/makedep @@ -34,6 +34,8 @@ re_procedure = re.compile( # Preprocessor expression tokenization +# NOTE: Labels and attributes could be assigned here, but for now we just use +# the token string as the label. cpp_scanner = re.Scanner([ (r'defined', lambda scanner, token: token), (r'[_A-Za-z][_0-9a-zA-Z]*', lambda scanner, token: token), @@ -56,13 +58,15 @@ cpp_scanner = re.Scanner([ (r'&', lambda scanner, token: token), (r'\|\|', lambda scanner, token: token), (r'\|', lambda scanner, token: token), - (r'^\#if', None), + (r'^ *\# *if', None), (r'\s+', None), ]) cpp_operate = { + '(': lambda x: x, '!': lambda x: not x, + 'defined': lambda x, y: x in y, '*': lambda x, y: x * y, '/': lambda x, y: x // y, '+': lambda x, y: x + y, @@ -85,6 +89,7 @@ cpp_operate = { cpp_op_rank = { '(': 13, '!': 12, + 'defined': 12, '*': 11, '/': 11, '+': 10, @@ -527,7 +532,7 @@ def cpp_expr_eval(expr, macros=None): if macros is None: macros = {} - results, remainder = cpp_scanner.scan(expr) + results, remainder = cpp_scanner.scan(expr.strip()) # Abort if any characters are not tokenized if remainder: @@ -545,72 +550,59 @@ def cpp_expr_eval(expr, macros=None): tokens = iter(results) for tok in tokens: - # Evaluate "defined()" statements - if tok == 'defined': - tok = next(tokens) - - parens = tok == '(' - if parens: - tok = next(tokens) + if tok in cpp_op_rank.keys(): + while cpp_op_rank[tok] <= cpp_op_rank[prior_op]: - # NOTE: Any key in `macros` is considered to be set, even if the - # value is None. - value = tok in macros + # Unary operators are "look ahead" so we always skip them. + # (However, `op` below could be a unary operator.) + if tok in ('!', 'defined', '('): + break - # Negation - while prior_op == '!': + second = stack.pop() op = stack.pop() - assert op == '!' - value = cpp_operate[op](value) - prior_op = stack[-1] if stack else None - - stack.append(value) - if parens: - tok = next(tokens) - assert tok == ')' + if op == '(': + value = second - elif tok.isdigit(): - value = int(tok) - stack.append(value) + elif op == '!': + if isinstance(second, str): + if second.isidentifier(): + second = macros.get(second, '0') + if second.isdigit(): + second = int(second) - elif tok.isidentifier(): - # "Identifiers that are not macros, which are all considered to be - # the number zero." (CPP manual, 4.2.2) - value = macros.get(tok, '0') - if value.isdigit(): - value = int(value) - stack.append(value) + value = cpp_operate[op](second) - elif tok in cpp_op_rank.keys(): - while cpp_op_rank[tok] <= cpp_op_rank[prior_op]: + elif op == 'defined': + value = cpp_operate[op](second, macros) - # Skip unary prefix operators (only '!' at the moment) - if tok == '!': - break + else: + first = stack.pop() - second = stack.pop() - op = stack.pop() - first = stack.pop() + if isinstance(first, str): + if first.isidentifier(): + first = macros.get(first, '0') + if first.isdigit(): + first = int(first) - value = cpp_operate[op](first, second) - prior_op = stack[-1] if stack else None + if isinstance(second, str): + if second.isidentifier(): + second = macros.get(second, '0') + if second.isdigit(): + second = int(second) - if prior_op == '(': - prior_op = None - if tok == ')': - stack.pop() + value = cpp_operate[op](first, second) + prior_op = stack[-1] if stack else None stack.append(value) - if tok == ')': - prior_op = stack[-2] if stack and len(stack) > 1 else None - else: + # The ) "operator" has already been applied, so it can be dropped. + if tok != ')': stack.append(tok) prior_op = tok - if prior_op in ('(',): - prior_op = None + elif tok.isdigit() or tok.isidentifier(): + stack.append(tok) else: print("Unsupported token:", tok) From 93d9bb80f817367a1e578a15c3446d98234a4154 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 28 Jan 2023 06:55:01 -0500 Subject: [PATCH 593/629] +(*)Fix USE_QG_LEITH_VISC = True reproducibility This commit includes a series of changes that get MOM6 to reproduce across processor counts, layouts and restarts when USE_QG_LEITH_VISC = True and also to implement related changes to the QG Leith code to be consistent with not making the Boussinesq approximation when in non-Boussinesq mode. These changes include: - Adding a thermo_var_ptrs and a timestep argument to to the interfaces to horizontal_viscosity, initialize_dyn_split_RK2 and initialize_dyn_split_RK2b - Correcting a bug in the powers of H_subroundoff in the denominators of some expressions for the effective thicknesses associated with interfaces, thereby correcting some dimensionally inconsistencies in these expressions - Adding the new publicly visible routine calc_QG_slopes - Adding the arguments slope_x and slope_y to calc_QG_Leith_viscosity and avoiding the use of the VarMix%slope_[xy] elements in that routine - Using thickness_to_dz to consistently convert layer thicknesses to the vertical distances across layers and provide this as an argument to calc_QG_Leith_viscosity - Determining vertical distances in calculating the vertical derivatives of the slopes consistently with avoiding the Boussinesq approximation when in non-Boussinesq mode - Increasing some loop extents in calc_QG_Leith_viscosity Note that several of the expansions of the halo sizes in updates or in some of the calculations are not necessary if an extra halo update is included for slope_x and slope_y and dz after the calls to calc_QG_slopes and thickness_to_dz in horizontal_viscosity. This extra halo update has also been included in a comment for later reference. This commit includes several changes to publicly visible interfaces, and it will change answers with USE_QG_LEITH_VISC = True (which had previously triggered a fatal error), but answers and output are bitwise identical in other cases. --- src/core/MOM.F90 | 10 +- src/core/MOM_dynamics_split_RK2.F90 | 9 +- src/core/MOM_dynamics_split_RK2b.F90 | 9 +- src/core/MOM_dynamics_unsplit.F90 | 2 +- src/core/MOM_dynamics_unsplit_RK2.F90 | 2 +- .../lateral/MOM_hor_visc.F90 | 68 ++++++----- .../lateral/MOM_lateral_mixing_coeffs.F90 | 108 +++++++++++------- 7 files changed, 127 insertions(+), 81 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index fb53c638db..0b602be944 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3114,10 +3114,10 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & 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_MKS) + call hchksum(CS%h, "Post ALE adjust init cond h", G%HI, haloshift=2, 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) + call hchksum(CS%tv%T, "Post ALE adjust init cond T", G%HI, haloshift=2, scale=US%C_to_degC) + call hchksum(CS%tv%S, "Post ALE adjust init cond S", G%HI, haloshift=2, scale=US%S_to_ppt) endif endif endif @@ -3221,13 +3221,13 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (CS%split) then allocate(eta(SZI_(G),SZJ_(G)), source=0.0) if (CS%use_alt_split) then - call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + call initialize_dyn_split_RK2b(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & G, GV, US, param_file, diag, CS%dyn_split_RK2b_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & CS%visc, dirs, CS%ntrunc, CS%pbv, calc_dtbt=calc_dtbt, cont_stencil=CS%cont_stencil) else - call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%uh, CS%vh, eta, Time, & + call initialize_dyn_split_RK2(CS%u, CS%v, CS%h, CS%tv, CS%uh, CS%vh, eta, Time, & G, GV, US, param_file, diag, CS%dyn_split_RK2_CSp, restart_CSp, & CS%dt, CS%ADp, CS%CDp, MOM_internal_state, CS%VarMix, CS%MEKE, & CS%thickness_diffuse_CSp, CS%OBC, CS%update_OBC_CSp, CS%ALE_CSp, CS%set_visc_CSp, & diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index 0557ec7cd5..a184cf473f 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -840,7 +840,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f 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_MKS) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, 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_MKS*US%L_to_m**2*US%s_to_T) @@ -849,7 +849,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, & - MEKE, Varmix, G, GV, US, CS%hor_visc, & + MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & ADp=CS%ADp, hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call cpu_clock_end(id_clock_horvisc) @@ -1296,7 +1296,7 @@ end subroutine remap_dyn_split_RK2_aux_vars !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. -subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & +subroutine initialize_dyn_split_RK2(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & @@ -1310,6 +1310,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -1518,7 +1519,7 @@ subroutine initialize_dyn_split_RK2(u, v, h, uh, vh, eta, Time, G, GV, US, param if (.not. query_initialized(CS%diffu, "diffu", restart_CS) .or. & .not. query_initialized(CS%diffv, "diffv", restart_CS)) then call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, VarMix, G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, & hu_cont=CS%BT_cont%h_u, hv_cont=CS%BT_cont%h_v) call set_initialized(CS%diffu, "diffu", restart_CS) call set_initialized(CS%diffv, "diffv", restart_CS) diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index 44a0b0bf5c..fa78938477 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -558,7 +558,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & - OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) + tv, dt, OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%AD_pred) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with predictor horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -837,7 +837,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc 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_MKS) + call hchksum(h_av, "Predictor avg h", G%HI, haloshift=2, 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_MKS*US%L_to_m**2*US%s_to_T) @@ -845,7 +845,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! diffu = horizontal viscosity terms (u_av) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, & + call horizontal_viscosity(u_av, v_av, h_av, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt, & OBC=CS%OBC, BT=CS%barotropic_CSp, TD=thickness_diffuse_CSp, ADp=CS%ADp) call cpu_clock_end(id_clock_horvisc) if (showCallTree) call callTree_wayPoint("done with horizontal_viscosity (step_MOM_dyn_split_RK2b)") @@ -1222,7 +1222,7 @@ end subroutine remap_dyn_split_RK2b_aux_vars !> This subroutine initializes all of the variables that are used by this !! dynamic core, including diagnostics and the cpu clocks. -subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, param_file, & +subroutine initialize_dyn_split_RK2b(u, v, h, tv, uh, vh, eta, Time, G, GV, US, param_file, & diag, CS, restart_CS, dt, Accel_diag, Cont_diag, MIS, & VarMix, MEKE, thickness_diffuse_CSp, & OBC, update_OBC_CSp, ALE_CSp, set_visc, & @@ -1236,6 +1236,7 @@ subroutine initialize_dyn_split_RK2b(u, v, h, uh, vh, eta, Time, G, GV, US, para intent(inout) :: v !< merid velocity [L T-1 ~> m s-1] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & intent(inout) :: h !< layer thickness [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Thermodynamic type real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & target, intent(inout) :: uh !< zonal volume/mass transport [H L2 T-1 ~> m3 s-1 or kg s-1] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & diff --git a/src/core/MOM_dynamics_unsplit.F90 b/src/core/MOM_dynamics_unsplit.F90 index f9e4aa0efe..579ddead2d 100644 --- a/src/core/MOM_dynamics_unsplit.F90 +++ b/src/core/MOM_dynamics_unsplit.F90 @@ -263,7 +263,7 @@ subroutine step_MOM_dyn_unsplit(u, v, h, tv, visc, Time_local, dt, forces, & ! diffu = horizontal viscosity terms (u,h) call enable_averages(dt, Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) - call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc) + call horizontal_viscosity(u, v, h, CS%diffu, CS%diffv, MEKE, Varmix, G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) diff --git a/src/core/MOM_dynamics_unsplit_RK2.F90 b/src/core/MOM_dynamics_unsplit_RK2.F90 index 1c589f509c..65b3bdf50e 100644 --- a/src/core/MOM_dynamics_unsplit_RK2.F90 +++ b/src/core/MOM_dynamics_unsplit_RK2.F90 @@ -276,7 +276,7 @@ subroutine step_MOM_dyn_unsplit_RK2(u_in, v_in, h_in, tv, visc, Time_local, dt, call enable_averages(dt,Time_local, CS%diag) call cpu_clock_begin(id_clock_horvisc) call horizontal_viscosity(u_in, v_in, h_in, CS%diffu, CS%diffv, MEKE, VarMix, & - G, GV, US, CS%hor_visc) + G, GV, US, CS%hor_visc, tv, dt) call cpu_clock_end(id_clock_horvisc) call disable_averaging(CS%diag) call pass_vector(CS%diffu, CS%diffv, G%Domain, clock=id_clock_pass) diff --git a/src/parameterizations/lateral/MOM_hor_visc.F90 b/src/parameterizations/lateral/MOM_hor_visc.F90 index ab7a6fa5fc..2eef171bf5 100644 --- a/src/parameterizations/lateral/MOM_hor_visc.F90 +++ b/src/parameterizations/lateral/MOM_hor_visc.F90 @@ -13,7 +13,8 @@ module MOM_hor_visc use MOM_error_handler, only : MOM_error, FATAL, WARNING, is_root_pe use MOM_file_parser, only : get_param, log_version, param_file_type use MOM_grid, only : ocean_grid_type -use MOM_lateral_mixing_coeffs, only : VarMix_CS, calc_QG_Leith_viscosity +use MOM_interface_heights, only : thickness_to_dz +use MOM_lateral_mixing_coeffs, only : VarMix_CS, calc_QG_slopes, calc_QG_Leith_viscosity use MOM_barotropic, only : barotropic_CS, barotropic_get_tav use MOM_thickness_diffuse, only : thickness_diffuse_CS, thickness_diffuse_get_KH use MOM_io, only : MOM_read_data, slasher @@ -22,9 +23,9 @@ module MOM_hor_visc use MOM_open_boundary, only : OBC_DIRECTION_N, OBC_DIRECTION_S, OBC_NONE 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 : ZB2020_lateral_stress, ZB2020_init, ZB2020_end, & - ZB2020_CS, ZB2020_copy_gradient_and_thickness +use MOM_variables, only : accel_diag_ptrs, thermo_var_ptrs +use MOM_Zanna_Bolton, only : ZB2020_lateral_stress, ZB2020_init, ZB2020_end +use MOM_Zanna_Bolton, only : ZB2020_CS, ZB2020_copy_gradient_and_thickness implicit none ; private @@ -237,11 +238,11 @@ module MOM_hor_visc !! !! To work, the following fields must be set outside of the usual !! is:ie range before this subroutine is called: -!! u[is-2:ie+2,js-2:je+2] -!! v[is-2:ie+2,js-2:je+2] -!! h[is-1:ie+1,js-1:je+1] +!! u(is-2:ie+2,js-2:je+2) +!! v(is-2:ie+2,js-2:je+2) +!! h(is-1:ie+1,js-1:je+1) or up to h(is-2:ie+2,js-2:je+2) with some Leith options. subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, & - CS, OBC, BT, TD, ADp, hu_cont, hv_cont) + CS, tv, dt, OBC, BT, TD, ADp, hu_cont, hv_cont) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & @@ -259,12 +260,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, type(MEKE_type), intent(inout) :: MEKE !< MEKE fields !! related to Mesoscale Eddy Kinetic Energy. type(VarMix_CS), intent(inout) :: VarMix !< Variable mixing control structure - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure - type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type - type(barotropic_CS), intent(in), optional :: BT !< Barotropic control structure - type(thickness_diffuse_CS), intent(in), optional :: TD !< Thickness diffusion control structure - type(accel_diag_ptrs), intent(in), optional :: ADp !< Acceleration diagnostics + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(hor_visc_CS), intent(inout) :: CS !< Horizontal viscosity control structure + type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various + !! thermodynamic variables + real, intent(in) :: dt !< Time increment [T ~> s] + type(ocean_OBC_type), optional, pointer :: OBC !< Pointer to an open boundary condition type + type(barotropic_CS), optional, intent(in) :: BT !< Barotropic control structure + type(thickness_diffuse_CS), optional, intent(in) :: TD !< Thickness diffusion control structure + type(accel_diag_ptrs), optional, intent(in) :: ADp !< Acceleration diagnostics real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)), & optional, intent(in) :: hu_cont !< Layer thickness at u-points [H ~> m or kg m-2]. real, dimension(SZI_(G),SZJB_(G),SZK_(GV)), & @@ -341,12 +345,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, GME_coeff_q, & !< GME coeff. at q-points [L2 T-1 ~> m2 s-1] ShSt ! A diagnostic array of shear stress [T-1 ~> s-1]. real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: & - KH_u_GME !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + KH_u_GME, & !< Isopycnal height diffusivities in u-columns [L2 T-1 ~> m2 s-1] + slope_x !< Isopycnal slope in i-direction [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: & - KH_v_GME !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + KH_v_GME, & !< Isopycnal height diffusivities in v-columns [L2 T-1 ~> m2 s-1] + slope_y !< Isopycnal slope in j-direction [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)) :: & Ah_h, & ! biharmonic viscosity at thickness points [L4 T-1 ~> m4 s-1] Kh_h, & ! Laplacian viscosity at thickness points [L2 T-1 ~> m2 s-1] + dz, & ! Height change across layers [Z ~> m] FrictWork, & ! work done by MKE dissipation mechanisms [R L2 T-3 ~> W m-2] FrictWork_GME, & ! work done by GME [R L2 T-3 ~> W m-2] div_xx_h, & ! horizontal divergence [T-1 ~> s-1] @@ -590,6 +597,15 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, call pass_vector(u_smooth, v_smooth, G%Domain) endif + if (CS%use_QG_Leith_visc .and. ((CS%Leith_Kh) .or. (CS%Leith_Ah))) then + call thickness_to_dz(h, tv, dz, G, GV, US, halo_size=2) + ! Calculate isopycnal slopes that will be used for some forms of viscosity. + call calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, VarMix, OBC) + ! If the following halo update is added, the calculations in calc_QG_slopes could work on just + ! the computational domains, and some halo updates outside of this routine could be smaller. + ! call pass_vector(slope_x, slope_y, G%Domain, halo=2) + endif + !$OMP parallel do default(none) & !$OMP shared( & !$OMP CS, G, GV, US, OBC, VarMix, MEKE, u, v, h, & @@ -597,7 +613,7 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, !$OMP is_vort, ie_vort, js_vort, je_vort, & !$OMP is_Kh, ie_Kh, js_Kh, je_Kh, & !$OMP apply_OBC, rescale_Kh, legacy_bound, find_FrictWork, & - !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, & + !$OMP use_MEKE_Ku, use_MEKE_Au, u_smooth, v_smooth, use_cont_huv, slope_x, slope_y, dz, & !$OMP backscat_subround, GME_effic_h, GME_effic_q, & !$OMP h_neglect, h_neglect3, inv_PI3, inv_PI6, & !$OMP diffu, diffv, Kh_h, Kh_q, Ah_h, Ah_q, FrictWork, FrictWork_GME, & @@ -1008,9 +1024,9 @@ subroutine horizontal_viscosity(u, v, h, diffu, diffv, MEKE, VarMix, G, GV, US, (0.5*(vort_xy_dy(I,j) + vort_xy_dy(I,j+1)))**2 ) enddo ; enddo - ! This accumulates terms, some of which are in VarMix, so rescaling can not be done here. - call calc_QG_Leith_viscosity(VarMix, G, GV, US, h, k, div_xx_dx, div_xx_dy, & - vort_xy_dx, vort_xy_dy) + ! This accumulates terms, some of which are in VarMix. + call calc_QG_Leith_viscosity(VarMix, G, GV, US, h, dz, k, div_xx_dx, div_xx_dy, & + slope_x, slope_y, vort_xy_dx, vort_xy_dy) endif @@ -2207,12 +2223,12 @@ subroutine hor_visc_init(Time, G, GV, US, param_file, diag, CS, ADp) call get_param(param_file, mdl, "USE_QG_LEITH_VISC", CS%use_QG_Leith_visc, & "If true, use QG Leith nonlinear eddy viscosity.", & default=.false., do_not_log=.not.(CS%Leith_Kh .or. CS%Leith_Ah) ) - if (CS%use_QG_Leith_visc) then - call MOM_error(FATAL, "USE_QG_LEITH_VISC=True activates code that is a work-in-progress and "//& - "should not be used until a number of bugs are fixed. Specifically it does not "//& - "reproduce across PE count or layout, and may use arrays that have not been properly "//& - "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.") - endif +! if (CS%use_QG_Leith_visc) then +! call MOM_error(FATAL, "USE_QG_LEITH_VISC=True activates code that is a work-in-progress and "//& +! "should not be used until a number of bugs are fixed. Specifically it does not "//& +! "reproduce across PE count or layout, and may use arrays that have not been properly "//& +! "set or allocated. See github.com/mom-ocean/MOM6/issues/1590 for a discussion.") +! endif if (CS%use_QG_Leith_visc .and. .not. (CS%Leith_Kh .or. CS%Leith_Ah) ) then call MOM_error(FATAL, "MOM_hor_visc.F90, hor_visc_init:"//& "LEITH_KH or LEITH_AH must be True when USE_QG_LEITH_VISC=True.") diff --git a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 index 4f1dbb89ac..defbd78aa7 100644 --- a/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 +++ b/src/parameterizations/lateral/MOM_lateral_mixing_coeffs.F90 @@ -170,7 +170,7 @@ module MOM_lateral_mixing_coeffs end type VarMix_CS public VarMix_init, VarMix_end, calc_slope_functions, calc_resoln_function -public calc_QG_Leith_viscosity, calc_depth_function +public calc_QG_slopes, calc_QG_Leith_viscosity, calc_depth_function contains @@ -474,14 +474,13 @@ subroutine calc_slope_functions(h, tv, dt, G, GV, US, CS, OBC) type(VarMix_CS), intent(inout) :: CS !< Variable mixing control structure type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure ! Local variables - real, dimension(SZI_(G), SZJ_(G),SZK_(GV)+1) :: & - e ! The interface heights relative to mean sea level [Z ~> m]. - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] - real, dimension(SZIB_(G), SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] - real, dimension(SZI_(G), SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: N2_u ! Square of Brunt-Vaisala freq at u-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: N2_v ! Square of Brunt-Vaisala freq at v-points [L2 Z-2 T-2 ~> s-2] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzu ! Z-thickness at u-points [Z ~> m] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzv ! Z-thickness at v-points [Z ~> m] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1) :: dzSxN ! |Sx| N times dz at u-points [Z T-1 ~> m s-1] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1) :: dzSyN ! |Sy| N times dz at v-points [Z T-1 ~> m s-1] if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_slope_functions: "//& "Module must be initialized before it is used.") @@ -996,18 +995,47 @@ subroutine calc_slope_functions_using_just_e(h, G, GV, US, CS, e, calculate_slop end subroutine calc_slope_functions_using_just_e + +!> Calculates and returns isopycnal slopes with wider halos for use in finding QG viscosity. +subroutine calc_QG_slopes(h, tv, dt, G, GV, US, slope_x, slope_y, CS, OBC) + 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 + real, intent(in) :: dt !< Time increment [T ~> s] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] + type(VarMix_CS), intent(in) :: CS !< Variable mixing control structure + type(ocean_OBC_type), pointer :: OBC !< Open boundaries control structure + ! Local variables + real, dimension(SZI_(G),SZJ_(G),SZK_(GV)+1) :: e ! The interface heights relative to mean sea level [Z ~> m] + + if (.not. CS%initialized) call MOM_error(FATAL, "MOM_lateral_mixing_coeffs.F90, calc_QG_slopes: "//& + "Module must be initialized before it is used.") + + call find_eta(h, tv, G, GV, US, e, halo_size=3) + call calc_isoneutral_slopes(G, GV, US, h, e, tv, dt*CS%kappa_smooth, CS%use_stanley_iso, & + slope_x, slope_y, halo=2, OBC=OBC) + +end subroutine calc_QG_slopes + !> Calculates the Leith Laplacian and bi-harmonic viscosity coefficients -subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vort_xy_dx, vort_xy_dy) +subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, dz, k, div_xx_dx, div_xx_dy, slope_x, slope_y, & + vort_xy_dx, vort_xy_dy) type(VarMix_CS), intent(inout) :: CS !< Variable mixing coefficients - type(ocean_grid_type), intent(in) :: G !< Ocean grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. - type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< Layer thickness [H ~> m or kg m-2] - integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude - real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence + type(ocean_grid_type), intent(in) :: G !< Ocean grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. + type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + real, dimension(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) :: dz !< Layer vertical extents [Z ~> m] + integer, intent(in) :: k !< Layer for which to calculate vorticity magnitude + real, dimension(SZIB_(G),SZJ_(G)), intent(in) :: div_xx_dx !< x-derivative of horizontal divergence !! (d/dx(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] - real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence + real, dimension(SZI_(G),SZJB_(G)), intent(in) :: div_xx_dy !< y-derivative of horizontal divergence !! (d/dy(du/dx + dv/dy)) [L-1 T-1 ~> m-1 s-1] + real, dimension(SZIB_(G),SZJ_(G),SZK_(GV)+1), intent(inout) :: slope_x !< Isopycnal slope in i-dir [Z L-1 ~> nondim] + real, dimension(SZI_(G),SZJB_(G),SZK_(GV)+1), intent(inout) :: slope_y !< Isopycnal slope in j-dir [Z L-1 ~> nondim] real, dimension(SZI_(G),SZJB_(G)), intent(inout) :: vort_xy_dx !< x-derivative of vertical vorticity !! (d/dx(dv/dx - du/dy)) [L-1 T-1 ~> m-1 s-1] real, dimension(SZIB_(G),SZJ_(G)), intent(inout) :: vort_xy_dy !< y-derivative of vertical vorticity @@ -1030,6 +1058,8 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo real :: h_at_slope_below ! The thickness below [H ~> m or kg m-2] real :: Ih ! The inverse of a combination of thicknesses [H-1 ~> m-1 or m2 kg-1] real :: f ! A copy of the Coriolis parameter [T-1 ~> s-1] + real :: Z_to_H ! A local copy of depth to thickness conversion factors or the inverse of the + ! mass-weighted average specific volumes around an interface [H Z-1 ~> nondim or kg m-3] real :: inv_PI3 ! The inverse of pi cubed [nondim] integer :: i, j, is, ie, js, je, Isq, Ieq, Jsq, Jeq, nz @@ -1038,41 +1068,41 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo nz = GV%ke inv_PI3 = 1.0 / ((4.0*atan(1.0))**3) + Z_to_H = GV%Z_to_H ! This will be replaced with a varying value in non-Boussinesq mode. if ((k > 1) .and. (k < nz)) then - ! With USE_QG_LEITH_VISC=True, this might need to change to - ! do j=js-2,je+2 ; do I=is-2,ie+1 - ! but other arrays used here (e.g., h and CS%slope_x) would also need to have wider valid halos. - do j=js-1,je+1 ; do I=is-2,Ieq+1 + do j=js-2,je+2 ; do I=is-2,ie+1 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) * h(i+1,j,k) ) / & ( ( h(i,j,k-1) * h(i+1,j,k-1) ) * ( h(i,j,k) + h(i+1,j,k) ) & - + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff**2 ) + + ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k-1) + h(i+1,j,k-1) ) + GV%H_subroundoff**3 ) h_at_slope_below = 2. * ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) * h(i+1,j,k+1) ) / & ( ( h(i,j,k) * h(i+1,j,k) ) * ( h(i,j,k+1) + h(i+1,j,k+1) ) & - + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**2 ) - Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) - dslopex_dz(I,j) = 2. * ( CS%slope_x(i,j,k) - CS%slope_x(i,j,k+1) ) * (GV%Z_to_H * Ih) + + ( h(i,j,k+1) * h(i+1,j,k+1) ) * ( h(i,j,k) + h(i+1,j,k) ) + GV%H_subroundoff**3 ) + Ih = 1./ ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + if (.not.GV%Boussinesq) & + Z_to_H = ( (h(i,j,k-1) + h(i+1,j,k-1)) + (h(i,j,k) + h(i+1,j,k)) ) / & + ( (dz(i,j,k-1) + dz(i+1,j,k-1)) + (dz(i,j,k) + dz(i+1,j,k)) + GV%dZ_subroundoff) + dslopex_dz(I,j) = 2. * ( slope_x(I,j,k) - slope_x(I,j,k+1) ) * (Z_to_H * Ih) h_at_u(I,j) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - ! With USE_QG_LEITH_VISC=True, this might need to change to - ! do J=js-2,je+1 ; do i=is-2,ie+2 - do J=js-2,Jeq+1 ; do i=is-1,ie+1 + do J=js-2,je+1 ; do i=is-2,ie+2 h_at_slope_above = 2. * ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) * h(i,j+1,k) ) / & ( ( h(i,j,k-1) * h(i,j+1,k-1) ) * ( h(i,j,k) + h(i,j+1,k) ) & - + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff**2 ) + + ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k-1) + h(i,j+1,k-1) ) + GV%H_subroundoff**3 ) h_at_slope_below = 2. * ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) * h(i,j+1,k+1) ) / & ( ( h(i,j,k) * h(i,j+1,k) ) * ( h(i,j,k+1) + h(i,j+1,k+1) ) & - + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**2 ) - Ih = 1. / ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) - dslopey_dz(i,J) = 2. * ( CS%slope_y(i,j,k) - CS%slope_y(i,j,k+1) ) * (GV%Z_to_H * Ih) + + ( h(i,j,k+1) * h(i,j+1,k+1) ) * ( h(i,j,k) + h(i,j+1,k) ) + GV%H_subroundoff**3 ) + Ih = 1./ ( h_at_slope_above + h_at_slope_below + GV%H_subroundoff ) + if (.not.GV%Boussinesq) & + Z_to_H = ( (h(i,j,k-1) + h(i,j+1,k-1)) + (h(i,j,k) + h(i,j+1,k)) ) / & + ( (dz(i,j,k-1) + dz(i,j+1,k-1)) + (dz(i,j,k) + dz(i,j+1,k)) + GV%dZ_subroundoff) + dslopey_dz(i,J) = 2. * ( slope_y(i,J,k) - slope_y(i,J,k+1) ) * (Z_to_H * Ih) h_at_v(i,J) = 2. * ( h_at_slope_above * h_at_slope_below ) * Ih enddo ; enddo - ! With USE_QG_LEITH_VISC=True, this might need to be - ! do J=js-2,je+1 ; do i=is-1,ie+1 - do J=js-1,je ; do i=is-1,Ieq+1 + do J=js-2,je+1 ; do i=is-1,ie+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I-1,J) ) vort_xy_dx(i,J) = vort_xy_dx(i,J) - f * & ( ( h_at_u(I,j) * dslopex_dz(I,j) + h_at_u(I-1,j+1) * dslopex_dz(I-1,j+1) ) & @@ -1080,9 +1110,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo ( ( h_at_u(I,j) + h_at_u(I-1,j+1) ) + ( h_at_u(I-1,j) + h_at_u(I,j+1) ) + GV%H_subroundoff) enddo ; enddo - ! With USE_QG_LEITH_VISC=True, this might need to be - ! do j=js-1,je+1 ; do I=is-2,ie+1 - do j=js-1,Jeq+1 ; do I=is-1,ie + do j=js-1,je+1 ; do I=is-2,ie+1 f = 0.5 * ( G%CoriolisBu(I,J) + G%CoriolisBu(I,J-1) ) vort_xy_dy(I,j) = vort_xy_dy(I,j) - f * & ( ( h_at_v(i,J) * dslopey_dz(i,J) + h_at_v(i+1,J-1) * dslopey_dz(i+1,J-1) ) & @@ -1100,7 +1128,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo + (div_xx_dy(i+1,J) + div_xx_dy(i,J-1))))**2) if (CS%use_beta_in_QG_Leith) then beta_u(I,j) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i+1,j))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) + (0.5*(G%dF_dy(i,j)+G%dF_dy(i+1,j))**2)) CS%KH_u_QG(I,j,k) = MIN(grad_vort_mag_u(I,j) + grad_div_mag_u(I,j), 3.0*beta_u(I,j)) * & CS%Laplac3_const_u(I,j) * inv_PI3 else @@ -1116,7 +1144,7 @@ subroutine calc_QG_Leith_viscosity(CS, G, GV, US, h, k, div_xx_dx, div_xx_dy, vo + (div_xx_dx(I,j+1) + div_xx_dx(I-1,j))))**2) if (CS%use_beta_in_QG_Leith) then beta_v(i,J) = sqrt((0.5*(G%dF_dx(i,j)+G%dF_dx(i,j+1))**2) + & - (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) + (0.5*(G%dF_dy(i,j)+G%dF_dy(i,j+1))**2)) CS%KH_v_QG(i,J,k) = MIN(grad_vort_mag_v(i,J) + grad_div_mag_v(i,J), 3.0*beta_v(i,J)) * & CS%Laplac3_const_v(i,J) * inv_PI3 else From bb8a6533178533289b92847153ee0612aec1903c Mon Sep 17 00:00:00 2001 From: Kate Hedstrom Date: Mon, 29 Apr 2024 10:42:24 -0800 Subject: [PATCH 594/629] Add diags for east, north velocity components. - This is required for our BOEM-funded Arctic project. It needs something similar for SIS2 as well. --- src/diagnostics/MOM_diagnostics.F90 | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/src/diagnostics/MOM_diagnostics.F90 b/src/diagnostics/MOM_diagnostics.F90 index 167b2e81f3..fd8057c38f 100644 --- a/src/diagnostics/MOM_diagnostics.F90 +++ b/src/diagnostics/MOM_diagnostics.F90 @@ -136,6 +136,7 @@ module MOM_diagnostics integer :: id_sst = -1, id_sst_sq = -1, id_sstcon = -1 integer :: id_sss = -1, id_sss_sq = -1, id_sssabs = -1 integer :: id_ssu = -1, id_ssv = -1 + integer :: id_ssu_east = -1, id_ssv_north = -1 ! Diagnostic IDs for heat and salt flux fields integer :: id_fraz = -1 @@ -1283,6 +1284,8 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) ! Local variables real, dimension(SZI_(G),SZJ_(G)) :: speed ! The surface speed [L T-1 ~> m s-1] + real :: ssu_east(SZI_(G),SZJ_(G)) ! Surface velocity due east component [L T-1 ~> m s-1] + real :: ssv_north(SZI_(G),SZJ_(G)) ! Surface velocity due north component [L T-1 ~> m s-1] integer :: i, j, is, ie, js, je is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec @@ -1304,6 +1307,17 @@ subroutine post_surface_dyn_diags(IDs, G, diag, sfc_state, ssh) call post_data(IDs%id_speed, speed, diag, mask=G%mask2dT) endif + if (IDs%id_ssu_east > 0 .or. IDs%id_ssv_north > 0) then + do j=js,je ; do i=is,ie + ssu_east(i,j) = ((0.5*(sfc_state%u(I-1,j) + sfc_state%u(I,j))) * G%cos_rot(i,j)) + & + ((0.5*(sfc_state%v(i,J-1) + sfc_state%v(i,J))) * G%sin_rot(i,j)) + ssv_north(i,j) = ((0.5*(sfc_state%v(i,J-1) + sfc_state%v(i,J))) * G%cos_rot(i,j)) - & + ((0.5*(sfc_state%u(I-1,j) + sfc_state%u(I,j))) * G%sin_rot(i,j)) + enddo ; enddo + if (IDs%id_ssu_east > 0 ) call post_data(IDs%id_ssu_east, ssu_east, diag, mask=G%mask2dT) + if (IDs%id_ssv_north > 0 ) call post_data(IDs%id_ssv_north, ssv_north, diag, mask=G%mask2dT) + endif + end subroutine post_surface_dyn_diags @@ -1912,6 +1926,10 @@ subroutine register_surface_diags(Time, G, US, IDs, diag, tv) 'Sea Surface Meridional Velocity', 'm s-1', conversion=US%L_T_to_m_s) IDs%id_speed = register_diag_field('ocean_model', 'speed', diag%axesT1, Time, & 'Sea Surface Speed', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_ssu_east = register_diag_field('ocean_model', 'ssu_east', diag%axesT1, Time, & + 'Eastward velocity', 'm s-1', conversion=US%L_T_to_m_s) + IDs%id_ssv_north = register_diag_field('ocean_model', 'ssv_north', diag%axesT1, Time, & + 'Northward velocity', 'm s-1', conversion=US%L_T_to_m_s) if (associated(tv%T)) then IDs%id_sst = register_diag_field('ocean_model', 'SST', diag%axesT1, Time, & From 0c790f2dcb975f0aeae024bc8651cfa4096716cc Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 10 May 2024 15:08:21 -0400 Subject: [PATCH 595/629] SAL: Explicitly allocate sht variable in SAL_CS For reasons not entirely clear, deallocation of the RK2 control structure caused a segmentation fault when compiled by Nvidia. A deeper investigation suggested that the compiler was attempting to deallocate a nullified pointer during automatic cleanup of RK2->SAL->sht. Apparently deallocation of a NULL pointer is an error (even though free() is not supposed to care). By redefining `sht` as an allocatable component rather than a local component of the SAL_CS instance, it seemed to satisfy the compiler that nothing was needed and the error went away. There are still some lingering questions behind the cause of the segfault, but for now I am going to put this under "compiler bug". This patch also initializes some of the logical flags in the SAL_CS type. This is possibly unnecessary, but it is consistent with the general rules of safety followed in other MOM6 derived types. --- .../lateral/MOM_self_attr_load.F90 | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/src/parameterizations/lateral/MOM_self_attr_load.F90 b/src/parameterizations/lateral/MOM_self_attr_load.F90 index 7f7215c9d8..e7f8a73ab2 100644 --- a/src/parameterizations/lateral/MOM_self_attr_load.F90 +++ b/src/parameterizations/lateral/MOM_self_attr_load.F90 @@ -20,14 +20,17 @@ module MOM_self_attr_load !> The control structure for the MOM_self_attr_load module type, public :: SAL_CS ; private - logical :: use_sal_scalar !< If true, use the scalar approximation to calculate SAL. - logical :: use_sal_sht !< If true, use online spherical harmonics to calculate SAL - logical :: use_tidal_sal_prev !< If true, read the tidal SAL from the previous iteration of - !! the tides to facilitate convergence. + logical :: use_sal_scalar = .false. + !< If true, use the scalar approximation to calculate SAL. + logical :: use_sal_sht = .false. + !< If true, use online spherical harmonics to calculate SAL + logical :: use_tidal_sal_prev = .false. + !< If true, read the tidal SAL from the previous iteration of the tides to + !! facilitate convergence. real :: sal_scalar_value !< The constant of proportionality between sea surface height !! (really it should be bottom pressure) anomalies and bottom !! geopotential anomalies [nondim]. - type(sht_CS) :: sht !< Spherical harmonic transforms (SHT) control structure + type(sht_CS), allocatable :: sht !< Spherical harmonic transforms (SHT) control structure integer :: sal_sht_Nd !< Maximum degree for SHT [nodim] real, allocatable :: Love_Scaling(:) !< Love number for each SHT mode [nodim] real, allocatable :: Snm_Re(:), & !< Real SHT coefficient for SHT SAL [Z ~> m] @@ -218,6 +221,8 @@ subroutine SAL_init(G, US, param_file, CS) allocate(CS%Love_Scaling(lmax)); CS%Love_Scaling(:) = 0.0 call calc_love_scaling(CS%sal_sht_Nd, rhoW, rhoE, CS%Love_Scaling) + + allocate(CS%sht) call spherical_harmonics_init(G, param_file, CS%sht) endif @@ -234,6 +239,7 @@ subroutine SAL_end(CS) if (allocated(CS%Snm_Re)) deallocate(CS%Snm_Re) if (allocated(CS%Snm_Im)) deallocate(CS%Snm_Im) call spherical_harmonics_end(CS%sht) + deallocate(CS%sht) endif end subroutine SAL_end From 6272bbcdc670639f9508026da9b85698a3a29257 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 14 May 2024 12:10:19 -0400 Subject: [PATCH 596/629] Testing: Correct perf parsing of C++ output This patch fixes errors in the parser of perf output. Previously, each record was assumed to be separated by spaces, but this failed for more generic records (usually from C++) which included signatures (such as `f(a, b)`) or templates (`f`). Nested constructs were also possible. This is fixed by introducing a simple tokenizer which extracts <, (, and whitespace from the output , then rebuilds the records by combining any whitespace which appears inside of delimiters. This patch should hopefully resolve the CI errors in GitHub Actions. --- .testing/tools/parse_perf.py | 60 +++++++++++++++++++++++++++++++++--- 1 file changed, 55 insertions(+), 5 deletions(-) diff --git a/.testing/tools/parse_perf.py b/.testing/tools/parse_perf.py index 7cbffd995d..76c6be5bcb 100755 --- a/.testing/tools/parse_perf.py +++ b/.testing/tools/parse_perf.py @@ -3,10 +3,20 @@ import collections import json import os +import re import shlex import subprocess import sys +perf_scanner = re.Scanner([ + (r'<', lambda scanner, token: token), + (r'>', lambda scanner, token: token), + (r'\(', lambda scanner, token: token), + (r'\)', lambda scanner, token: token), + (r'[ \t]+', lambda scanner, token: token), + (r'[^<>() \t]+', lambda scanner, token: token), +]) + def main(): desc = 'Parse perf.data and return in JSON format.' @@ -58,15 +68,55 @@ def parse_perf_report(perf_data_path): # get per-symbol count else: + tokens, remainder = perf_scanner.scan(line) + if remainder: + print('Line could not be tokenized', file=sys.stderr) + print(' line:', repr(line), file=sys.stderr) + print(' tokens:', tokens, file=sys.stderr) + print(' remainder:', remainder, file=sys.stderr) + sys.exit(os.EX_DATAERR) + + # Construct record from tokens + # (NOTE: Not a proper grammar, just dumb bracket counting) + record = [] + bracks = 0 + parens = 0 + + for tok in tokens: + if tok == '<': + bracks += 1 + + if tok == '(': + parens += 1 + + rec = record[-1] if record else None + + inside_bracket = rec and (bracks > 0 or parens > 0) + lead_rec = tok in '<(' and rec and not rec.isspace() + tail_rec = not tok.isspace() and rec and rec[-1] in '>)' + + if inside_bracket or lead_rec or tail_rec: + record[-1] += tok + else: + record.append(tok) + + if tok == '>': + bracks -= 1 + if tok == '(': + parens -= 1 + + # Strip any whitespace tokens + record = [rec for rec in record if not rec.isspace()] + try: - tokens = line.split() - symbol = tokens[2] - period = int(tokens[3]) - except ValueError: + symbol = record[2] + period = int(record[3]) + except: print("parse_perf.py: Error extracting symbol count", - file=sys.stderr) + file=sys.stderr) print("line:", repr(line), file=sys.stderr) print("tokens:", tokens, file=sys.stderr) + print("record:", record, file=sys.stderr) raise profile[event_name]['symbol'][symbol] = period From 7a2a33b59d4ec29cad31b779279e9d53856a3ffe Mon Sep 17 00:00:00 2001 From: Alistair Adcroft Date: Sat, 18 May 2024 14:09:06 -0400 Subject: [PATCH 597/629] Use FMS1 for MacOS builds - Given a recent incompatibility with FMS2 and gfortan 14.1 we need to revert to FMS1 for the MacOS builds. --- .github/workflows/macos-regression.yml | 2 ++ .github/workflows/macos-stencil.yml | 2 ++ 2 files changed, 4 insertions(+) diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml index 422c50b68a..5e0380bcd2 100644 --- a/.github/workflows/macos-regression.yml +++ b/.github/workflows/macos-regression.yml @@ -10,6 +10,8 @@ jobs: env: CC: gcc FC: gfortran + FMS_COMMIT: 2019.01.03 + FRAMEWORK: fms1 defaults: run: diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml index 36a5841bb2..e54912b607 100644 --- a/.github/workflows/macos-stencil.yml +++ b/.github/workflows/macos-stencil.yml @@ -10,6 +10,8 @@ jobs: env: CC: gcc FC: gfortran + FMS_COMMIT: 2019.01.03 + FRAMEWORK: fms1 defaults: run: From b32aea7bf3f9e2a774afa23d3386c88156cd1182 Mon Sep 17 00:00:00 2001 From: Daniel Sarmiento <42810219+dpsarmie@users.noreply.github.com> Date: Tue, 21 May 2024 13:46:30 -0400 Subject: [PATCH 598/629] Add end of run restart functionality to MOM6 (#133) * Update mom_cap.F90 to add end of run restart file functionality controlled by write_restart_at_endofrun configuration option in CMEPS. Author: Daniel Sarmient --- config_src/drivers/nuopc_cap/mom_cap.F90 | 23 +++++++++++++++++++++-- 1 file changed, 21 insertions(+), 2 deletions(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index 3574943918..d2dcf96067 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -136,6 +136,7 @@ module MOM_cap_mod logical :: grid_attach_area = .false. logical :: use_coldstart = .true. logical :: use_mommesh = .true. +logical :: restart_eor = .false. character(len=128) :: scalar_field_name = '' integer :: scalar_field_count = 0 integer :: scalar_field_idx_grid_nx = 0 @@ -381,6 +382,12 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) geomtype = ESMF_GEOMTYPE_GRID endif + ! Read end of run restart config option + call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=value, isPresent=isPresent, isSet=isSet, rc=rc) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + if (isPresent .and. isSet) then + if (trim(value) .eq. '.true.') restart_eor = .true. + end if end subroutine @@ -1637,6 +1644,8 @@ subroutine ModelAdvance(gcomp, rc) real(8) :: MPI_Wtime, timers logical :: write_restart logical :: write_restartfh + logical :: write_restart_eor + rc = ESMF_SUCCESS if(profile_memory) call ESMF_VMLogMemInfo("Entering MOM Model_ADVANCE: ") @@ -1776,7 +1785,6 @@ subroutine ModelAdvance(gcomp, rc) !--------------- ! Get the stop alarm !--------------- - call ESMF_ClockGetAlarm(clock, alarmname='stop_alarm', alarm=stop_alarm, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return @@ -1807,7 +1815,18 @@ subroutine ModelAdvance(gcomp, rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return end if - if (write_restart .or. write_restartfh) then + write_restart_eor = .false. + if (restart_eor) then + if (ESMF_AlarmIsRinging(stop_alarm, rc=rc)) then + if (ChkErr(rc,__LINE__,u_FILE_u)) return + write_restart_eor = .true. + ! turn off the alarm + call ESMF_AlarmRingerOff(stop_alarm, rc=rc ) + if (ChkErr(rc,__LINE__,u_FILE_u)) return + end if + end if + + if (write_restart .or. write_restartfh .or. write_restart_eor) then ! determine restart filename call ESMF_ClockGetNextTime(clock, MyTime, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return From 83bc4a66f8ba658a16c651d67992d966a387ca32 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 20 May 2024 10:19:27 -0400 Subject: [PATCH 599/629] GitLab CI: Direct build directory to $HOME This patch directs the compilation of GitLab regression test models to the $HOME directory. This is motivated by incredibly slow file access times on GFDL's GPFS file system (F5), with the Nvidia builds taking a prohibitively long time (around 4 hours). Compiling in $HOME reduces Nvidia times to 15 minutes, with similar reduction times in the other compilation. This is achieved with only minimal changes to the build system. Instead of creating `build/`, we create a dedicated directory in `$HOME/ci/$CI_PROJECT_ID/build` and a symbolic link to this directory in the GPFS directory. To support these builds, additional symlinks to `src/` and `ocean_only/` (for static builds) are also created, from $HOME and back into GPFS. Once the job is completed, the temporary space in $HOME is deleted. This patch should not be considered a permanent solution, it is only meant to get us through a difficult period of testing. Hopefully we can revert this change in the near future. --- .gitlab-ci.yml | 3 +++ .gitlab/pipeline-ci-tool.sh | 7 +++++++ 2 files changed, 10 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 2c4d92c424..55494696ae 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -32,6 +32,8 @@ p:clone: tags: - ncrc5 script: + # NOTE: We could sweep any builds older than 3 days here if needed + #- find $HOME/ci/[0-9]* -mtime +3 -delete 2> /dev/null || true - .gitlab/pipeline-ci-tool.sh create-job-dir #.gitlab/pipeline-ci-tool.sh clean-job-dir @@ -353,4 +355,5 @@ cleanup: before_script: - echo Skipping usual preamble script: + - rm -rf $HOME/ci/$CI_PIPELINE_ID - rm -rf $JOB_DIR diff --git a/.gitlab/pipeline-ci-tool.sh b/.gitlab/pipeline-ci-tool.sh index 77409d29ef..d948b72008 100755 --- a/.gitlab/pipeline-ci-tool.sh +++ b/.gitlab/pipeline-ci-tool.sh @@ -94,6 +94,13 @@ create-job-dir () { make -f tools/MRS/Makefile.clone clone_gfdl -j # Extras and link to datasets bash tools/MRS/generate_manifest.sh . tools/MRS/excluded-expts.txt > manifest.mk mkdir -p results + # Temporarily move build directory to $HOME to circumvent poor F5 performance + mkdir -p $HOME/ci/$CI_PIPELINE_ID/build + ln -s $HOME/ci/$CI_PIPELINE_ID/build build + # Builds need non-mangled access to src/. + ln -s "$(pwd)"/src $HOME/ci/$CI_PIPELINE_ID/src + # Static builds need access to ocean_only/ + ln -s "$(pwd)"/ocean_only $HOME/ci/$CI_PIPELINE_ID/ocean_only fi section-end create-job-dir } From 758b5a340c25c293bbd3c5436819cac1b290c4ff Mon Sep 17 00:00:00 2001 From: Claire Yung Date: Wed, 24 Apr 2024 13:08:47 -0400 Subject: [PATCH 600/629] Add maximum number of iterations in find_depth_of_pressure_in_cell --- src/core/MOM_density_integrals.F90 | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index b73524e362..d747d6aab2 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1753,6 +1753,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t real :: F_guess, F_l, F_r ! Fractional positions [nondim] real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] + integer :: m ! A counter for how many iterations have been done in the while loop [nondim] character(len=240) :: msg GxRho = G_e * rho_ref @@ -1780,8 +1781,14 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t F_guess = F_l - Pa_left / (Pa_right - Pa_left) * (F_r - F_l) Pa = Pa_right - Pa_left ! To get into iterative loop + m = 0 ! Reset the counter for the loop to be zero do while ( abs(Pa) > Pa_tol ) + m = m + 1 + if (m > 30) then !Call an error, because convergence to the tolerance has not been achieved + write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell completes too many iterations: /n'//msg) + endif z_out = z_t + ( z_b - z_t ) * F_guess Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) From 9f3da0be2c72334c01e481d142421a6c55c3b6ff Mon Sep 17 00:00:00 2001 From: Claire Yung Date: Thu, 16 May 2024 10:31:17 +1000 Subject: [PATCH 601/629] Fix minor issues --- src/core/MOM_density_integrals.F90 | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/core/MOM_density_integrals.F90 b/src/core/MOM_density_integrals.F90 index d747d6aab2..6d80d4dd55 100644 --- a/src/core/MOM_density_integrals.F90 +++ b/src/core/MOM_density_integrals.F90 @@ -1753,7 +1753,7 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t real :: F_guess, F_l, F_r ! Fractional positions [nondim] real :: GxRho ! The product of the gravitational acceleration and reference density [R L2 Z-1 T-2 ~> Pa m-1] real :: Pa, Pa_left, Pa_right, Pa_tol ! Pressure anomalies, P = integral of g*(rho-rho_ref) dz [R L2 T-2 ~> Pa] - integer :: m ! A counter for how many iterations have been done in the while loop [nondim] + integer :: m ! A counter for how many iterations have been done in the while loop character(len=240) :: msg GxRho = G_e * rho_ref @@ -1785,9 +1785,9 @@ subroutine find_depth_of_pressure_in_cell(T_t, T_b, S_t, S_b, z_t, z_b, P_t, P_t do while ( abs(Pa) > Pa_tol ) m = m + 1 - if (m > 30) then !Call an error, because convergence to the tolerance has not been achieved + if (m > 30) then ! Call an error, because convergence to the tolerance has not been achieved write(msg,*) Pa_left,Pa,Pa_right,P_t-P_tgt,P_b-P_tgt - call MOM_error(FATAL, 'find_depth_of_pressure_in_cell completes too many iterations: /n'//msg) + call MOM_error(FATAL, 'find_depth_of_pressure_in_cell completes too many iterations: '//msg) endif z_out = z_t + ( z_b - z_t ) * F_guess Pa = frac_dp_at_pos(T_t, T_b, S_t, S_b, z_t, z_b, rho_ref, G_e, F_guess, EOS) - ( P_tgt - P_t ) From 93f2aeea43a8a456b11e531cfe733df804036d34 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 6 May 2024 16:04:15 -0400 Subject: [PATCH 602/629] Fix error in diagnostic axis registration for grid space axes - For runs using grid space diagnostic axes, the registration of the cell centered axes fails with symmetric memory with a runtime error when posting diagnostics. This patch fixes this error. --- src/framework/MOM_diag_mediator.F90 | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 18dcd9a825..8af82d7872 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -419,9 +419,9 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) if (diag_cs%grid_space_axes) then id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & - 'h point grid-space longitude', G%Domain, position=EAST) + 'h point grid-space longitude', G%Domain) id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & - 'h point grid space latitude', G%Domain, position=NORTH) + 'h point grid space latitude', G%Domain) else id_xh = diag_axis_init('xh', G%gridLonT(G%isg:G%ieg), G%x_axis_units, 'x', & 'h point nominal longitude', G%Domain) From c1c32d217bb6b9568e63299ae66e1a3674ea37d9 Mon Sep 17 00:00:00 2001 From: Matthew Harrison Date: Mon, 20 May 2024 13:53:23 -0400 Subject: [PATCH 603/629] Replace USE_GRID_SPACE_DIAGNOSTIC_AXES with USE_INDEX_DIAGNOSTIC_AXES - The old flag has been obsoleted. This will impact only a very small number of users. --- src/diagnostics/MOM_obsolete_params.F90 | 3 +++ src/framework/MOM_diag_mediator.F90 | 14 +++++++------- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/diagnostics/MOM_obsolete_params.F90 b/src/diagnostics/MOM_obsolete_params.F90 index 2567e7591b..a590ae3893 100644 --- a/src/diagnostics/MOM_obsolete_params.F90 +++ b/src/diagnostics/MOM_obsolete_params.F90 @@ -152,6 +152,9 @@ subroutine find_obsolete_params(param_file) call obsolete_logical(param_file, "VERT_FRICTION_2018_ANSWERS", & hint="Instead use VERT_FRICTION_ANSWER_DATE.") + call obsolete_logical(param_file, "USE_GRID_SPACE_DIAGNOSTIC_AXES", & + hint="Instead use USE_INDEX_DIAGNOSTIC_AXIS.") + ! Write the file version number to the model log. call log_version(param_file, mdl, version) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 8af82d7872..5289d266df 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -243,7 +243,7 @@ module MOM_diag_mediator !! This file is open if available_diag_doc_unit is > 0. logical :: diag_as_chksum !< If true, log chksums in a text file instead of posting diagnostics logical :: show_call_tree !< Display the call tree while running. Set by VERBOSITY level. - logical :: grid_space_axes !< If true, diagnostic horizontal coordinates axes are in grid space. + logical :: index_space_axes !< If true, diagnostic horizontal coordinates axes are in index space. ! The following fields are used for the output of the data. integer :: is !< The start i-index of cell centers within the computational domain integer :: ie !< The end i-index of cell centers within the computational domain @@ -371,7 +371,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) set_vert = .true. ; if (present(set_vertical)) set_vert = set_vertical - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then allocate(IaxB(G%IsgB:G%IegB)) do i=G%IsgB, G%IegB Iaxb(i)=real(i) @@ -392,7 +392,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) ! Horizontal axes for the native grids if (G%symmetric) then - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then id_xq = diag_axis_init('iq', IaxB(G%isgB:G%iegB), 'none', 'x', & 'q point grid-space longitude', G%Domain, position=EAST) id_yq = diag_axis_init('jq', JaxB(G%jsgB:G%jegB), 'none', 'y', & @@ -404,7 +404,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) 'q point nominal latitude', G%Domain, position=NORTH) endif else - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then id_xq = diag_axis_init('Iq', IaxB(G%isg:G%ieg), 'none', 'x', & 'q point grid-space longitude', G%Domain, position=EAST) id_yq = diag_axis_init('Jq', JaxB(G%jsg:G%jeg), 'none', 'y', & @@ -417,7 +417,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) endif endif - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then id_xh = diag_axis_init('ih', iax(G%isg:G%ieg), 'none', 'x', & 'h point grid-space longitude', G%Domain) id_yh = diag_axis_init('jh', jax(G%jsg:G%jeg), 'none', 'y', & @@ -579,7 +579,7 @@ subroutine set_axes_info(G, GV, US, param_file, diag_cs, set_vertical) endif enddo - if (diag_cs%grid_space_axes) then + if (diag_cs%index_space_axes) then deallocate(IaxB, iax, JaxB, jax) endif !Define the downsampled axes @@ -3287,7 +3287,7 @@ subroutine diag_mediator_init(G, GV, US, nz, param_file, diag_cs, doc_file_dir) "robust and accurate forms of mathematically equivalent expressions.", & default=default_answer_date, do_not_log=.not.GV%Boussinesq) if (.not.GV%Boussinesq) remap_answer_date = max(remap_answer_date, 20230701) - call get_param(param_file, mdl, 'USE_GRID_SPACE_DIAGNOSTIC_AXES', diag_cs%grid_space_axes, & + call get_param(param_file, mdl, 'USE_INDEX_DIAGNOSTIC_AXES', diag_cs%index_space_axes, & 'If true, use a grid index coordinate convention for diagnostic axes. ',& default=.false.) From 1cf20b3e43a4f235eb6dba66e29497102e9c652b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 5 Mar 2024 05:30:22 -0500 Subject: [PATCH 604/629] Better variables for updated masks in fill_miss_2d Within fill_miss_2d, there are 2 sets of masked values used for remapping - masked values in neighboring points in arbitrary units (with names like "south") and the updated valid mask with values of 0 or 1 (with names like "gs"). At one point in the code, the former were being used where the latter were more appropriate. This commit changes this to help with the understandability of the code. However, when the order of arithmetic is not specified with parentheses, the Nvidia compiler is changing answers with this change of variables. To avoid this change in answers, this commit is only changing which variables are used when the answer_date is larger than 20190101 and the order of the sums are specified with parentheses. This commit also now moves the logical test for ans_2018 outside of the i- and j- loops where non-zero values of a_chg are set. All answers and output are bitwise identical. --- src/framework/MOM_horizontal_regridding.F90 | 35 ++++++++++++--------- 1 file changed, 21 insertions(+), 14 deletions(-) diff --git a/src/framework/MOM_horizontal_regridding.F90 b/src/framework/MOM_horizontal_regridding.F90 index b718f65b5e..ce739cba55 100644 --- a/src/framework/MOM_horizontal_regridding.F90 +++ b/src/framework/MOM_horizontal_regridding.F90 @@ -125,7 +125,7 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, real, dimension(SZI_(G),SZJ_(G)) :: good_new ! The values of good_ to use for the next iteration [nondim] real :: east, west, north, south ! Valid neighboring values or 0 for invalid values [arbitrary] - real :: ge, gw, gn, gs ! Flags indicating which neighbors have valid values [nondim] + real :: ge, gw, gn, gs ! Flags set to 0 or 1 indicating which neighbors have valid values [nondim] real :: ngood ! The number of valid values in neighboring points [nondim] real :: nfill ! The remaining number of points to fill [nondim] real :: nfill_prev ! The previous value of nfill [nondim] @@ -227,23 +227,30 @@ subroutine fill_miss_2d(aout, good, fill, prev, G, acrit, num_pass, relc, debug, ! Do Laplacian smoothing for the points that have been filled in. do k=1,npass call pass_var(aout,G%Domain) - do j=js,je ; do i=is,ie - if (fill(i,j) == 1) then - east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j)) - north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1)) - if (ans_2018) then + + a_chg(:,:) = 0.0 + if (ans_2018) then + do j=js,je ; do i=is,ie + if (fill(i,j) == 1) then + east = max(good(i+1,j),fill(i+1,j)) ; west = max(good(i-1,j),fill(i-1,j)) + north = max(good(i,j+1),fill(i,j+1)) ; south = max(good(i,j-1),fill(i,j-1)) a_chg(i,j) = relax_coeff*(south*aout(i,j-1)+north*aout(i,j+1) + & west*aout(i-1,j)+east*aout(i+1,j) - & (south+north+west+east)*aout(i,j)) - else - a_chg(i,j) = relax_coeff*( ((south*aout(i,j-1) + north*aout(i,j+1)) + & - (west*aout(i-1,j)+east*aout(i+1,j))) - & - ((south+north)+(west+east))*aout(i,j) ) endif - else - a_chg(i,j) = 0. - endif - enddo ; enddo + enddo ; enddo + else + do j=js,je ; do i=is,ie + if (fill(i,j) == 1) then + ge = max(good(i+1,j),fill(i+1,j)) ; gw = max(good(i-1,j),fill(i-1,j)) + gn = max(good(i,j+1),fill(i,j+1)) ; gs = max(good(i,j-1),fill(i,j-1)) + a_chg(i,j) = relax_coeff*( ((gs*aout(i,j-1) + gn*aout(i,j+1)) + & + (gw*aout(i-1,j) + ge*aout(i+1,j))) - & + ((gs + gn) + (gw + ge))*aout(i,j) ) + endif + enddo ; enddo + endif + ares = 0.0 do j=js,je ; do i=is,ie aout(i,j) = a_chg(i,j) + aout(i,j) From bfe3e4f03d2795b42d557a2ebe2713f6cee3bff3 Mon Sep 17 00:00:00 2001 From: jiandewang Date: Wed, 22 May 2024 15:51:27 -0400 Subject: [PATCH 605/629] fix line length too long issue in mom_cap.F90 --- config_src/drivers/nuopc_cap/mom_cap.F90 | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/config_src/drivers/nuopc_cap/mom_cap.F90 b/config_src/drivers/nuopc_cap/mom_cap.F90 index d2dcf96067..3e3abba674 100644 --- a/config_src/drivers/nuopc_cap/mom_cap.F90 +++ b/config_src/drivers/nuopc_cap/mom_cap.F90 @@ -383,7 +383,8 @@ subroutine InitializeP0(gcomp, importState, exportState, clock, rc) endif ! Read end of run restart config option - call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=value, isPresent=isPresent, isSet=isSet, rc=rc) + call NUOPC_CompAttributeGet(gcomp, name="write_restart_at_endofrun", value=value, & + isPresent=isPresent, isSet=isSet, rc=rc) if (ChkErr(rc,__LINE__,u_FILE_u)) return if (isPresent .and. isSet) then if (trim(value) .eq. '.true.') restart_eor = .true. From 2b69f1e9816b6d7a0235326a6e67de500aeb419e Mon Sep 17 00:00:00 2001 From: "brandon.reichl" Date: Thu, 23 May 2024 19:19:37 -0400 Subject: [PATCH 606/629] Bugfix for tracer advection diagnostic in symmetric memory mode - Fix logic so tracer advection diagnostics are computed correctly for symmetric memory mode --- src/tracer/MOM_tracer_advect.F90 | 13 ++++++------- 1 file changed, 6 insertions(+), 7 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index ef2c3125cd..b77949342d 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -380,7 +380,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & real :: dA ! Difference between the reconstruction tracer edge values [conc] real :: mA ! Average of the reconstruction tracer edge values [conc] real :: a6 ! Curvature of the reconstruction tracer values [conc] - logical :: do_i(SZIB_(G),SZJ_(G)) ! If true, work on given points. + logical :: do_i(SZI_(G),SZJ_(G)) ! If true, work on given points. logical :: usePLMslope integer :: i, j, m, n, i_up, stencil, ntr_id type(OBC_segment_type), pointer :: segment=>NULL() @@ -659,7 +659,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & enddo ! diagnostics - if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j)) then + if (associated(Tr(m)%ad_x)) then ; do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then Tr(m)%ad_x(I,j,k) = Tr(m)%ad_x(I,j,k) + flux_x(I,j,m)*Idt endif ; enddo ; endif @@ -688,7 +688,7 @@ subroutine advect_x(Tr, hprev, uhr, uh_neglect, OBC, domore_u, ntr, Idt, & !$OMP ordered do m=1,ntr ; if (associated(Tr(m)%ad2d_x)) then do j=js,je ; if (domore_u_initial(j,k)) then - do I=is-1,ie ; if (do_i(i,j)) then + do I=is-1,ie ; if (do_i(i,j) .or. do_i(i+1,j)) then Tr(m)%ad2d_x(I,j) = Tr(m)%ad2d_x(I,j) + flux_x(I,j,m)*Idt endif ; enddo endif ; enddo @@ -756,7 +756,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & real :: mA ! Average of the reconstruction tracer edge values [conc] real :: a6 ! Curvature of the reconstruction tracer values [conc] logical :: do_j_tr(SZJ_(G)) ! If true, calculate the tracer profiles. - logical :: do_i(SZIB_(G), SZJ_(G)) ! If true, work on given points. + logical :: do_i(SZI_(G), SZJ_(G)) ! If true, work on given points. logical :: usePLMslope integer :: i, j, j2, m, n, j_up, stencil, ntr_id type(OBC_segment_type), pointer :: segment=>NULL() @@ -1066,8 +1066,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & !$OMP ordered do m=1,ntr ; if (associated(Tr(m)%ad_y)) then do J=js-1,je ; if (domore_v_initial(J)) then - ! (The logical test could be "do_i(i,j) .or. do_i(i+1,j)" to be clearer, but not needed) - do i=is,ie ; if (do_i(i,j)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then Tr(m)%ad_y(i,J,k) = Tr(m)%ad_y(i,J,k) + flux_y(i,m,J)*Idt endif ; enddo endif ; enddo @@ -1075,7 +1074,7 @@ subroutine advect_y(Tr, hprev, vhr, vh_neglect, OBC, domore_v, ntr, Idt, & do m=1,ntr ; if (associated(Tr(m)%ad2d_y)) then do J=js-1,je ; if (domore_v_initial(J)) then - do i=is,ie ; if (do_i(i,j)) then + do i=is,ie ; if (do_i(i,j) .or. do_i(i,j+1)) then Tr(m)%ad2d_y(i,J) = Tr(m)%ad2d_y(i,J) + flux_y(i,m,J)*Idt endif ; enddo endif ; enddo From 7384dba37cb3ba82bb9eec204b7e8bd1c8031322 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Thu, 23 May 2024 16:14:22 -0400 Subject: [PATCH 607/629] Autoconf: Detect FMS IO implementation This patch allows autoconf to detect the version of FMS IO that is implemented in its library, and select the appropriate "infra" in the MOM6 source. The allows for removal of the --with-framework flag, and should prevent future FMS library/infra mismatches. --- .testing/Makefile | 1 - ac/configure.ac | 21 ++++++++------------- 2 files changed, 8 insertions(+), 14 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index a1461fe7ab..2efead315d 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -286,7 +286,6 @@ $(BUILD)/unit/Makefile: MOM_ENV += $(COV_FCFLAGS) $(COV_LDFLAGS) $(BUILD)/timing/Makefile: MOM_ENV += $(OPT_FCFLAGS) $(MOM_LDFLAGS) # Configure script flags -MOM_ACFLAGS := --with-framework=$(FRAMEWORK) $(BUILD)/openmp/Makefile: MOM_ACFLAGS += --enable-openmp $(BUILD)/coupled/Makefile: MOM_ACFLAGS += --with-driver=FMS_cap $(BUILD)/nuopc/Makefile: MOM_ACFLAGS += --with-driver=nuopc_cap diff --git a/ac/configure.ac b/ac/configure.ac index c774c39129..8196e2eb01 100644 --- a/ac/configure.ac +++ b/ac/configure.ac @@ -79,18 +79,6 @@ AS_IF([test "x$with_driver" != "x"], # used to configure a header based on a template. #AC_CONFIG_HEADERS(["$MEM_LAYOUT/MOM_memory.h"]) -# Select the model framework (default: FMS1) -# NOTE: We can phase this out after the FMS1 I/O has been removed from FMS and -# replace with a detection test. For now, it is a user-defined switch. -MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2 -AC_ARG_WITH([framework], - AS_HELP_STRING([--with-framework=fms1|fms2], [Select the model framework])) -AS_CASE(["$with_framework"], - [fms1], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1], - [fms2], [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2], - [MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2] -) - # Explicitly assume free-form Fortran AC_LANG(Fortran) @@ -220,7 +208,6 @@ AX_FC_CHECK_LIB([FMS], [fms_init], [fms_mod], ] ) - # Verify that FMS is at least 2019.01.02 # NOTE: 2019.01.02 introduced two changes: # - diag_axis_init supports an optional domain_position argument @@ -236,6 +223,14 @@ AC_COMPILE_IFELSE( ] ) +# Determine the FMS IO implementation. +AX_FC_CHECK_MODULE([fms2_io_mod], [ + MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS2 +],[ + MODEL_FRAMEWORK=${srcdir}/config_src/infra/FMS1 +]) + + # Python interpreter test # Declare the Python interpreter variable From c7d3268b65292e6cfcdca595cfbfb9d5f1d2f519 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Fri, 24 May 2024 12:53:36 -0400 Subject: [PATCH 608/629] .testing: Target build uses its own Makefile The build/target/MOM6 rule was modified so that build/target is now a symlink into build/target_codebase/.testing/build/symmetric. In other words, build/target now uses the entire build system of target_codebase (i.e. the reference codebase) rather than borrowing from bits and pieces of the current codebase. This should prevent potential false positives in future regression tests related to buildsystem changes. Several apparently unused blocks of rules and other content in .testing/Makefile have also been removed. --- .testing/Makefile | 60 ++++++++++------------------------------------- 1 file changed, 12 insertions(+), 48 deletions(-) diff --git a/.testing/Makefile b/.testing/Makefile index 2efead315d..8ca3fe21eb 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -133,9 +133,6 @@ TIME ?= time WORKSPACE ?= . # Set directories for build/ and work/ -#BUILD ?= $(WORKSPACE)build -#DEPS ?= $(BUILD)/deps -#WORK ?= $(WORKSPACE)work BUILD ?= $(WORKSPACE)/build DEPS ?= $(BUILD)/deps WORK ?= $(WORKSPACE)/work @@ -207,34 +204,6 @@ else endif -# List of source files to link this Makefile's dependencies to model Makefiles -# Assumes a depth of two, and the following extensions: F90 inc c h -# (1): Root directory -# NOTE: extensions could be a second variable -SOURCE = \ - $(foreach ext,F90 inc c h,$(wildcard $(1)/*/*.$(ext) $(1)/*/*/*.$(ext))) - -MOM_SOURCE = \ - $(call SOURCE,../src) \ - $(wildcard ../config_src/drivers/solo_driver/*.F90) \ - $(wildcard ../config_src/ext*/*/*.F90) - -TARGET_SOURCE = \ - $(call SOURCE,$(BUILD)/target_codebase/src) \ - $(wildcard $(BUILD)/target_codebase/config_src/drivers/solo_driver/*.F90) \ - $(wildcard $(BUILD)target_codebase/config_src/ext*/*.F90) - -ifeq ($(FRAMEWORK), fms1) - MOM_SOURCE += $(wildcard ../config_src/infra/FMS1/*.F90) - TARGET_SOURCE += $(wildcard $(BUILD)/target_codebase/config_src/infra/FMS1/*.F90) -else - MOM_SOURCE +=$(wildcard ../config_src/infra/FMS2/*.F90) - TARGET_SOURCE += $(wildcard $(BUILD)/target_codebase/config_src/infra/FMS2/*.F90) -endif - -FMS_SOURCE = $(call SOURCE,$(DEPS)/fms/src) - - ## Rules .PHONY: all build.regressions build.prof @@ -297,11 +266,21 @@ $(BUILD)/timing/Makefile: MOM_ACFLAGS += --with-driver=timing_tests $(BUILD)/unit/test_%: $(BUILD)/unit/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j $(BUILD)/unit/Makefile: $(foreach e,$(UNIT_EXECS),../config_src/drivers/unit_tests/$(e).F90) + $(BUILD)/timing/time_%: $(BUILD)/timing/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j $(BUILD)/timing/Makefile: $(foreach e,$(TIMING_EXECS),../config_src/drivers/timing_tests/$(e).F90) + $(BUILD)/%/MOM6: $(BUILD)/%/Makefile FORCE cd $(@D) && $(TIME) $(MAKE) $(@F) -j + +# Target codebase should use its own build system +$(BUILD)/target/MOM6: $(BUILD)/target FORCE | $(TARGET_CODEBASE) + $(MAKE) -C $(TARGET_CODEBASE)/.testing build/symmetric/MOM6 + +$(BUILD)/target: | $(TARGET_CODEBASE) + ln -s $(abspath $(TARGET_CODEBASE))/.testing/build/symmetric $@ + FORCE: @@ -333,27 +312,12 @@ $(BUILD)/%/configure.ac: ../ac/configure.ac | $(BUILD)/%/ $(BUILD)/%/m4/: ../ac/m4/ | $(BUILD)/%/ cp -r ../ac/m4 $(@D) -ALL_EXECS = symmetric asymmetric repro openmp target opt opt_target coupled \ - nuopc cov unit timing +ALL_EXECS = symmetric asymmetric repro openmp opt opt_target coupled nuopc \ + cov unit timing $(foreach b,$(ALL_EXECS),$(BUILD)/$(b)/): mkdir -p $@ # Fetch the regression target codebase - -$(BUILD)/target/config.status: $(BUILD)/target/configure $(DEPS)/lib/libFMS.a - cd $(@D) && $(MOM_ENV) ./configure -n \ - --srcdir=$(abspath $(BUILD))/target_codebase/ac $(MOM_ACFLAGS) \ - || (cat config.log && false) - -$(BUILD)/target/Makefile.in: | $(TARGET_CODEBASE) $(BUILD)/target/ - cp $(TARGET_CODEBASE)/ac/Makefile.in $(@D) - -$(BUILD)/target/configure.ac: | $(TARGET_CODEBASE) $(BUILD)/target/ - cp $(TARGET_CODEBASE)/ac/configure.ac $(@D) - -$(BUILD)/target/m4/: | $(TARGET_CODEBASE) $(BUILD)/target/ - cp -r $(TARGET_CODEBASE)/ac/m4 $(@D) - $(TARGET_CODEBASE): git clone --recursive $(MOM_TARGET_URL) $@ cd $@ && git checkout --recurse-submodules $(MOM_TARGET_BRANCH) From 8ecb2603119b8c9d4dee9ee6b174e1864415d1cc Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 28 May 2024 14:48:54 -0400 Subject: [PATCH 609/629] CI: Fix FMS_COMMIT, remove FRAMEWORK This patch fixes FMS_COMMIT and FMS_URL so that they are properly exported to ``ac/deps/Makefile`` and used in the .testing FMS build. It also removes any references to the FRAMEWORK flag, which is no longer needed to identify the FMS API. --- .github/workflows/macos-regression.yml | 1 - .github/workflows/macos-stencil.yml | 1 - .testing/Makefile | 8 +++++--- .testing/README.rst | 8 +++++--- 4 files changed, 10 insertions(+), 8 deletions(-) diff --git a/.github/workflows/macos-regression.yml b/.github/workflows/macos-regression.yml index 5e0380bcd2..d769e15131 100644 --- a/.github/workflows/macos-regression.yml +++ b/.github/workflows/macos-regression.yml @@ -11,7 +11,6 @@ jobs: CC: gcc FC: gfortran FMS_COMMIT: 2019.01.03 - FRAMEWORK: fms1 defaults: run: diff --git a/.github/workflows/macos-stencil.yml b/.github/workflows/macos-stencil.yml index e54912b607..6e77a5c4a6 100644 --- a/.github/workflows/macos-stencil.yml +++ b/.github/workflows/macos-stencil.yml @@ -11,7 +11,6 @@ jobs: CC: gcc FC: gfortran FMS_COMMIT: 2019.01.03 - FRAMEWORK: fms1 defaults: run: diff --git a/.testing/Makefile b/.testing/Makefile index 8ca3fe21eb..f5da44342d 100644 --- a/.testing/Makefile +++ b/.testing/Makefile @@ -20,7 +20,6 @@ # # General test configuration: # MPIRUN MPI job launcher (mpirun, srun, etc) -# FRAMEWORK Model framework (fms1 or fms2) # DO_REPRO_TESTS Enable production ("repro") testing equivalence # DO_REGRESSION_TESTS Enable regression tests (usually dev/gfdl) # DO_COVERAGE Enable code coverage and generate .gcov reports @@ -74,8 +73,11 @@ AC_SRCDIR := $(dir $(abspath $(lastword $(MAKEFILE_LIST))))../ac # User-defined configuration -include config.mk -# Set the infra framework -FRAMEWORK ?= fms2 +# Set the FMS library +FMS_COMMIT ?= 2023.03 +FMS_URL ?= https://github.com/NOAA-GFDL/FMS.git +export FMS_COMMIT +export FMS_URL # Set the MPI launcher here # TODO: This needs more automated configuration diff --git a/.testing/README.rst b/.testing/README.rst index 49103da718..a84eeea80e 100644 --- a/.testing/README.rst +++ b/.testing/README.rst @@ -47,9 +47,11 @@ Several of the following may require configuration for particular systems. Name of the MPI launcher. Often this is ``mpirun`` or ``mpiexec`` but may all need to run through a scheduler, e.g. ``srun`` if using Slurm. -``FRAMEWORK`` (*default:* ``fms1``) - Select either the legacy FMS framework (``fms1``) or an FMS2 I/O compatible - version (``fms2``). +``FMS_COMMIT`` (*default:* ``2023.03``) + Set the FMS version, either by tag or commit (as defined in ``FMS_URL``). + +``FMS_URL`` (*default*: ``https://github.com/NOAA-GFDL/FMS.git``) + Set the URL of the FMS repository. ``DO_REPRO_TESTS`` (*default:* *none*) Set to ``true`` to test the REPRO build and confirm equivalence of DEBUG and From f21ec031ecb5a78caaae5a6d153feba8abf5d907 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 24 May 2024 04:24:15 -0400 Subject: [PATCH 610/629] *Fix ALE_remap_scalar call with h_in_Z_units Corrected an argument to the call to ALE_remap_scalar() when h_in_Z_units is true in MOM_initialize_tracer_from_Z(), to avoid the problems documented in github.com/NOAA-GFDL/MOM6/issues/589. A comment was also added explaining the logic of what is going on in this fork of the code. This commit will change answers with some generic tracers that are initialized from a Z-space input file, restoring them to previous values that worked previously (before about Feb. 1, 2024 on dev/gfdl) in Boussinesq configurations without dimensional consistency testing, but in a new form that does pass the dimensional consistency testing for depths and thicknesses. All answers are bitwise identical in any cases that do not use generic tracers. --- src/initialization/MOM_tracer_initialization_from_Z.F90 | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/initialization/MOM_tracer_initialization_from_Z.F90 b/src/initialization/MOM_tracer_initialization_from_Z.F90 index d28a925c03..cac8a5cd6c 100644 --- a/src/initialization/MOM_tracer_initialization_from_Z.F90 +++ b/src/initialization/MOM_tracer_initialization_from_Z.F90 @@ -200,8 +200,10 @@ subroutine MOM_initialize_tracer_from_Z(h, tr, G, GV, US, PF, src_file, src_var_ enddo ; enddo if (h_is_in_Z_units) then + ! Because h is in units of [Z ~> m], dzSrc is already in the right units, but we need to + ! specify negligible thickness values with the right units. dz_neglect = set_dz_neglect(GV, US, remap_answer_date, dz_neglect_edge) - call ALE_remap_scalar(remapCS, G, GV, kd, hSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date, & + call ALE_remap_scalar(remapCS, G, GV, kd, dzSrc, tr_z, h, tr, all_cells=.false., answer_date=remap_answer_date, & H_neglect=dz_neglect, H_neglect_edge=dz_neglect_edge) else ! Equation of state data is not available, so a simpler rescaling will have to suffice, From 705a38493fef60cd4d577315fe1d0ff9609a7d58 Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Mon, 1 Apr 2024 13:27:35 -0400 Subject: [PATCH 611/629] Add diag send complete calls to MOM --- config_src/infra/FMS1/MOM_diag_manager_infra.F90 | 6 ++++++ config_src/infra/FMS2/MOM_diag_manager_infra.F90 | 12 +++++++++++- src/framework/MOM_diag_mediator.F90 | 2 ++ 3 files changed, 19 insertions(+), 1 deletion(-) diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index 18ccdaae67..cd9544d6e6 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -57,6 +57,7 @@ module MOM_diag_manager_infra public MOM_diag_manager_init public MOM_diag_manager_end public send_data_infra +public diag_send_complete_infra public MOM_diag_field_add_attribute public register_diag_field_infra public register_static_field_infra @@ -451,4 +452,9 @@ subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) end subroutine MOM_diag_field_add_attribute_i1d +!> Finishes the diag manager reduction methods as needed for the time_step +!! Needed for backwards compatibility, does nothing +subroutine diag_send_complete_infra () +end subroutine diag_send_complete_infra + end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index 18ccdaae67..230ee79566 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -14,13 +14,14 @@ module MOM_diag_manager_infra use diag_data_mod, only : null_axis_id use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end +use diag_manager_mod, only : diag_send_complete use diag_manager_mod, only : send_data_fms => send_data use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND use diag_manager_mod, only : register_diag_field_fms => register_diag_field use diag_manager_mod, only : register_static_field_fms => register_static_field use diag_manager_mod, only : get_diag_field_id_fms => get_diag_field_id -use MOM_time_manager, only : time_type +use MOM_time_manager, only : time_type, set_time use MOM_domain_infra, only : MOM_domain_type use MOM_error_infra, only : MOM_error => MOM_err, FATAL, WARNING @@ -57,6 +58,7 @@ module MOM_diag_manager_infra public MOM_diag_manager_init public MOM_diag_manager_end public send_data_infra +public diag_send_complete_infra public MOM_diag_field_add_attribute public register_diag_field_infra public register_static_field_infra @@ -451,4 +453,12 @@ subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) end subroutine MOM_diag_field_add_attribute_i1d +!> Finishes the diag manager reduction methods as needed for the time_step +subroutine diag_send_complete_infra () + !! The time_step in the diag_send_complete call is a dummy argument, needed for backwards compatibility + !! It won't be used at all when diag_manager_nml::use_modern_diag=.true. + !! It won't have any impact when diag_manager_nml::use_modern_diag=.false. + call diag_send_complete (set_time(0)) +end subroutine diag_send_complete_infra + end module MOM_diag_manager_infra diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index 5289d266df..b3194af3d8 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -14,6 +14,7 @@ module MOM_diag_mediator use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND +use MOM_diag_manager_infra, only : diag_send_complete_infra use MOM_diag_remap, only : diag_remap_ctrl, diag_remap_update, diag_remap_calc_hmask use MOM_diag_remap, only : diag_remap_init, diag_remap_end, diag_remap_do_remap use MOM_diag_remap, only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field @@ -2078,6 +2079,7 @@ end subroutine enable_averages subroutine disable_averaging(diag_cs) type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output + call diag_send_complete_infra() diag_cs%time_int = 0.0 diag_cs%ave_enabled = .false. From 7305528fd99bc09bda648693cd7130e4627de25c Mon Sep 17 00:00:00 2001 From: Uriel Ramirez Date: Tue, 14 May 2024 16:43:16 -0400 Subject: [PATCH 612/629] Add diag_manager_set_time_end calls to the solo drivers --- config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 | 3 +++ config_src/drivers/solo_driver/MOM_driver.F90 | 3 +++ config_src/infra/FMS1/MOM_diag_manager_infra.F90 | 9 +++++++-- config_src/infra/FMS2/MOM_diag_manager_infra.F90 | 9 +++++++++ 4 files changed, 22 insertions(+), 2 deletions(-) diff --git a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 index c4be8c769d..787fa7e7d1 100644 --- a/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 +++ b/config_src/drivers/ice_solo_driver/ice_shelf_driver.F90 @@ -26,6 +26,7 @@ program Shelf_main use MOM_debugging, only : MOM_debugging_init use MOM_diag_mediator, only : diag_mediator_init, diag_mediator_infrastructure_init, set_axes_info use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration + use MOM_diag_manager_infra, only : diag_manager_set_time_end_infra use MOM_domains, only : MOM_infra_init, MOM_infra_end use MOM_domains, only : MOM_domains_init, clone_MOM_domain, pass_var use MOM_dyn_horgrid, only : dyn_horgrid_type, create_dyn_horgrid, destroy_dyn_horgrid @@ -325,6 +326,8 @@ program Shelf_main Time_end = daymax endif + call diag_manager_set_time_end_infra (Time_end) + if (Time >= Time_end) call MOM_error(FATAL, & "Shelf_driver: The run has been started at or after the end time of the run.") diff --git a/config_src/drivers/solo_driver/MOM_driver.F90 b/config_src/drivers/solo_driver/MOM_driver.F90 index 0e355f8638..9b85fafb8d 100644 --- a/config_src/drivers/solo_driver/MOM_driver.F90 +++ b/config_src/drivers/solo_driver/MOM_driver.F90 @@ -28,6 +28,7 @@ program MOM6 use MOM_cpu_clock, only : CLOCK_COMPONENT use MOM_data_override, only : data_override_init use MOM_diag_mediator, only : diag_mediator_end, diag_ctrl, diag_mediator_close_registration + use MOM_diag_manager_infra, only : diag_manager_set_time_end_infra use MOM, only : initialize_MOM, step_MOM, MOM_control_struct, MOM_end use MOM, only : extract_surface_state, finish_MOM_initialization use MOM, only : get_MOM_state_elements, MOM_state_is_synchronized @@ -375,6 +376,8 @@ program MOM6 Time_end = daymax endif + call diag_manager_set_time_end_infra(Time_end) + call get_param(param_file, mod_name, "SINGLE_STEPPING_CALL", single_step_call, & "If true, advance the state of MOM with a single step "//& "including both dynamics and thermodynamics. If false "//& diff --git a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 index cd9544d6e6..232986f480 100644 --- a/config_src/infra/FMS1/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS1/MOM_diag_manager_infra.F90 @@ -58,6 +58,7 @@ module MOM_diag_manager_infra public MOM_diag_manager_end public send_data_infra public diag_send_complete_infra +public diag_manager_set_time_end_infra public MOM_diag_field_add_attribute public register_diag_field_infra public register_static_field_infra @@ -452,9 +453,13 @@ subroutine MOM_diag_field_add_attribute_i1d(diag_field_id, att_name, att_value) end subroutine MOM_diag_field_add_attribute_i1d -!> Finishes the diag manager reduction methods as needed for the time_step -!! Needed for backwards compatibility, does nothing +!> Needed for backwards compatibility, does nothing subroutine diag_send_complete_infra () end subroutine diag_send_complete_infra +!> Needed for backwards compatibility, does nothing +subroutine diag_manager_set_time_end_infra(time) + type(time_type), intent(in) :: time !< The model time that simulation ends +end subroutine diag_manager_set_time_end_infra + end module MOM_diag_manager_infra diff --git a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 index 230ee79566..f05baa4474 100644 --- a/config_src/infra/FMS2/MOM_diag_manager_infra.F90 +++ b/config_src/infra/FMS2/MOM_diag_manager_infra.F90 @@ -15,6 +15,7 @@ module MOM_diag_manager_infra use diag_manager_mod, only : fms_diag_manager_init => diag_manager_init use diag_manager_mod, only : fms_diag_manager_end => diag_manager_end use diag_manager_mod, only : diag_send_complete +use diag_manager_mod, only : diag_manager_set_time_end use diag_manager_mod, only : send_data_fms => send_data use diag_manager_mod, only : fms_diag_field_add_attribute => diag_field_add_attribute use diag_manager_mod, only : DIAG_FIELD_NOT_FOUND @@ -59,6 +60,7 @@ module MOM_diag_manager_infra public MOM_diag_manager_end public send_data_infra public diag_send_complete_infra +public diag_manager_set_time_end_infra public MOM_diag_field_add_attribute public register_diag_field_infra public register_static_field_infra @@ -461,4 +463,11 @@ subroutine diag_send_complete_infra () call diag_send_complete (set_time(0)) end subroutine diag_send_complete_infra +!> Sets the time that the simulation ends in the diag manager +subroutine diag_manager_set_time_end_infra(time) + type(time_type), optional, intent(in) :: time !< The time the simulation ends + + call diag_manager_set_time_end(time) +end subroutine diag_manager_set_time_end_infra + end module MOM_diag_manager_infra From d90ff6b09acf421695d73d4c9206c07152b2a5d9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Apr 2024 15:46:33 -0400 Subject: [PATCH 613/629] (*)Refactor and document soliton_initialization Refactored the code in soliton_initialization.F90 to more accurately reflect the nondimensionalization that was applied in developing this test case. This change includes reading in the maximum depth and beta, and using them to calculate the equatorial deformation radius and the external gravity wave speed. The references to the papers describing the test case in the module were added to the doxygen comments describing the routines in this module. This commit also includes adding comments documenting the nature and units of all the internal variables in this module. There are two new arguments each (param_file and just_read) to soliton_initialize_thickness and soliton_initialize_velocity to accommodate these changes, bringing them into line with the interfaces for other similar user initialization routines, and MOM_initialize_state was changed accordingly. This change could change answers in general, but in the specific examples that use this code, both beta and the external wave speed are deliberately set to 1 in MKS units, so this commit does not change answers for that specific case. --- .../MOM_state_initialization.F90 | 5 +- src/user/soliton_initialization.F90 | 108 +++++++++++++++--- 2 files changed, 94 insertions(+), 19 deletions(-) diff --git a/src/initialization/MOM_state_initialization.F90 b/src/initialization/MOM_state_initialization.F90 index 4f11233c93..c18752c83d 100644 --- a/src/initialization/MOM_state_initialization.F90 +++ b/src/initialization/MOM_state_initialization.F90 @@ -343,7 +343,8 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & just_read=just_read) case ("dumbbell"); call dumbbell_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) - case ("soliton"); call soliton_initialize_thickness(dz, depth_tot, G, GV, US) + case ("soliton"); call soliton_initialize_thickness(dz, depth_tot, G, GV, US, PF, & + just_read=just_read) case ("phillips"); call Phillips_initialize_thickness(dz, depth_tot, G, GV, US, PF, & just_read=just_read) case ("rossby_front") @@ -508,7 +509,7 @@ subroutine MOM_initialize_state(u, v, h, tv, Time, G, GV, US, PF, dirs, & 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) - case ("soliton"); call soliton_initialize_velocity(u, v, G, GV, US) + case ("soliton"); call soliton_initialize_velocity(u, v, G, GV, US, PF, just_read) 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)) diff --git a/src/user/soliton_initialization.F90 b/src/user/soliton_initialization.F90 index 06a781ec94..722a41b7e5 100644 --- a/src/user/soliton_initialization.F90 +++ b/src/user/soliton_initialization.F90 @@ -26,8 +26,9 @@ module soliton_initialization contains -!> Initialization of thicknesses in Equatorial Rossby soliton test -subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) +!> Initialization of thicknesses in equatorial Rossby soliton test, as described in section +!! 6.1 of Haidvogel and Beckman (1990) and in Boyd (1980, JPO) and Boyd (1985, JPO). +subroutine soliton_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 @@ -35,45 +36,96 @@ subroutine soliton_initialize_thickness(h, depth_tot, G, GV, US) 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. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. + ! Local variables + real :: max_depth ! Maximum depth of the model bathymetry [Z ~> m] + real :: cg_max ! The external wave speed based on max_depth [L T-1 ~> m s-1] + real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] + real :: L_eq ! The equatorial deformation radius used in nondimensionalizing this problem [L ~> m] + real :: scale_pos ! A conversion factor to nondimensionalize the axis units, usually [m-1] + real :: x0 ! Initial x-position of the soliton in the same units as geoLonT, often [m]. + real :: y0 ! Initial y-position of the soliton in the same units as geoLatT, often [m]. + real :: x, y ! Nondimensionalized positions [nondim] + real :: I_nz ! The inverse of the number of layers [nondim] + real :: val1 ! A nondimensionlized zonal decay scale [nondim] + real :: val2 ! An overall surface height anomaly amplitude [L T-1 ~> m s-1] + real :: val3 ! A decay factor [nondim] + real :: val4 ! The local velocity amplitude [L T-1 ~> m s-1] + ! This include declares and sets the variable "version". +# include "version_variable.h" integer :: i, j, k, is, ie, js, je, nz - real :: x, y, x0, y0 - real :: val1, val2, val3, val4 is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke - call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + if (.not.just_read) & + call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + + if (.not.just_read) call log_version(param_file, mdl, version, "") + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "BETA", beta, & + "The northward gradient of the Coriolis parameter with the betaplane option.", & + units="m-1 s-1", default=0.0, scale=US%T_to_s*US%L_to_m, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_thickness: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + if (abs(beta) <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_thickness: "//& + "This module requires a non-zero value of BETA.") + + cg_max = sqrt(GV%g_Earth * max_depth) + L_eq = sqrt(cg_max / abs(beta)) + scale_pos = US%m_to_L / L_eq + I_nz = 1.0 / real(nz) x0 = 2.0*G%len_lon/3.0 y0 = 0.0 val1 = 0.395 - val2 = US%m_to_Z * 0.771*(val1*val1) + val2 = max_depth * 0.771*(val1*val1) do j = G%jsc,G%jec ; do i = G%isc,G%iec do k = 1, nz - x = G%geoLonT(i,j)-x0 - y = G%geoLatT(i,j)-y0 + x = (G%geoLonT(i,j)-x0) * scale_pos + y = (G%geoLatT(i,j)-y0) * scale_pos val3 = exp(-val1*x) val4 = val2 * ( 2.0*val3 / (1.0 + (val3*val3)) )**2 - h(i,j,k) = (0.25*val4*(6.0*y*y + 3.0) * exp(-0.5*y*y) + 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)) * I_nz enddo enddo ; enddo end subroutine soliton_initialize_thickness -!> Initialization of u and v in the equatorial Rossby soliton test -subroutine soliton_initialize_velocity(u, v, G, GV, US) +!> Initialization of u and v in the equatorial Rossby soliton test, as described in section +!! 6.1 of Haidvogel and Beckman (1990) and in Boyd (1980, JPO) and Boyd (1985, JPO). +subroutine soliton_initialize_velocity(u, v, G, GV, US, param_file, just_read) 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] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type + type(param_file_type), intent(in) :: param_file !< A structure indicating the open file + !! to parse for model parameter values. + logical, intent(in) :: just_read !< If true, this call will only read + !! parameters without changing h. ! Local variables - real :: x, x0 ! Positions in the same units as geoLonT. - real :: y, y0 ! Positions in the same units as geoLatT. - real :: val1 ! A zonal decay scale in the inverse of the units of geoLonT. + real :: max_depth ! Maximum depth of the model bathymetry [Z ~> m] + real :: cg_max ! The external wave speed based on max_depth [L T-1 ~> m s-1] + real :: beta ! The meridional gradient of the Coriolis parameter [T-1 L-1 ~> s-1 m-1] + real :: L_eq ! The equatorial deformation radius used in nondimensionalizing this problem [L ~> m] + real :: scale_pos ! A conversion factor to nondimensionalize the axis units, usually [m-1] + real :: x0 ! Initial x-position of the soliton in the same units as geoLonT, often [m]. + real :: y0 ! Initial y-position of the soliton in the same units as geoLatT, often [m]. + real :: x, y ! Nondimensionalized positions [nondim] + real :: val1 ! A nondimensionlized zonal decay scale [nondim] real :: val2 ! An overall velocity amplitude [L T-1 ~> m s-1] real :: val3 ! A decay factor [nondim] real :: val4 ! The local velocity amplitude [L T-1 ~> m s-1] @@ -81,18 +133,40 @@ subroutine soliton_initialize_velocity(u, v, G, GV, US) is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + if (.not.just_read) & + call MOM_mesg("soliton_initialization.F90, soliton_initialize_thickness: setting thickness") + + call get_param(param_file, mdl, "MAXIMUM_DEPTH", max_depth, & + units="m", default=-1.e9, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "BETA", beta, & + "The northward gradient of the Coriolis parameter with the betaplane option.", & + units="m-1 s-1", default=0.0, scale=US%T_to_s*US%L_to_m, do_not_log=.true.) + + if (just_read) return ! All run-time parameters have been read, so return. + + if (max_depth <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_velocity: "//& + "This module requires a positive value of MAXIMUM_DEPTH.") + if (abs(beta) <= 0.0) call MOM_error(FATAL, & + "soliton_initialization, soliton_initialize_velocity: "//& + "This module requires a non-zero value of BETA.") + + cg_max = sqrt(GV%g_Earth * max_depth) + L_eq = sqrt(cg_max / abs(beta)) + scale_pos = US%m_to_L / L_eq + x0 = 2.0*G%len_lon/3.0 y0 = 0.0 val1 = 0.395 - val2 = US%m_s_to_L_T * 0.771*(val1*val1) + val2 = cg_max * 0.771*(val1*val1) v(:,:,:) = 0.0 u(:,:,:) = 0.0 do j = G%jsc,G%jec ; do I = G%isc-1,G%iec+1 do k = 1, nz - x = 0.5*(G%geoLonT(i+1,j)+G%geoLonT(i,j))-x0 - y = 0.5*(G%geoLatT(i+1,j)+G%geoLatT(i,j))-y0 + x = (0.5*(G%geoLonT(i+1,j)+G%geoLonT(i,j))-x0) * scale_pos + y = (0.5*(G%geoLatT(i+1,j)+G%geoLatT(i,j))-y0) * scale_pos val3 = exp(-val1*x) val4 = val2*((2.0*val3/(1.0+(val3*val3)))**2) u(I,j,k) = 0.25*val4*(6.0*y*y-9.0) * exp(-0.5*y*y) From 3c87d981dc4a895fa7528a1b805078085370c27a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 May 2024 03:53:38 -0400 Subject: [PATCH 614/629] (*)Correct rescaling of KPP pseudo-salt flux Calculate the rescaled pseudo-salt flux when KPP is in use inside of pseudo_salt_tracer_column_physics(), rather than using fluxes%KPP_salt_flux. This commit also corrects for the fact that salinity and pseudo-salt have scaling that differs by a factor of US%S_to_ppt, which was not previously being taken into account. All answers are bitwise identical when no dimensional rescaling is being used, but they will change (and be corrected) when salinity is being rescaled. --- src/tracer/pseudo_salt_tracer.F90 | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/src/tracer/pseudo_salt_tracer.F90 b/src/tracer/pseudo_salt_tracer.F90 index 1185f70d22..ade36bad19 100644 --- a/src/tracer/pseudo_salt_tracer.F90 +++ b/src/tracer/pseudo_salt_tracer.F90 @@ -196,6 +196,8 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G ! h_new(k) = h_old(k) + ea(k) - eb(k-1) + eb(k) - ea(k+1) ! Local variables + real :: net_salt_rate(SZI_(G),SZJ_(G)) ! Net salt flux into the ocean + ! [ppt H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real :: net_salt(SZI_(G),SZJ_(G)) ! Net salt flux into the ocean integrated over ! a timestep [ppt H ~> ppt m or ppt kg m-2] real :: htot(SZI_(G)) ! Total ocean depth [H ~> m or kg m-2] @@ -216,11 +218,27 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G call hchksum(CS%ps,"pseudo_salt pre pseudo-salt vertdiff", G%HI) endif + FluxRescaleDepth = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) + Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth + ! Compute KPP nonlocal term if necessary if (present(KPP_CSp)) then - if (associated(KPP_CSp) .and. present(nonLocalTrans)) & - call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, fluxes%KPP_salt_flux(:,:), & + if (associated(KPP_CSp) .and. present(nonLocalTrans)) then + ! Determine the salt flux, including limiting for small total ocean depths. + net_salt_rate(:,:) = 0.0 + if (associated(fluxes%salt_flux)) then + do j=js,je + do i=is,ie ; htot(i) = h_old(i,j,1) ; enddo + do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h_old(i,j,k) ; enddo ; enddo + do i=is,ie + scale = 1.0 ; if ((Ih_limit > 0.0) .and. (htot(i)*Ih_limit < 1.0)) scale = htot(i)*Ih_limit + net_salt_rate(i,j) = (scale * (1000.0 * fluxes%salt_flux(i,j))) * GV%RZ_to_H + enddo + enddo + endif + call KPP_NonLocalTransport(KPP_CSp, G, GV, h_old, nonLocalTrans, net_salt_rate, & dt, CS%diag, CS%tr_ptr, CS%ps(:,:,:)) + endif endif ! This uses applyTracerBoundaryFluxesInOut, usually in ALE mode @@ -229,8 +247,6 @@ subroutine pseudo_salt_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G ! Determine the time-integrated salt flux, including limiting for small total ocean depths. net_Salt(:,:) = 0.0 - FluxRescaleDepth = max( GV%Angstrom_H, 1.e-30*GV%m_to_H ) - Ih_limit = 0.0 ; if (FluxRescaleDepth > 0.0) Ih_limit = 1.0 / FluxRescaleDepth do j=js,je do i=is,ie ; htot(i) = h_old(i,j,1) ; enddo do k=2,nz ; do i=is,ie ; htot(i) = htot(i) + h_old(i,j,k) ; enddo ; enddo From 506d1864ca51452cce32b85a326d0f7fd8949677 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sat, 11 May 2024 03:54:21 -0400 Subject: [PATCH 615/629] +Eliminate fluxes%KPP_salt_flux Eliminated the KPP_salt_flux element of the forcing type, which is no longer being used after the revisions to pseudo_salt_tracer_column_physics. Also moved 5 allocatable arrays (KPP_NLTheat, KPP_NLTscalar, KPP_buoy_flux, KPP_temp_flux and KPP_salt_flux) out of diabatic_CS, replacing them with ordinary arrays in diabatic_ALE(), diabatic_ALE_legacy() and layered_diabatic(). This change could reduce the high-water memory footprint of the model when KPP is in use. All answers are bitwise identical, but one element of a publicly visible type has been eliminated. --- src/core/MOM_forcing_type.F90 | 3 +- .../vertical/MOM_diabatic_driver.F90 | 149 ++++++++---------- 2 files changed, 70 insertions(+), 82 deletions(-) diff --git a/src/core/MOM_forcing_type.F90 b/src/core/MOM_forcing_type.F90 index 452161c6ca..72c67253ed 100644 --- a/src/core/MOM_forcing_type.F90 +++ b/src/core/MOM_forcing_type.F90 @@ -126,9 +126,8 @@ module MOM_forcing_type real, pointer, dimension(:,:) :: & netMassIn => NULL(), & !< Sum of water mass fluxes into the ocean integrated over a !! forcing timestep [H ~> m or kg m-2] - netMassOut => NULL(), & !< Net water mass flux out of the ocean integrated over a forcing timestep, + netMassOut => NULL() !< Net water mass flux out of the ocean integrated over a forcing timestep, !! with negative values for water leaving the ocean [H ~> m or kg m-2] - KPP_salt_flux => NULL() !< KPP effective salt flux [ppt m s-1] ! heat associated with water crossing ocean surface real, pointer, dimension(:,:) :: & diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 081f065f3e..010f17b978 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -244,15 +244,6 @@ module MOM_diabatic_driver type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass type(group_pass_type) :: pass_Kv !< For group halo pass type(diag_grid_storage) :: diag_grids_prev!< Stores diagnostic grids at some previous point in the algorithm - ! Data arrays for communicating between components - !### Why are these arrays in this control structure, and not local variables in the various routines? - real, allocatable, dimension(:,:,:) :: KPP_NLTheat !< KPP non-local transport for heat [nondim] - real, allocatable, dimension(:,:,:) :: KPP_NLTscalar !< KPP non-local transport for scalars [nondim] - real, allocatable, dimension(:,:,:) :: KPP_buoy_flux !< KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] - real, allocatable, dimension(:,:) :: KPP_temp_flux !< KPP effective temperature flux - !! [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] - real, allocatable, dimension(:,:) :: KPP_salt_flux !< KPP effective salt flux - !! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type diabatic_CS @@ -558,11 +549,16 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_ePBL, & ! test array of diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KPP_NLTheat, & ! KPP non-local transport for heat [nondim] + KPP_NLTscalar, & ! KPP non-local transport for scalars [nondim] + KPP_buoy_flux, & ! KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & @@ -677,11 +673,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux + ! NOTE: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux) ! Determine the friction velocity, perhaps using the evovling surface density. call find_ustar(fluxes, tv, U_star, G, GV, US) @@ -689,16 +685,16 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - U_star, CS%KPP_buoy_flux, Waves=Waves) + U_star, KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif if (associated(Hml)) then @@ -708,7 +704,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif if (associated(visc%sfc_buoy_flx)) then - visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) endif @@ -733,18 +729,18 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_thermovar_chksum("after KPP", tv, G, US) call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, KPP_NLTheat, KPP_temp_flux, & dt, tv%tr_T, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, KPP_NLTscalar, KPP_salt_flux, & dt, tv%tr_S, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") @@ -755,7 +751,6 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G, US) endif - if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux endif ! endif for KPP ! This is the "old" method for applying differential diffusion. @@ -1084,7 +1079,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=CS%KPP_NLTscalar, & + nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & minimum_forcing_depth=CS%minimum_forcing_depth) @@ -1174,11 +1169,16 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to ! Kd_int returned from set_diffusivity [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_ePBL, & ! boundary layer or convective diapycnal diffusivities at interfaces [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KPP_NLTheat, & ! KPP non-local transport for heat [nondim] + KPP_NLTscalar, & ! KPP non-local transport for scalars [nondim] + KPP_buoy_flux, & ! KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] real, dimension(SZI_(G),SZJ_(G)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] SkinBuoyFlux ! 2d surface buoyancy flux [Z2 T-3 ~> m2 s-3], used by ePBL logical, dimension(SZI_(G)) :: & @@ -1298,11 +1298,11 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux + ! NOTE: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux) ! Determine the friction velocity, perhaps using the evovling surface density. call find_ustar(fluxes, tv, U_star, G, GV, US) @@ -1310,16 +1310,16 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! The KPP scheme calculates boundary layer diffusivities and non-local transport. if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - U_star, CS%KPP_buoy_flux, Waves=Waves) + U_star, KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif if (associated(Hml)) then @@ -1329,7 +1329,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif if (associated(visc%sfc_buoy_flx)) then - visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) endif @@ -1340,18 +1340,18 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_thermovar_chksum("after KPP", tv, G, US) call hchksum(Kd_heat, "after KPP Kd_heat", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(Kd_salt, "after KPP Kd_salt", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, KPP_NLTheat, KPP_temp_flux, & dt, tv%tr_T, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, KPP_NLTscalar, KPP_salt_flux, & dt, tv%tr_S, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") @@ -1362,7 +1362,6 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call MOM_forcing_chksum("after KPP_applyNLT ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after KPP_applyNLT ", tv, G, US) endif - if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux endif ! endif for KPP ! Calculate vertical mixing due to convection (computed via CVMix) @@ -1607,7 +1606,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=CS%KPP_NLTscalar, & + nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & minimum_forcing_depth=CS%minimum_forcing_depth) @@ -1693,6 +1692,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)) :: & U_star, & ! The friction velocity [Z T-1 ~> m s-1]. + KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] + KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] Rcv_ml ! Coordinate density of mixed layer [R ~> kg m-3], used for applying sponges real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), target :: & @@ -1710,6 +1711,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] Kd_extra_S , & ! The extra diffusivity of salinity due to double diffusion relative to ! Kd_int [H Z T-1 ~> m2 s-1 or kg m-1 s-1] + KPP_NLTheat, & ! KPP non-local transport for heat [nondim] + KPP_NLTscalar, & ! KPP non-local transport for scalars [nondim] + KPP_buoy_flux, & ! KPP forcing buoyancy flux [L2 T-3 ~> m2 s-3] Tdif_flx, & ! diffusive diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Tadv_flx, & ! advective diapycnal heat flux across interfaces [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] Sdif_flx, & ! diffusive diapycnal salt flux across interfaces [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1902,11 +1906,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call cpu_clock_begin(id_clock_kpp) ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. - ! Sets: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux - ! NOTE: CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux are returned as rates (i.e. stuff per second) + ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux + ! NOTE: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux are returned as rates (i.e. stuff per second) ! unlike other instances where the fluxes are integrated in time over a time-step. call calculateBuoyancyFlux2d(G, GV, US, fluxes, CS%optics, h, tv%T, tv%S, tv, & - CS%KPP_buoy_flux, CS%KPP_temp_flux, CS%KPP_salt_flux) + KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux) ! The KPP scheme calculates boundary layer diffusivities and non-local transport. ! Set diffusivities for heat and salt separately @@ -1931,16 +1935,16 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if ( associated(fluxes%lamult) ) then call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - U_star, CS%KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) + U_star, KPP_buoy_flux, Waves=Waves, lamult=fluxes%lamult) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves, lamult=fluxes%lamult) else call KPP_compute_BLD(CS%KPP_CSp, G, GV, US, h, tv%T, tv%S, u, v, tv, & - U_star, CS%KPP_buoy_flux, Waves=Waves) + U_star, KPP_buoy_flux, Waves=Waves) - call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, CS%KPP_buoy_flux, Kd_heat, & - Kd_salt, visc%Kv_shear, CS%KPP_NLTheat, CS%KPP_NLTscalar, Waves=Waves) + call KPP_calculate(CS%KPP_CSp, G, GV, US, h, tv, U_star, KPP_buoy_flux, Kd_heat, & + Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif if (associated(Hml)) then @@ -1950,7 +1954,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) endif if (associated(visc%sfc_buoy_flx)) then - visc%sfc_buoy_flx(:,:) = CS%KPP_buoy_flux(:,:,1) + visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) endif @@ -1977,7 +1981,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call hchksum(Kd_lay, "after KPP Kd_lay", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) call hchksum(Kd_Int, "after KPP Kd_Int", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif - if (.not.associated(fluxes%KPP_salt_flux)) fluxes%KPP_salt_flux => CS%KPP_salt_flux endif ! endif for KPP ! Add vertical diff./visc. due to convection (computed via CVMix) @@ -1988,18 +1991,18 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%useKPP) then call cpu_clock_begin(id_clock_kpp) if (CS%debug) then - call hchksum(CS%KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & + call hchksum(KPP_temp_flux, "before KPP_applyNLT netHeat", G%HI, haloshift=0, & scale=US%C_to_degC*GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & + call hchksum(KPP_salt_flux, "before KPP_applyNLT netSalt", G%HI, haloshift=0, & scale=US%S_to_ppt*GV%H_to_m*US%s_to_T) - call hchksum(CS%KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) - call hchksum(CS%KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) + call hchksum(KPP_NLTheat, "before KPP_applyNLT NLTheat", G%HI, haloshift=0) + call hchksum(KPP_NLTscalar, "before KPP_applyNLT NLTscalar", G%HI, haloshift=0) endif ! Apply non-local transport of heat and salt ! Changes: tv%T, tv%S - call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, CS%KPP_NLTheat, CS%KPP_temp_flux, & + call KPP_NonLocalTransport_temp(CS%KPP_CSp, G, GV, h, KPP_NLTheat, KPP_temp_flux, & dt, tv%tr_T, tv%T, tv%C_p) - call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, CS%KPP_NLTscalar, CS%KPP_salt_flux, & + call KPP_NonLocalTransport_saln(CS%KPP_CSp, G, GV, h, KPP_NLTscalar, KPP_salt_flux, & dt, tv%tr_S, tv%S) call cpu_clock_end(id_clock_kpp) if (showCallTree) call callTree_waypoint("done with KPP_applyNonLocalTransport (diabatic)") @@ -2401,7 +2404,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=CS%KPP_NLTscalar) + nonLocalTrans=KPP_NLTscalar) elseif (CS%double_diffuse) then ! extra diffusivity for passive tracers @@ -2423,13 +2426,13 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=CS%KPP_NLTscalar) + nonLocalTrans=KPP_NLTscalar) else call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=CS%KPP_NLTscalar) + nonLocalTrans=KPP_NLTscalar) endif ! (CS%mix_boundary_tracers) @@ -3315,14 +3318,6 @@ subroutine diabatic_driver_init(Time, G, GV, US, param_file, useALEalgorithm, di ! CS%useKPP is set to True if KPP-scheme is to be used, False otherwise. ! KPP_init() allocated CS%KPP_Csp and also sets CS%KPPisPassive CS%useKPP = KPP_init(param_file, G, GV, US, diag, Time, CS%KPP_CSp, passive=CS%KPPisPassive) - if (CS%useKPP) then - allocate(CS%KPP_NLTheat(isd:ied,jsd:jed,nz+1), source=0.0) - allocate(CS%KPP_NLTscalar(isd:ied,jsd:jed,nz+1), source=0.0) - allocate(CS%KPP_buoy_flux(isd:ied,jsd:jed,nz+1), source=0.0) - allocate(CS%KPP_temp_flux(isd:ied,jsd:jed), source=0.0) - allocate(CS%KPP_salt_flux(isd:ied,jsd:jed), source=0.0) - endif - ! Diagnostics for tendencies of temperature and salinity due to diabatic processes, ! available only for ALE algorithm. @@ -3616,14 +3611,8 @@ subroutine diabatic_driver_end(CS) if (CS%use_geothermal) & call geothermal_end(CS%geothermal) - if (CS%useKPP) then - deallocate( CS%KPP_buoy_flux ) - deallocate( CS%KPP_temp_flux ) - deallocate( CS%KPP_salt_flux ) - deallocate( CS%KPP_NLTheat ) - deallocate( CS%KPP_NLTscalar ) + if (CS%useKPP) & call KPP_end(CS%KPP_CSp) - endif ! GMM, the following is commented out because arrays in ! CS%diag_grids_prev are neither pointers or allocatables From c121215cbfbfc0944418abb4ea3490649f97c946 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 24 May 2024 05:23:22 -0400 Subject: [PATCH 616/629] Fix TEOS10 argument descriptions Corrected the descriptions of several conservative temperature and absolute salinity arguments in the comments for arguments to 4 TEOS10 equation of state routines, and eliminated the commented out code to mask out negative salinities in 8 TEOS10 routines. Only comments are changed, and all answers are bitwise identical. --- src/equation_of_state/MOM_EOS_TEOS10.F90 | 139 +++++++++-------------- 1 file changed, 53 insertions(+), 86 deletions(-) diff --git a/src/equation_of_state/MOM_EOS_TEOS10.F90 b/src/equation_of_state/MOM_EOS_TEOS10.F90 index 3f138e20bb..6e4aaa762f 100644 --- a/src/equation_of_state/MOM_EOS_TEOS10.F90 +++ b/src/equation_of_state/MOM_EOS_TEOS10.F90 @@ -50,13 +50,6 @@ real elemental function density_elem_TEOS10(this, T, S, pressure) real, intent(in) :: S !< Absolute salinity [g kg-1]. real, intent(in) :: pressure !< pressure [Pa]. - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA -! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? -! density_elem_TEOS10 = 1000.0 -! else -! density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) -! endif - density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) end function density_elem_TEOS10 @@ -69,13 +62,6 @@ real elemental function density_anomaly_elem_TEOS10(this, T, S, pressure, rho_re real, intent(in) :: pressure !< pressure [Pa]. real, intent(in) :: rho_ref !< A reference density [kg m-3]. - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA -! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? -! density_elem_TEOS10 = 1000.0 -! else -! density_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) -! endif - density_anomaly_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) density_anomaly_elem_TEOS10 = density_anomaly_elem_TEOS10 - rho_ref @@ -88,13 +74,6 @@ real elemental function spec_vol_elem_TEOS10(this, T, S, pressure) real, intent(in) :: S !< Absolute salinity [g kg-1]. real, intent(in) :: pressure !< pressure [Pa]. - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA -! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? -! spec_vol_elem_TEOS10 = 0.001 -! else -! spec_vol_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) -! endif - spec_vol_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) end function spec_vol_elem_TEOS10 @@ -107,13 +86,6 @@ real elemental function spec_vol_anomaly_elem_TEOS10(this, T, S, pressure, spv_r real, intent(in) :: pressure !< pressure [Pa]. real, intent(in) :: spv_ref !< A reference specific volume [m3 kg-1]. - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA -! if (S < -1.0e-10) then ! Can we assume safely that this is a missing value? -! spec_vol_elem_TEOS10 = 0.001 -! else -! spec_vol_elem_TEOS10 = gsw_rho(S, T, pressure * Pa2db) -! endif - spec_vol_anomaly_elem_TEOS10 = gsw_specvol(S, T, pressure * Pa2db) - spv_ref end function spec_vol_anomaly_elem_TEOS10 @@ -122,28 +94,27 @@ end function spec_vol_anomaly_elem_TEOS10 !! temperature and absolute salinity, using the TEOS10 expressions. elemental subroutine calculate_density_derivs_elem_TEOS10(this, T, S, pressure, drho_dT, drho_dS) class(TEOS10_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< Potential temperature relative to the surface [degC] - real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] = [ppt] real, intent(in) :: pressure !< Pressure [Pa] - real, intent(out) :: drho_dT !< The partial derivative of density with potential + 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 salinity, - !! in [kg m-3 PSU-1] + !! in [kg m-3 ppt-1] ! Local variables real :: zs ! Absolute salinity [g kg-1] real :: zt ! Conservative temperature [degC] real :: zp ! Pressure converted to decibars [dbar] - !Conversions - zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp - zp = pressure* Pa2db !Convert pressure from Pascal to decibar - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA - !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? - ! drho_dT = 0.0 ; drho_dS = 0.0 - !else - call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) - !endif + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp + + call gsw_rho_first_derivatives(zs, zt, zp, drho_dsa=drho_dS, drho_dct=drho_dT) end subroutine calculate_density_derivs_elem_TEOS10 @@ -151,17 +122,17 @@ end subroutine calculate_density_derivs_elem_TEOS10 elemental subroutine calculate_density_second_derivs_elem_TEOS10(this, T, S, pressure, & drho_dS_dS, drho_dS_dT, drho_dT_dT, drho_dS_dP, drho_dT_dP) class(TEOS10_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< Potential temperature referenced to 0 dbar [degC] - real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] = [ppt] real, intent(in) :: pressure !< Pressure [Pa] real, intent(inout) :: drho_ds_ds !< Partial derivative of beta with respect - !! to S [kg m-3 PSU-2] + !! to S [kg m-3 ppt-2] real, intent(inout) :: drho_ds_dt !< Partial derivative of beta with respect - !! to T [kg m-3 PSU-1 degC-1] + !! to T [kg m-3 ppt-1 degC-1] real, intent(inout) :: drho_dt_dt !< Partial derivative of alpha with respect !! to T [kg m-3 degC-2] real, 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] + !! to pressure [kg m-3 ppt-1 Pa-1] = [s2 m-2 ppt-1] real, 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] ! Local variables @@ -169,18 +140,16 @@ elemental subroutine calculate_density_second_derivs_elem_TEOS10(this, T, S, pre real :: zt ! Conservative temperature [degC] real :: zp ! Pressure converted to decibars [dbar] - !Conversions - zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp - zp = pressure* Pa2db !Convert pressure from Pascal to decibar - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA - !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? - ! drho_dS_dS = 0.0 ; drho_dS_dT = 0.0 ; drho_dT_dT = 0.0 - ! drho_dS_dP = 0.0 ; drho_dT_dP = 0.0 - !else - call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & - rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) - !endif + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp + + call gsw_rho_second_derivatives(zs, zt, zp, rho_sa_sa=drho_dS_dS, rho_sa_ct=drho_dS_dT, & + rho_ct_ct=drho_dT_dT, rho_sa_p=drho_dS_dP, rho_ct_p=drho_dT_dP) end subroutine calculate_density_second_derivs_elem_TEOS10 @@ -188,28 +157,27 @@ end subroutine calculate_density_second_derivs_elem_TEOS10 !! temperature and absolute salinity, using the TEOS10 expressions. elemental subroutine calculate_specvol_derivs_elem_TEOS10(this, T, S, pressure, dSV_dT, dSV_dS) class(TEOS10_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< Potential temperature [degC] - real, intent(in) :: S !< Salinity [PSU] + real, intent(in) :: T !< Conservative temperature [degC] + real, intent(in) :: S !< Absolute salinity [g kg-1] = [ppt] real, intent(in) :: pressure !< Pressure [Pa] real, intent(inout) :: dSV_dT !< The partial derivative of specific volume with - !! potential temperature [m3 kg-1 degC-1] + !! conservative temperature [m3 kg-1 degC-1] real, intent(inout) :: dSV_dS !< The partial derivative of specific volume with - !! salinity [m3 kg-1 PSU-1] + !! absolute salinity [m3 kg-1 ppt-1] ! Local variables real :: zs ! Absolute salinity [g kg-1] real :: zt ! Conservative temperature [degC] real :: zp ! Pressure converted to decibars [dbar] - !Conversions - zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp - zp = pressure* Pa2db !Convert pressure from Pascal to decibar - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA - !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? - ! dSV_dT = 0.0 ; dSV_dS = 0.0 - !else - call gsw_specvol_first_derivatives(zs,zt,zp, v_sa=dSV_dS, v_ct=dSV_dT) - !endif + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp + + call gsw_specvol_first_derivatives(zs, zt, zp, v_sa=dSV_dS, v_ct=dSV_dT) end subroutine calculate_specvol_derivs_elem_TEOS10 @@ -220,8 +188,8 @@ end subroutine calculate_specvol_derivs_elem_TEOS10 !! subroutines from TEOS10 website elemental subroutine calculate_compress_elem_TEOS10(this, T, S, pressure, rho, drho_dp) class(TEOS10_EOS), intent(in) :: this !< This EOS - real, intent(in) :: T !< Potential temperature relative to the surface [degC] - real, intent(in) :: S !< Salinity [PSU] + 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, intent(out) :: drho_dp !< The partial derivative of density with pressure @@ -233,17 +201,16 @@ elemental subroutine calculate_compress_elem_TEOS10(this, T, S, pressure, rho, d real :: zt ! Conservative temperature [degC] real :: zp ! Pressure converted to decibars [dbar] - !Conversions - zs = S !gsw_sr_from_sp(S) !Convert practical salinity to absolute salinity - zt = T !gsw_ct_from_pt(S,T) !Convert potential temp to conservative temp - zp = pressure* Pa2db !Convert pressure from Pascal to decibar - !!! #### This code originally had this "masking" line. The answer to the question below is "no" -AJA - !if (S < -1.0e-10) then !Can we assume safely that this is a missing value? - ! rho = 1000.0 ; drho_dp = 0.0 - !else - rho = gsw_rho(zs,zt,zp) - call gsw_rho_first_derivatives(zs,zt,zp, drho_dp=drho_dp) - !endif + ! Conversions + zs = S + zt = T + zp = pressure * Pa2db ! Convert pressure from Pascal to decibar + ! The following conversions are unnecessary because the arguments are already the right variables. + ! zs = gsw_sr_from_sp(S) ! Uncomment to convert practical salinity to absolute salinity + ! zt = gsw_ct_from_pt(S,T) ! Uncomment to convert potential temp to conservative temp + + rho = gsw_rho(zs, zt, zp) + call gsw_rho_first_derivatives(zs, zt, zp, drho_dp=drho_dp) end subroutine calculate_compress_elem_TEOS10 From 836e696c2e1fdf088150744e42a6aceb1536a184 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Apr 2024 06:46:00 -0400 Subject: [PATCH 617/629] +Add convert_MLD_to_ML_thickness Added the routine convert_MLD_to_ML_thickness to consistently convert the mixed layer depths (in units of [Z ~> m]) back to the mixed layer thicknesses (in [H ~> m or kg m-2]), with proper error checking and handling of the non-Boussinesq case. The body of this routine was taken from duplicated blocks of code in MOM_mixedlayer_restrat.F90. This is not tested directly in this PR, but it was tested via revisions to MOM_mixedlayer_restrat.F90 that are included in a subsequent commit. All answers are bitwise identical, but there is a new publicly visible interface. --- src/core/MOM_interface_heights.F90 | 66 ++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) diff --git a/src/core/MOM_interface_heights.F90 b/src/core/MOM_interface_heights.F90 index 6681034cb9..3891c86e3a 100644 --- a/src/core/MOM_interface_heights.F90 +++ b/src/core/MOM_interface_heights.F90 @@ -19,6 +19,7 @@ module MOM_interface_heights public find_eta, dz_to_thickness, thickness_to_dz, dz_to_thickness_simple public calc_derived_thermo +public convert_MLD_to_ML_thickness public find_rho_bottom, find_col_avg_SpV !> Calculates the heights of the free surface or all interfaces from layer thicknesses. @@ -824,4 +825,69 @@ subroutine thickness_to_dz_jslice(h, tv, dz, j, G, GV, halo_size) end subroutine thickness_to_dz_jslice + +!> Convert mixed layer depths in height units into the thickness of water in the mixed +!! in thickness units. +subroutine convert_MLD_to_ML_thickness(MLD_in, h, h_MLD, tv, G, GV, 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 + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: MLD_in !< Input mixed layer depth [Z ~> m]. + 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(out) :: h_MLD !< Thickness of water in the mixed layer [H ~> m or kg m-2] + type(thermo_var_ptrs), intent(in) :: tv !< Structure containing pointers to any available + !! thermodynamic fields. + integer, optional, intent(in) :: halo !< Halo width over which to calculate frazil + + ! Local variables + real :: MLD_rem(SZI_(G)) ! The vertical extent of the MLD_in that has not yet been accounted for [Z ~> m] + character(len=128) :: mesg ! A string for error messages + logical :: keep_going + integer :: i, j, k, is, ie, js, je, nz, halos + + is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke + + halos = 0 ; if (present(halo)) halos = halo + if (present(halo)) then + is = G%isc-halo ; ie = G%iec+halo ; js = G%jsc-halo ; je = G%jec+halo + endif + + if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then + do j=js,je ; do i=is,ie + h_MLD(i,j) = GV%Z_to_H * MLD_in(i,j) + enddo ; enddo + else ! The fully non-Boussinesq conversion between height in MLD_in and thickness. + if ((allocated(tv%SpV_avg)) .and. (tv%valid_SpV_halo < halos)) then + if (tv%valid_SpV_halo < 0) then + mesg = "invalid values of SpV_avg." + else + write(mesg, '("insufficiently large SpV_avg halos of width ", i2, " but ", i2," is needed.")') & + tv%valid_SpV_halo, halos + endif + call MOM_error(FATAL, "convert_MLD_to_ML_thickness called in fully non-Boussinesq mode with "//trim(mesg)) + endif + + do j=js,je + do i=is,ie ; MLD_rem(i) = MLD_in(i,j) ; h_MLD(i,j) = 0.0 ; enddo + do k=1,nz + keep_going = .false. + do i=is,ie ; if (MLD_rem(i) > 0.0) then + if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then + h_MLD(i,j) = h_MLD(i,j) + h(i,j,k) + MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) + keep_going = .true. + else + h_MLD(i,j) = h_MLD(i,j) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) + MLD_rem(i) = 0.0 + endif + endif ; enddo + if (.not.keep_going) exit + enddo + enddo + endif + +end subroutine convert_MLD_to_ML_thickness + end module MOM_interface_heights From 2035af3d2d12e3cbc4885f893d91c9fabdc5a5ba Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Apr 2024 06:46:59 -0400 Subject: [PATCH 618/629] +*Use thickness in ideal_age_tracer_column_physics Pass mixed layer thickness, rather than mixed layer depth, to ideal_age_tracer_column_physics, and determine the number of layers within the mixed layer in count_BL_layers in thickness units rather than depth units. To accommodate these changes there is now a call to convert_MLD_to_ML_thickness inside of call_tracer_column_fns. The thermo_var_ptrs type argument (tv) to ideal_age_tracer_column_physics and count_BL_layers are no longer used and have been removed. All answers are bitwise identical in Boussinesq mode, but in non-Boussinesq mode there are changes in the passive ideal age tracers at the level of roundoff. There are also changes in the units of arguments and the number of arguments to a public interface. --- src/tracer/MOM_tracer_flow_control.F90 | 27 +++++++++++++++--------- src/tracer/ideal_age_example.F90 | 29 +++++++++++--------------- 2 files changed, 29 insertions(+), 27 deletions(-) diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 6d035e1d27..10aba675da 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -11,6 +11,7 @@ module MOM_tracer_flow_control use MOM_get_input, only : Get_MOM_input use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type +use MOM_interface_heights, only : convert_MLD_to_ML_thickness use MOM_CVMix_KPP, only : KPP_CS use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : MOM_restart_CS @@ -427,7 +428,7 @@ subroutine call_tracer_set_forcing(sfc_state, fluxes, day_start, day_interval, G end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. -subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, US, tv, optics, CS, & +subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, US, tv, optics, CS, & debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. @@ -444,7 +445,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, type(forcing), intent(in) :: fluxes !< A structure containing pointers to !! any possible forcing fields. !! Unused fields have NULL ptrs. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hml !< Mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: mld !< Mixed layer depth [Z ~> m] real, intent(in) :: dt !< The amount of time covered by this !! call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -464,6 +465,9 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over !! which fluxes can be applied [H ~> m or kg m-2] + ! Local variables + real :: Hbl(SZI_(G),SZJ_(G)) !< Boundary layer thickness [H ~> m or kg m-2] + if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_column_fns: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -488,12 +492,13 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, G, GV, US, CS%RGC_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) - if (CS%use_ideal_age) & + if (CS%use_ideal_age) then + call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, tv, CS%ideal_age_tracer_CSp, & + G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & - minimum_forcing_depth=minimum_forcing_depth, & - Hbl=Hml) + minimum_forcing_depth=minimum_forcing_depth, Hbl=Hbl) + endif if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, tv, CS%dye_tracer_CSp, & @@ -526,7 +531,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& "[QRZT]_RESCALE_POWER parameters to 0.") - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, mld, dt, & G, GV, US, CS%MOM_generic_tracer_CSp, tv, optics, & evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) @@ -567,9 +572,11 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (CS%use_RGC_tracer) & call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%RGC_tracer_CSp) - if (CS%use_ideal_age) & + if (CS%use_ideal_age) then + call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & - G, GV, US, tv, CS%ideal_age_tracer_CSp, Hbl=Hml) + G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hbl) + endif if (CS%use_regional_dyes) & call dye_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, tv, CS%dye_tracer_CSp) @@ -591,7 +598,7 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, Hml, dt, G, GV, if (US%QRZ_T_to_W_m2 /= 1.0) call MOM_error(FATAL, "MOM_generic_tracer_column_physics "//& "has not been written to permit dimensionsal rescaling. Set all 4 of the "//& "[QRZT]_RESCALE_POWER parameters to 0.") - call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, Hml, dt, & + call MOM_generic_tracer_column_physics(h_old, h_new, ea, eb, fluxes, mld, dt, & G, GV, US, CS%MOM_generic_tracer_CSp, tv, optics) endif if (CS%use_pseudo_salt_tracer) & diff --git a/src/tracer/ideal_age_example.F90 b/src/tracer/ideal_age_example.F90 index 1d04e94589..4323479823 100644 --- a/src/tracer/ideal_age_example.F90 +++ b/src/tracer/ideal_age_example.F90 @@ -12,7 +12,6 @@ module ideal_age_example use MOM_grid, only : ocean_grid_type use MOM_hor_index, only : hor_index_type use MOM_io, only : file_exists, MOM_read_data, slasher, vardesc, var_desc, query_vardesc -use MOM_interface_heights, only : thickness_to_dz use MOM_open_boundary, only : ocean_OBC_type use MOM_restart, only : query_initialized, set_initialized, MOM_restart_CS use MOM_spatial_means, only : global_mass_int_EFP @@ -22,7 +21,7 @@ module ideal_age_example use MOM_tracer_diabatic, only : tracer_vertdiff, applyTracerBoundaryFluxesInOut use MOM_tracer_Z_init, only : tracer_Z_init use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : surface, thermo_var_ptrs +use MOM_variables, only : surface use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -297,7 +296,7 @@ subroutine initialize_ideal_age_tracer(restart, day, G, GV, US, h, diag, OBC, CS end subroutine initialize_ideal_age_tracer !> Applies diapycnal diffusion, aging and regeneration at the surface to the ideal age tracers -subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, tv, CS, & +subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, GV, US, CS, & evap_CFL_limit, minimum_forcing_depth, Hbl) type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure @@ -317,14 +316,13 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, !! and tracer forcing fields. Unused fields have NULL ptrs. real, intent(in) :: dt !< The amount of time covered by this call [T ~> s] type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables type(ideal_age_tracer_CS), pointer :: CS !< The control structure returned by a previous !! call to register_ideal_age_tracer. real, optional, intent(in) :: evap_CFL_limit !< Limit on the fraction of the water that can !! be fluxed out of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over which !! fluxes can be applied [H ~> m or kg m-2] - real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hbl !< Boundary layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: Hbl !< Boundary layer thickness [H ~> m or kg m-2] ! This subroutine applies diapycnal diffusion and any other column ! tracer physics or chemistry to the tracers from this file. @@ -349,7 +347,7 @@ subroutine ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, G, endif if (CS%use_real_BL_depth .and. present(Hbl)) then - call count_BL_layers(G, GV, h_old, Hbl, tv, BL_layers) + call count_BL_layers(G, GV, h_old, Hbl, BL_layers) endif if (.not.associated(CS)) return @@ -578,30 +576,27 @@ subroutine ideal_age_example_end(CS) endif end subroutine ideal_age_example_end -subroutine count_BL_layers(G, GV, h, Hbl, tv, BL_layers) - type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure - type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure +subroutine count_BL_layers(G, GV, h, Hbl, BL_layers) + type(ocean_grid_type), intent(in) :: G !< The ocean's grid structure + type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. - real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer depth [Z ~> m] - type(thermo_var_ptrs), intent(in) :: tv !< A structure pointing to various thermodynamic variables + intent(in) :: h !< Layer thicknesses [H ~> m or kg m-2]. + real, dimension(SZI_(G),SZJ_(G)), intent(in) :: Hbl !< Boundary layer thickness [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G)), intent(out) :: BL_layers !< Number of model layers in the boundary layer [nondim] - real :: dz(SZI_(G),SZK_(GV)) ! Height change across layers [Z ~> m] - real :: current_depth ! Distance from the free surface [Z ~> m] + real :: current_depth ! Distance from the free surface [H ~> m or kg m-2] integer :: i, j, k, is, ie, js, je, nz, m, nk character(len=255) :: msg is = G%isc ; ie = G%iec ; js = G%jsc ; je = G%jec ; nz = GV%ke BL_layers(:,:) = 0. do j=js,je - call thickness_to_dz(h, tv, dz, j, G, GV) do i=is,ie current_depth = 0. do k=1,nz - current_depth = current_depth + dz(i,k) + current_depth = current_depth + h(i,j,k) if (Hbl(i,j) <= current_depth) then - BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / dz(i,k)) + BL_layers(i,j) = BL_layers(i,j) + (1.0 - (current_depth - Hbl(i,j)) / h(i,j,k)) exit else BL_layers(i,j) = BL_layers(i,j) + 1.0 From 912c56883b46d19c180659ad26fba8e3a10c64bc Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Tue, 23 Apr 2024 06:48:40 -0400 Subject: [PATCH 619/629] +Pass h_MLD to mixedlayer_restrat Provide the mixed layer thickness, as well as the mixed layer depth as arguments to mixedlayer_restrat. The code that had previously been used to convert between the two has now been removed to the new external function convert_MLD_to_ML_thickness. To accommodate these changes, a new element, h_ML, was added to the vertvisc type, and a call to convert_MLD_to_ML_thickness was temporarily added in step_MOM_dynamics just before the call to mixedlayer_restrat. All answers are bitwise identical, but there are changes to a public interface. --- src/core/MOM.F90 | 7 +- src/core/MOM_variables.F90 | 3 +- .../lateral/MOM_mixed_layer_restrat.F90 | 97 ++++++------------- 3 files changed, 35 insertions(+), 72 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0b602be944..0f3274c2f3 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -98,6 +98,7 @@ module MOM 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, calc_derived_thermo, thickness_to_dz +use MOM_interface_heights, only : convert_MLD_to_ML_thickness use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS use MOM_internal_tides, only : int_tide_CS @@ -1327,7 +1328,11 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_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, & + if (associated(CS%visc%MLD)) then + call safe_alloc_ptr(CS%visc%h_ML, G%isd, G%ied, G%jsd, G%jed) + call convert_MLD_to_ML_thickness(CS%visc%MLD, h, CS%visc%h_ML, CS%tv, G, GV, halo=1) + endif + call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & 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)) diff --git a/src/core/MOM_variables.F90 b/src/core/MOM_variables.F90 index cb20837d3b..2510ff95a5 100644 --- a/src/core/MOM_variables.F90 +++ b/src/core/MOM_variables.F90 @@ -263,7 +263,8 @@ module MOM_variables Ray_v !< The Rayleigh drag velocity to be applied to each layer at v-points [H T-1 ~> m s-1 or Pa s m-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(:,:) :: h_ML => NULL() !< Instantaneous active mixing layer thickness [H ~> m or kg m-2]. 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 diff --git a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 index 327d18cc7c..e7ada31430 100644 --- a/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 +++ b/src/parameterizations/lateral/MOM_mixed_layer_restrat.F90 @@ -132,7 +132,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, bflux, VarMix, G, GV, US, CS) +subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, h_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 @@ -146,11 +146,15 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, bflux, VarMix, 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 :: h_MLD !< Mixed layer thickness provided + !! by the planetary boundary layer + !! scheme [H ~> m or kg m-2] 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, "mixedlayer_restrat: "// & "Module must be initialized before it is used.") @@ -159,16 +163,16 @@ subroutine mixedlayer_restrat(h, uhtr, vhtr, tv, forces, dt, MLD, bflux, VarMix, 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) + call mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, MLD, h_MLD, bflux) 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) + call mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, VarMix, G, GV, US, CS) endif end subroutine mixedlayer_restrat !> 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) +subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, h_MLD, 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 @@ -181,8 +185,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, 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 :: MLD_in !< Mixed layer depth provided by the - !! PBL scheme [Z ~> m] + real, dimension(:,:), pointer :: h_MLD !< Thickness of water within the + !! mixed layer depth provided by + !! the PBL scheme [H ~> m or kg m-2] type(VarMix_CS), intent(in) :: VarMix !< Variable mixing control structure type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure @@ -212,8 +217,6 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] real :: SpV_int_fast(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] real :: SpV_int_slow(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] - real :: H_mld(SZI_(G)) ! The thickness of water within the topmost MLD_in of height [H ~> m or kg m-2] - real :: MLD_rem(SZI_(G)) ! The vertical extent of the MLD_in that has not yet been accounted for [Z ~> m] real :: p0(SZI_(G)) ! A pressure of 0 [R L2 T-2 ~> Pa] real :: h_vel ! htot interpolated onto velocity points [H ~> m or kg m-2] @@ -326,30 +329,9 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, enddo enddo ! j-loop elseif (CS%MLE_use_PBL_MLD) then - if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then - do j=js-1,je+1 ; do i=is-1,ie+1 - MLD_fast(i,j) = CS%MLE_MLD_stretch * GV%Z_to_H * MLD_in(i,j) - enddo ; enddo - else ! The fully non-Boussinesq conversion between height in MLD_in and thickness. - do j=js-1,je+1 - do i=is-1,ie+1 ; MLD_rem(i) = MLD_in(i,j) ; H_mld(i) = 0.0 ; enddo - do k=1,nz - keep_going = .false. - do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then - if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then - H_mld(i) = H_mld(i) + h(i,j,k) - MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) - keep_going = .true. - else - H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) - MLD_rem(i) = 0.0 - endif - endif ; enddo - if (.not.keep_going) exit - enddo - do i=is-1,ie+1 ; MLD_fast(i,j) = CS%MLE_MLD_stretch * H_mld(i) ; enddo - enddo - endif + do j=js-1,je+1 ; do i=is-1,ie+1 + MLD_fast(i,j) = CS%MLE_MLD_stretch * h_MLD(i,j) + enddo ; enddo else call MOM_error(FATAL, "mixedlayer_restrat_OM4: "// & "No MLD to use for MLE parameterization.") @@ -359,7 +341,7 @@ subroutine mixedlayer_restrat_OM4(h, uhtr, vhtr, tv, forces, dt, MLD_in, VarMix, if (CS%MLE_MLD_decay_time>0.) then if (CS%debug) then call hchksum(CS%MLD_filtered, 'mixed_layer_restrat: MLD_filtered', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(MLD_in, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(h_MLD, 'mixed_layer_restrat: MLD in', G%HI, haloshift=1, scale=GV%H_to_mks) endif aFac = CS%MLE_MLD_decay_time / ( dt + CS%MLE_MLD_decay_time ) bFac = dt / ( dt + CS%MLE_MLD_decay_time ) @@ -776,7 +758,7 @@ 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) +subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, dt, BLD, h_MLD, bflux) ! Arguments type(mixedlayer_restrat_CS), intent(inout) :: CS !< Module control structure type(ocean_grid_type), intent(inout) :: G !< Ocean grid structure @@ -792,6 +774,9 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d 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 :: h_MLD !< Thickness of water within the + !! active boundary layer depth provided by + !! the PBL scheme [H ~> m or kg m-2] real, dimension(:,:), pointer :: bflux !< Surface buoyancy flux provided by the !! PBL scheme [Z2 T-3 ~> m2 s-3] ! Local variables @@ -812,16 +797,12 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d real :: U_star_2d(SZI_(G),SZJ_(G)) ! The wind friction velocity, calculated using the Boussinesq ! reference density or the time-evolving surface density in non-Boussinesq ! mode [Z T-1 ~> m s-1] - real :: BLD_in_H(SZI_(G)) ! The thickness of the active boundary layer with the topmost BLD of - ! height [H ~> m or kg m-2] real :: covTS(SZI_(G)) ! SGS TS covariance in Stanley param; currently 0 [C S ~> degC ppt] real :: varS(SZI_(G)) ! SGS S variance in Stanley param; currently 0 [S2 ~> ppt2] real :: dmu(SZK_(GV)) ! Change in mu(z) across layer k [nondim] real :: Rml_int(SZI_(G)) ! Potential density integrated through the mixed layer [R H ~> kg m-2 or kg2 m-5] real :: SpV_ml(SZI_(G)) ! Specific volume evaluated at the surface pressure [R-1 ~> m3 kg-1] real :: SpV_int(SZI_(G)) ! Specific volume integrated through the mixed layer [H R-1 ~> m4 kg-1 or m] - real :: H_mld(SZI_(G)) ! The thickness of water within the topmost BLD of height [H ~> m or kg m-2] - real :: MLD_rem(SZI_(G)) ! The vertical extent of the BLD that has not yet been accounted for [Z ~> m] 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 times a thickness conversion factor @@ -886,7 +867,8 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d if (CS%debug) then call hchksum(h,'mixed_Bodner: h', G%HI, haloshift=1, scale=GV%H_to_mks) - call hchksum(BLD, 'mle_Bodner: BLD in', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(BLD, 'mle_Bodner: BLD', G%HI, haloshift=1, scale=US%Z_to_m) + call hchksum(h_MLD, 'mle_Bodner: h_MLD', G%HI, haloshift=1, scale=GV%H_to_mks) 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(U_star_2d, 'mle_Bodner: u*', G%HI, haloshift=1, scale=US%Z_to_m*US%s_to_T) @@ -896,38 +878,13 @@ subroutine mixedlayer_restrat_Bodner(CS, G, GV, US, h, uhtr, vhtr, tv, forces, d G%HI, haloshift=1, scale=GV%H_to_mks) endif - ! Apply time filter to BLD (to remove diurnal cycle) to obtain "little h". + ! Apply time filter to h_MLD (to remove diurnal cycle) to obtain "little h". ! "little h" is representative of the active mixing layer depth, used in B22 formula (eq 27). - if (GV%Boussinesq .or. (.not.allocated(tv%SpV_avg))) then - do j=js-1,je+1 ; do i=is-1,ie+1 - little_h(i,j) = rmean2ts(GV%Z_to_H*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 - else ! The fully non-Boussinesq conversion between height in BLD and thickness. - do j=js-1,je+1 - do i=is-1,ie+1 ; MLD_rem(i) = BLD(i,j) ; H_mld(i) = 0.0 ; enddo - do k=1,nz - keep_going = .false. - do i=is-1,ie+1 ; if (MLD_rem(i) > 0.0) then - if (MLD_rem(i) > GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k)) then - H_mld(i) = H_mld(i) + h(i,j,k) - MLD_rem(i) = MLD_rem(i) - GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) - keep_going = .true. - else - H_mld(i) = H_mld(i) + GV%RZ_to_H * MLD_rem(i) / tv%SpV_avg(i,j,k) - MLD_rem(i) = 0.0 - endif - endif ; enddo - if (.not.keep_going) exit - enddo - do i=is-1,ie+1 - little_h(i,j) = rmean2ts(H_mld(i), 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 - endif + do j=js-1,je+1 ; do i=is-1,ie+1 + little_h(i,j) = rmean2ts(h_MLD(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 From c3002089f9255351c599b7c197027ee128ce6a0b Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Apr 2024 05:37:10 -0400 Subject: [PATCH 620/629] +*Convert MLD to ML_thickness in diabatic Moved the call to convert mixed layer depths into mixed layer thicknesses from right before the call to mixedlayer_restrat into the various diabatic routines just after they are calculated. This code rearrangement changes answers in non-Boussinesq mode because the layer specific volumes will have evolved between these two calls, but it is consistent with the mixed layer thicknesses as used in the boundary layer parameterizations. A new argument was added to bulkmixedlayer to return the mixed layer thickness that was already being calculated. The previous argument Hml was renamed to BLD and changed from a pointer into a simple array. Both are intent(inout) rather than intent(out) to preserve values in halos. This commit also revises the logic around the allocation of visc%h_ML and its registration as a restart variable, including handling cases where an older restart file is being read that includes MLD but not h_ML. Because the mixed layer depth is used in almost cases, CS%Hml in the control structure for MOM.F90 was changed from a pointer to an allocatable, with values of 0 in those cases (e.g., when ADIABATIC is true) where it is not used. In addition, the argument Hml to the various diabatic routines was changed to MLD to more clearly reflect that it is a depth and not a thickness. Outside of diabatic, BML is only used to provide the tracer point boundary layer depths to the calling routines, so it does not need a halo update. Instead, all of the halo updates for the various elements of visc that do need halo updates after the diabatic calls are collected into one place for efficiency and more accurate timings. The scale arguments of 34 checksum calls were revised from GV%H_to_m to GV%H_to_MKS for more accurate checksums in non-Boussinesq configurations by avoiding multiplication by an reference specific volume, and instead only rescaling by an integer power of 2. All answers are bitwise identical in Boussinesq mode, but in non-Boussinesq mode there are changes in answers in cases that use the boundary layer thicknesses obtained from the boundary layer parameterizations in subsequent calculations, such as mixed layer restratification with some options. There are also changes to the arguments of several publicly visible routines. --- src/core/MOM.F90 | 36 ++-- .../vertical/MOM_bulk_mixed_layer.F90 | 41 ++-- .../vertical/MOM_diabatic_driver.F90 | 198 ++++++++---------- .../vertical/MOM_set_viscosity.F90 | 7 +- 4 files changed, 138 insertions(+), 144 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index 0f3274c2f3..ad26b10013 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -98,7 +98,6 @@ module MOM 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, calc_derived_thermo, thickness_to_dz -use MOM_interface_heights, only : convert_MLD_to_ML_thickness use MOM_interface_filter, only : interface_filter, interface_filter_init, interface_filter_end use MOM_interface_filter, only : interface_filter_CS use MOM_internal_tides, only : int_tide_CS @@ -212,8 +211,8 @@ module MOM real ALLOCABLE_, dimension(NIMEM_,NJMEM_) :: eta_av_bc !< free surface height or column mass time averaged over the last !! baroclinic dynamics time step [H ~> m or kg m-2] - real, dimension(:,:), pointer :: & - Hml => NULL() !< active mixed layer depth [Z ~> m] + real, dimension(:,:), pointer :: Hml => NULL() + !< active mixed layer depth, or 0 if there is no boundary layer scheme [Z ~> m] real :: time_in_cycle !< The running time of the current time-stepping cycle !! in calls that step the dynamics, and also the length of !! the time integral of ssh_rint [T ~> s]. @@ -1328,10 +1327,6 @@ subroutine step_MOM_dynamics(forces, p_surf_begin, p_surf_end, dt, dt_thermo, & CS%uhtr, CS%vhtr, G%HI, haloshift=0, scale=GV%H_to_MKS*US%L_to_m**2) endif call cpu_clock_begin(id_clock_ml_restrat) - if (associated(CS%visc%MLD)) then - call safe_alloc_ptr(CS%visc%h_ML, G%isd, G%ied, G%jsd, G%jed) - call convert_MLD_to_ML_thickness(CS%visc%MLD, h, CS%visc%h_ML, CS%tv, G, GV, halo=1) - endif call mixedlayer_restrat(h, CS%uhtr, CS%vhtr, CS%tv, forces, dt, CS%visc%MLD, CS%visc%h_ML, & CS%visc%sfc_buoy_flx, CS%VarMix, G, GV, US, CS%mixedlayer_restrat_CSp) call cpu_clock_end(id_clock_ml_restrat) @@ -2129,6 +2124,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & logical :: Boussinesq ! If true, this run is fully Boussinesq logical :: semi_Boussinesq ! If true, this run is partially non-Boussinesq logical :: use_KPP ! If true, diabatic is using KPP vertical mixing + logical :: MLE_use_PBL_MLD ! If true, use stored boundary layer depths for submesoscale restratification. integer :: nkml, nkbl, verbosity, write_geom integer :: dynamics_stencil ! The computational stencil for the calculations ! in the dynamic core. @@ -2733,7 +2729,7 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & if (use_frazil) allocate(CS%tv%frazil(isd:ied,jsd:jed), source=0.0) if (bound_salinity) allocate(CS%tv%salt_deficit(isd:ied,jsd:jed), source=0.0) - if (bulkmixedlayer .or. use_temperature) allocate(CS%Hml(isd:ied,jsd:jed), source=0.0) + allocate(CS%Hml(isd:ied,jsd:jed), source=0.0) if (bulkmixedlayer) then GV%nkml = nkml ; GV%nk_rho_varies = nkml + nkbl @@ -3275,11 +3271,23 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, & CS%mixedlayer_restrat_CSp, restart_CSp) if (CS%mixedlayer_restrat) then + if (GV%Boussinesq .and. associated(CS%visc%h_ML)) then + ! This is here to allow for a transition of restart files between model versions. + call get_param(param_file, "MOM", "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + if (MLE_use_PBL_MLD .and. .not.query_initialized(CS%visc%h_ML, "h_ML", restart_CSp) .and. & + associated(CS%visc%MLD)) then + do j=js,je ; do i=is,ie ; CS%visc%h_ML(i,j) = GV%Z_to_H * CS%visc%MLD(i,j) ; enddo ; enddo + endif + endif + if (.not.(bulkmixedlayer .or. CS%use_ALE_algorithm)) & call MOM_error(FATAL, "MOM: MIXEDLAYER_RESTRAT true requires a boundary layer scheme.") ! When DIABATIC_FIRST=False and using CS%visc%ML in mixedlayer_restrat we need to update after a restart if (.not. CS%diabatic_first .and. associated(CS%visc%MLD)) & call pass_var(CS%visc%MLD, G%domain, halo=1) + if (.not. CS%diabatic_first .and. associated(CS%visc%h_ML)) & + call pass_var(CS%visc%h_ML, G%domain, halo=1) endif call MOM_diagnostics_init(MOM_internal_state, CS%ADp, CS%CDp, Time, G, GV, US, & @@ -3571,7 +3579,7 @@ subroutine set_restart_fields(GV, US, param_file, CS, restart_CSp) ! hML is needed when using the ice shelf module call get_param(param_file, '', "ICE_SHELF", use_ice_shelf, default=.false., & do_not_log=.true.) - if (use_ice_shelf .and. associated(CS%Hml)) then + if (use_ice_shelf) then call register_restart_field(CS%Hml, "hML", .false., restart_CSp, & "Mixed layer thickness", "m", conversion=US%Z_to_m) endif @@ -3711,11 +3719,9 @@ subroutine extract_surface_state(CS, sfc_state_in) enddo ; enddo ; endif ! copy Hml into sfc_state, so that caps can access it - if (associated(CS%Hml)) then - do j=js,je ; do i=is,ie - sfc_state%Hml(i,j) = CS%Hml(i,j) - enddo ; enddo - endif + do j=js,je ; do i=is,ie + sfc_state%Hml(i,j) = CS%Hml(i,j) + enddo ; enddo if (CS%Hmix < 0.0) then ! A bulk mixed layer is in use, so layer 1 has the properties if (use_temperature) then ; do j=js,je ; do i=is,ie @@ -3880,7 +3886,7 @@ subroutine extract_surface_state(CS, sfc_state_in) do k=1,nz call calculate_TFreeze(CS%tv%S(is:ie,j,k), pres(is:ie), T_freeze(is:ie), CS%tv%eqn_of_state) do i=is,ie - depth_ml = min(CS%HFrz, (US%Z_to_m*GV%m_to_H)*CS%visc%MLD(i,j)) + depth_ml = min(CS%HFrz, CS%visc%h_ML(i,j)) if (depth(i) + h(i,j,k) < depth_ml) then dh = h(i,j,k) elseif (depth(i) < depth_ml) then diff --git a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 index f2b38c4a29..561ace60a7 100644 --- a/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 +++ b/src/parameterizations/vertical/MOM_bulk_mixed_layer.F90 @@ -164,7 +164,7 @@ module MOM_bulk_mixed_layer !> This subroutine partially steps the bulk mixed layer model. !! See \ref BML for more details. subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, CS, & - optics, Hml, aggregate_FW_forcing, dt_diag, last_call) + optics, BLD, H_ml, aggregate_FW_forcing, dt_diag, last_call) type(ocean_grid_type), intent(inout) :: G !< The ocean's grid structure. type(verticalGrid_type), intent(in) :: GV !< The ocean's vertical grid structure. type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type @@ -195,7 +195,10 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C type(optics_type), pointer :: optics !< The structure that can be queried for the !! inverse of the vertical absorption decay !! scale for penetrating shortwave radiation. - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), & + intent(inout) :: H_ml !< Active mixed layer thickness [H ~> m or kg m-2]. logical, intent(in) :: aggregate_FW_forcing !< If true, the net incoming and !! outgoing surface freshwater fluxes are !! combined before being applied, instead of @@ -605,25 +608,27 @@ subroutine bulkmixedlayer(h_3d, u_3d, v_3d, tv, fluxes, dt, ea, eb, G, GV, US, C CS%ML_depth(i,j) = h(i,0) ! Store the diagnostic. enddo ; endif - if (associated(Hml)) then - ! Return the mixed layerd depth in [Z ~> m]. - if (GV%Boussinesq .or. GV%semi_Boussinesq) then - do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * GV%H_to_Z*h(i,0) - enddo + ! Return the mixed layer depth in [Z ~> m]. + if (GV%Boussinesq .or. GV%semi_Boussinesq) then + do i=is,ie + BLD(i,j) = G%mask2dT(i,j) * GV%H_to_Z*h(i,0) + enddo + else + do i=is,ie ; dp_ml(i) = GV%g_Earth * GV%H_to_RZ * h(i,0) ; enddo + if (associated(tv%p_surf)) then + do i=is,ie ; p_sfc(i) = tv%p_surf(i,j) ; enddo else - do i=is,ie ; dp_ml(i) = GV%g_Earth * GV%H_to_RZ * h(i,0) ; enddo - if (associated(tv%p_surf)) then - do i=is,ie ; p_sfc(i) = tv%p_surf(i,j) ; enddo - else - do i=is,ie ; p_sfc(i) = 0.0 ; enddo - endif - call average_specific_vol(T(:,0), S(:,0), p_sfc, dp_ml, SpV_ml, tv%eqn_of_state) - do i=is,ie - Hml(i,j) = G%mask2dT(i,j) * GV%H_to_RZ * SpV_ml(i) * h(i,0) - enddo + do i=is,ie ; p_sfc(i) = 0.0 ; enddo endif + call average_specific_vol(T(:,0), S(:,0), p_sfc, dp_ml, SpV_ml, tv%eqn_of_state) + do i=is,ie + BLD(i,j) = G%mask2dT(i,j) * GV%H_to_RZ * SpV_ml(i) * h(i,0) + enddo endif + ! Return the mixed layer thickness in [H ~> m or kg m-2]. + do i=is,ie + H_ml(i,j) = G%mask2dT(i,j) * h(i,0) + enddo ! At this point, return water to the original layers, but constrained to ! still be sorted. After this point, all the water that is in massive diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 010f17b978..4f4c605a11 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -45,6 +45,7 @@ module MOM_diabatic_driver 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, calc_derived_thermo, thickness_to_dz +use MOM_interface_heights, only : convert_MLD_to_ML_thickness use MOM_internal_tides, only : propagate_int_tide, register_int_tide_restarts use MOM_internal_tides, only : internal_tides_init, internal_tides_end, int_tide_CS use MOM_kappa_shear, only : kappa_shear_is_used @@ -242,8 +243,7 @@ module MOM_diabatic_driver type(regularize_layers_CS) :: regularize_layers !< Regularize layer control structure type(group_pass_type) :: pass_hold_eb_ea !< For group halo pass - type(group_pass_type) :: pass_Kv !< For group halo pass - type(diag_grid_storage) :: diag_grids_prev!< Stores diagnostic grids at some previous point in the algorithm + type(diag_grid_storage) :: diag_grids_prev !< Stores diagnostic grids at some previous point in the algorithm type(time_type), pointer :: Time !< Pointer to model time (needed for sponges) end type diabatic_CS @@ -259,7 +259,7 @@ module MOM_diabatic_driver !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, OBC, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -268,7 +268,7 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -389,18 +389,23 @@ subroutine diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & endif ! end CS%use_int_tides if (CS%useALEalgorithm .and. CS%use_legacy_diabatic) then - call diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) elseif (CS%useALEalgorithm) then - call diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + call diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) else - call layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & + call layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) endif - call cpu_clock_begin(id_clock_pass) + if (associated(visc%sfc_buoy_flx)) & + call pass_var(visc%sfc_buoy_flx, G%domain, halo=1, complete=.not.associated(visc%MLD)) + if (associated(visc%h_ML)) & + call pass_var(visc%h_ML, G%Domain, halo=1, complete=.not.associated(visc%MLD)) + if (associated(visc%MLD)) & + call pass_var(visc%MLD, G%Domain, halo=1, complete=.true.) if (associated(visc%Kv_shear)) & call pass_var(visc%Kv_shear, G%Domain, To_All+Omit_Corners, halo=1) call cpu_clock_end(id_clock_pass) @@ -499,7 +504,7 @@ end subroutine diabatic !> Applies diabatic forcing and diapycnal mixing of temperature, salinity and other tracers for use !! with an ALE algorithm. This version uses an older set of algorithms compared with diabatic_ALE. -subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -509,7 +514,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -697,16 +702,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! 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(:,:) = KPP_buoy_flux(:,:,1) - call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) - endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) if (.not.CS%KPPisPassive) then !$OMP parallel do default(shared) @@ -779,7 +779,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim ! Calculate vertical mixing due to convection (computed via CVMix) if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_shear) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, BLD, Kd_int, visc%Kv_shear) endif ! Find the vertical distances across layers. @@ -802,7 +802,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_s, "after calc_entrain ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -847,19 +847,11 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) - if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy ePBL's MLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - elseif (associated(visc%MLD)) then - 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 + call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) ! Find the vertical distances across layers, which may have been modified by the net surface flux call thickness_to_dz(h, tv, dz, G, GV, US) @@ -885,8 +877,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif @@ -930,8 +922,8 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1076,7 +1068,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Tim endif ! (CS%mix_boundary_tracers) ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & + call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, BLD, dt, & G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar, & @@ -1119,7 +1111,7 @@ end subroutine diabatic_ALE_legacy !> This subroutine imposes the diapycnal mass fluxes and the !! accompanying diapycnal advection of momentum and tracers. -subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, stoch_CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1129,7 +1121,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -1322,16 +1314,11 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! 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(:,:) = KPP_buoy_flux(:,:,1) - call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) - endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) if (showCallTree) call callTree_waypoint("done with KPP_calculate (diabatic)") if (CS%debug) then @@ -1367,7 +1354,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, ! Calculate vertical mixing due to convection (computed via CVMix) if (CS%use_CVMix_conv) then ! Increment vertical diffusion and viscosity due to convection - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_heat, visc%Kv_shear, Kd_aux=Kd_salt) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, BLD, Kd_heat, visc%Kv_shear, Kd_aux=Kd_salt) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -1393,8 +1380,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) if (CS%debug) then - call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "after applyBoundaryFluxes ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) call hchksum(cTKE, "after applyBoundaryFluxes cTKE", G%HI, haloshift=0, & scale=US%RZ3_T3_to_W_m2*US%T_to_s) call hchksum(dSV_dT, "after applyBoundaryFluxes dSV_dT", G%HI, haloshift=0, & @@ -1407,19 +1394,11 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, call energetic_PBL(h, u_h, v_h, tv, fluxes, dt, Kd_ePBL, G, GV, US, & CS%ePBL, stoch_CS, dSV_dT, dSV_dS, cTKE, SkinBuoyFlux, waves=waves) - if (associated(Hml)) then - call energetic_PBL_get_MLD(CS%ePBL, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! If visc%MLD exists, copy ePBL's MLD into it - if (associated(visc%MLD)) visc%MLD(:,:) = Hml(:,:) - elseif (associated(visc%MLD)) then - 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 + call energetic_PBL_get_MLD(CS%ePBL, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy ePBL's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = SkinBuoyFlux(:,:) ! Augment the diffusivities and viscosity due to those diagnosed in energetic_PBL. do K=2,nz ; do j=js,je ; do i=is,ie @@ -1436,8 +1415,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "after ePBL ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "after ePBL ent_s", G%HI, haloshift=0, scale=GV%H_to_MKS) call hchksum(Kd_ePBL, "after ePBL Kd_ePBL", G%HI, haloshift=0, scale=GV%HZ_T_to_m2_s) endif @@ -1473,8 +1452,8 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, if (associated(tv%T)) then if (CS%debug) then - call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ent_t, "before triDiagTS ent_t ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(ent_s, "before triDiagTS ent_s ", G%HI, haloshift=0, scale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -1603,7 +1582,7 @@ subroutine diabatic_ALE(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, endif ! (CS%mix_boundary_tracer_ALE) ! For passive tracers, the changes in thickness due to boundary fluxes has yet to be applied - call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, Hml, dt, & + call call_tracer_column_fns(h_orig, h, ent_s(:,:,1:nz), ent_s(:,:,2:nz+1), fluxes, BLD, dt, & G, GV, US, tv, CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar, & @@ -1650,7 +1629,7 @@ end subroutine diabatic_ALE !> Imposes the diapycnal mass fluxes and the accompanying diapycnal advection of momentum and tracers !! using the original MOM6 algorithms. -subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_end, & +subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, & G, GV, US, CS, Waves) type(ocean_grid_type), intent(inout) :: G !< ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1660,7 +1639,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(inout) :: h !< thickness [H ~> m or kg m-2] type(thermo_var_ptrs), intent(inout) :: tv !< points to thermodynamic fields !! unused have NULL ptrs - real, dimension(:,:), pointer :: Hml !< Active mixed layer depth [Z ~> m] + real, dimension(SZI_(G),SZJ_(G)), intent(inout) :: BLD !< Active mixed layer depth [Z ~> m] type(forcing), intent(inout) :: fluxes !< points to forcing fields !! unused fields have NULL ptrs type(vertvisc_type), intent(inout) :: visc !< Structure with vertical viscosities, @@ -1691,6 +1670,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e temp_diag, & ! Diagnostic array of previous temperatures [C ~> degC] saln_diag ! Diagnostic array of previous salinity [S ~> ppt] real, dimension(SZI_(G),SZJ_(G)) :: & + h_MLD, & ! Active mixed layer thickness [H ~> m or kg m-2]. U_star, & ! The friction velocity [Z T-1 ~> m s-1]. KPP_temp_flux, & ! KPP effective temperature flux [C H T-1 ~> degC m s-1 or degC kg m-2 s-1] KPP_salt_flux, & ! KPP effective salt flux [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] @@ -1772,7 +1752,6 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e dz_neglect = GV%dZ_subroundoff ; dz_neglect2 = dz_neglect*dz_neglect Kd_heat(:,:,:) = 0.0 ; Kd_salt(:,:,:) = 0.0 - showCallTree = callTree_showQuery() if (showCallTree) call callTree_enter("layered_diabatic(), MOM_diabatic_driver.F90") @@ -1826,12 +1805,14 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt*CS%ML_mix_first, & eaml, ebml, G, GV, US, CS%bulkmixedlayer, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.false.) + BLD, h_MLD, CS%aggregate_FW_forcing, dt, last_call=.false.) else ! Changes: h, tv%T, tv%S, eaml and ebml (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt, eaml, ebml, & G, GV, US, CS%bulkmixedlayer, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + BLD, h_MLD, CS%aggregate_FW_forcing, dt, last_call=.true.) + if (associated(visc%h_ML)) visc%h_ML(:,:) = h_MLD(:,:) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) endif ! Keep salinity from falling below a small but positive threshold. @@ -1858,8 +1839,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if ((CS%ML_mix_first > 0.0) .or. CS%use_geothermal) then call find_uv_at_h(u, v, h_orig, u_h, v_h, G, GV, US, eaml, ebml) if (CS%debug) then - call hchksum(eaml, "after find_uv_at_h eaml", G%HI, scale=GV%H_to_m) - call hchksum(ebml, "after find_uv_at_h ebml", G%HI, scale=GV%H_to_m) + call hchksum(eaml, "after find_uv_at_h eaml", G%HI, scale=GV%H_to_MKS) + call hchksum(ebml, "after find_uv_at_h ebml", G%HI, scale=GV%H_to_MKS) endif else call find_uv_at_h(u, v, h, u_h, v_h, G, GV, US) @@ -1947,16 +1928,11 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e Kd_salt, visc%Kv_shear, KPP_NLTheat, KPP_NLTscalar, Waves=Waves) endif - if (associated(Hml)) then - call KPP_get_BLD(CS%KPP_CSp, Hml(:,:), G, US) - call pass_var(Hml, G%domain, halo=1) - ! 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(:,:) = KPP_buoy_flux(:,:,1) - call pass_var(visc%sfc_buoy_flx, G%domain, halo=1) - endif + call KPP_get_BLD(CS%KPP_CSp, BLD(:,:), G, US) + ! If visc%MLD or visc%h_ML exist, copy KPP's BLD into them with appropriate conversions. + if (associated(visc%h_ML)) call convert_MLD_to_ML_thickness(BLD, h, visc%h_ML, tv, G, GV) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) + if (associated(visc%sfc_buoy_flx)) visc%sfc_buoy_flx(:,:) = KPP_buoy_flux(:,:,1) if (.not. CS%KPPisPassive) then !$OMP parallel do default(shared) @@ -1985,7 +1961,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Add vertical diff./visc. due to convection (computed via CVMix) if (CS%use_CVMix_conv) then - call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, Hml, Kd_int, visc%Kv_shear) + call calculate_CVMix_conv(h, tv, G, GV, US, CS%CVMix_conv, BLD, Kd_int, visc%Kv_shear) endif if (CS%useKPP) then @@ -2051,8 +2027,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e call MOM_forcing_chksum("after calc_entrain ", fluxes, G, US, haloshift=0) call MOM_thermovar_chksum("after calc_entrain ", tv, G, US) call MOM_state_chksum("after calc_entrain ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ea, "after calc_entrain ea", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(eb, "after calc_entrain eb", G%HI, haloshift=0, scale=GV%H_to_MKS) endif ! Save fields before boundary forcing is applied for tendency diagnostics @@ -2207,8 +2183,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eb(i,j,k) = eb(i,j,k) + ebml(i,j,k) enddo ; enddo ; enddo if (CS%debug) then - call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ea, "after ea = ea + eaml", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(eb, "after eb = eb + ebml", G%HI, haloshift=0, scale=GV%H_to_MKS) endif endif @@ -2229,7 +2205,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! Changes: h, tv%T, tv%S, ea and eb (G is also inout???) call bulkmixedlayer(h, u_h, v_h, tv, fluxes, dt_mix, ea, eb, & G, GV, US, CS%bulkmixedlayer, CS%optics, & - Hml, CS%aggregate_FW_forcing, dt, last_call=.true.) + BLD, h_MLD, CS%aggregate_FW_forcing, dt, last_call=.true.) + if (associated(visc%h_ML)) visc%h_ML(:,:) = h_MLD(:,:) + if (associated(visc%MLD)) visc%MLD(:,:) = BLD(:,:) ! Keep salinity from falling below a small but positive threshold. ! This constraint is needed for SIS1 ice model, which can extract @@ -2251,8 +2229,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (associated(tv%T)) then if (CS%debug) then - call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, scale=GV%H_to_m) - call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, scale=GV%H_to_m) + call hchksum(ea, "before triDiagTS ea ", G%HI, haloshift=0, scale=GV%H_to_MKS) + call hchksum(eb, "before triDiagTS eb ", G%HI, haloshift=0, scale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) @@ -2299,8 +2277,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e if (CS%debug) then call MOM_state_chksum("after mixed layer ", u, v, h, G, GV, US, haloshift=0) call MOM_thermovar_chksum("after mixed layer ", tv, G, US) - call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_m) + call hchksum(ea, "after mixed layer ea", G%HI, scale=GV%H_to_MKS) + call hchksum(eb, "after mixed layer eb", G%HI, scale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_remap) @@ -2401,7 +2379,7 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, BLD, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar) @@ -2423,13 +2401,13 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e eatr(i,j,k) = ea(i,j,k) + add_ent enddo ; enddo ; enddo - call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, Hml, dt, G, GV, US, tv, & + call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, BLD, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar) else - call call_tracer_column_fns(hold, h, ea, eb, fluxes, Hml, dt, G, GV, US, tv, & + call call_tracer_column_fns(hold, h, ea, eb, fluxes, BLD, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar) @@ -2493,8 +2471,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! mixed layer turbulence is applied elsewhere. if (CS%use_bulkmixedlayer) then if (CS%debug) then - call hchksum(ea, "before net flux rearrangement ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "before net flux rearrangement eb", G%HI, scale=GV%H_to_m) + call hchksum(ea, "before net flux rearrangement ea", G%HI, scale=GV%H_to_MKS) + call hchksum(eb, "before net flux rearrangement eb", G%HI, scale=GV%H_to_MKS) endif !$OMP parallel do default(shared) private(net_ent) do j=js,je @@ -2505,8 +2483,8 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e enddo ; enddo enddo if (CS%debug) then - call hchksum(ea, "after net flux rearrangement ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "after net flux rearrangement eb", G%HI, scale=GV%H_to_m) + call hchksum(ea, "after net flux rearrangement ea", G%HI, scale=GV%H_to_MKS) + call hchksum(eb, "after net flux rearrangement eb", G%HI, scale=GV%H_to_MKS) endif endif @@ -2537,9 +2515,9 @@ subroutine layered_diabatic(u, v, h, tv, Hml, fluxes, visc, ADp, CDp, dt, Time_e ! or enters the ocean with the surface velocity. if (CS%debug) then call MOM_state_chksum("before u/v tridiag ", u, v, h, G, GV, US, haloshift=0) - call hchksum(ea, "before u/v tridiag ea", G%HI, scale=GV%H_to_m) - call hchksum(eb, "before u/v tridiag eb", G%HI, scale=GV%H_to_m) - call hchksum(hold, "before u/v tridiag hold", G%HI, scale=GV%H_to_m) + call hchksum(ea, "before u/v tridiag ea", G%HI, scale=GV%H_to_MKS) + call hchksum(eb, "before u/v tridiag eb", G%HI, scale=GV%H_to_MKS) + call hchksum(hold, "before u/v tridiag hold", G%HI, scale=GV%H_to_MKS) endif call cpu_clock_begin(id_clock_tridiag) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index c103cbc71b..e10e1d5340 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -30,7 +30,7 @@ module MOM_set_visc use MOM_safe_alloc, only : safe_alloc_ptr, safe_alloc_alloc use MOM_unit_scaling, only : unit_scale_type use MOM_variables, only : thermo_var_ptrs, vertvisc_type, porous_barrier_type -use MOM_verticalGrid, only : verticalGrid_type +use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units implicit none ; private @@ -2767,10 +2767,15 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) endif + if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then + call safe_alloc_ptr(visc%h_ML, isd, ied, jsd, jed) + endif if (MLE_use_PBL_MLD) then call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) + call register_restart_field(visc%h_ML, "h_ML", .false., restart_CS, & + "Instantaneous active mixing layer thickness", units=get_thickness_units(GV), conversion=GV%H_to_mks) endif ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model From d3cb7eea01042abe0fbcc60910c0cd8dbc50a269 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Wed, 24 Apr 2024 09:35:43 -0400 Subject: [PATCH 621/629] +*Use visc%h_ML in tracer diffusion routines Pass visc%h_ML to applyBoundaryFluxesInOut, which avoids the need for the thickness conversions inside of that routine. Answers are bitwise identical for Boussinesq cases, but they will change in non-Boussinesq cases because the layer specific volumes have changed between the time the boundary layer thicknesses have been calculated and when they are being used in the brine plume parameterization. Also use visc%h_ML in place of calls to KPP_get_BLD or energetic_PBL_get_MLD in step_MOM_dyn_split_RK2, hor_bnd_diffusion and neutral_diffusion_calc_coeffs. This change requires a new vertvisc_type argument to tracer_hordiff, hor_bnd_diffusion and neutral_diffusion_calc_coeffs. Boussinesq answers are bitwise identical, but non-Boussinesq answers change because they now use the actual model specific volumes rather than some prescribed constant value to to the relevant unit conversions. The logic in set_visc_register_restarts was also updated so that visc%MLD and visc%h_ML are allocated and registered for restarts in the cases where they will be used. All answers are bitwise identical in Boussinesq mode, but in non-Boussinesq mode there are changes in answers in cases that use neutral tracer diffusion that excludes the boundary layer, horizontal tracer diffusion in the boundary layer or FPMIX. There are also changes to the arguments of several publicly visible routines. --- src/core/MOM.F90 | 8 ++-- src/core/MOM_dynamics_split_RK2.F90 | 9 +---- src/core/MOM_dynamics_split_RK2b.F90 | 9 +---- .../vertical/MOM_CVMix_ddiff.F90 | 4 +- .../vertical/MOM_diabatic_aux.F90 | 39 +++++++------------ .../vertical/MOM_diabatic_driver.F90 | 8 ++-- .../vertical/MOM_set_viscosity.F90 | 29 +++++++++++--- src/tracer/MOM_hor_bnd_diffusion.F90 | 24 ++++++++---- src/tracer/MOM_neutral_diffusion.F90 | 18 ++++++--- src/tracer/MOM_tracer_hor_diff.F90 | 17 ++++---- 10 files changed, 88 insertions(+), 77 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index ad26b10013..e6a42ef7a7 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -1433,7 +1433,7 @@ subroutine step_MOM_tracer_dyn(CS, G, GV, US, h, Time_local) call advect_tracer(h, CS%uhtr, CS%vhtr, CS%OBC, CS%t_dyn_rel_adv, G, GV, US, & CS%tracer_adv_CSp, CS%tracer_Reg, x_first_in=x_first) if (CS%debug) call MOM_tracer_chksum("Post-advect ", CS%tracer_Reg, G) - call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h, CS%t_dyn_rel_adv, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) if (CS%debug) call MOM_tracer_chksum("Post-diffuse ", CS%tracer_Reg, G) if (showCallTree) call callTree_waypoint("finished tracer advection/diffusion (step_MOM)") @@ -1882,7 +1882,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif - call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1909,7 +1909,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS call calc_depth_function(G, CS%VarMix) call calc_slope_functions(CS%h, CS%tv, dt_offline, G, GV, US, CS%VarMix, OBC=CS%OBC) endif - call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(CS%h, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif endif @@ -1966,7 +1966,7 @@ subroutine step_offline(forces, fluxes, sfc_state, Time_start, time_interval, CS CS%h, eatr, ebtr, uhtr, vhtr) ! Perform offline diffusion if requested if (.not. skip_diffusion) then - call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, G, GV, US, & + call tracer_hordiff(h_end, dt_offline, CS%MEKE, CS%VarMix, CS%visc, G, GV, US, & CS%tracer_diff_CSp, CS%tracer_Reg, CS%tv) endif diff --git a/src/core/MOM_dynamics_split_RK2.F90 b/src/core/MOM_dynamics_split_RK2.F90 index a184cf473f..b315916ec5 100644 --- a/src/core/MOM_dynamics_split_RK2.F90 +++ b/src/core/MOM_dynamics_split_RK2.F90 @@ -71,9 +71,6 @@ module MOM_dynamics_split_RK2 use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units use MOM_wave_interface, only : wave_parameters_CS, Stokes_PGF -use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS -use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS -use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member implicit none ; private @@ -139,8 +136,6 @@ module MOM_dynamics_split_RK2 real ALLOCABLE_, dimension(NIMEM_,NJMEM_,NKMEM_) :: pbce !< pbce times eta gives the baroclinic pressure !! anomaly in each layer due to free surface height !! anomalies [L2 H-1 T-2 ~> m s-2 or m4 kg-1 s-2]. - type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge - type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] @@ -717,9 +712,7 @@ subroutine step_MOM_dyn_split_RK2(u_inst, v_inst, h, tv, visc, Time_local, dt, f if (CS%fpmix) then hbl(:,:) = 0.0 - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) & - call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + if (associated(visc%h_ML)) hbl(:,:) = visc%h_ML(:,:) call vertFPmix(up, vp, uold, vold, hbl, h, forces, & dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & diff --git a/src/core/MOM_dynamics_split_RK2b.F90 b/src/core/MOM_dynamics_split_RK2b.F90 index fa78938477..e55e2e3f96 100644 --- a/src/core/MOM_dynamics_split_RK2b.F90 +++ b/src/core/MOM_dynamics_split_RK2b.F90 @@ -73,9 +73,6 @@ module MOM_dynamics_split_RK2b use MOM_verticalGrid, only : verticalGrid_type, get_thickness_units use MOM_verticalGrid, only : get_flux_units, get_tr_flux_units use MOM_wave_interface, only: wave_parameters_CS, Stokes_PGF -use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS -use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS -use MOM_diabatic_driver, only : diabatic_CS, extract_diabatic_member implicit none ; private @@ -147,8 +144,6 @@ module MOM_dynamics_split_RK2b real ALLOCABLE_, dimension(NIMEM_,NJMEMB_PTR_) :: dv_av_inst !< The barotropic meridional velocity increment !! between filtered and instantaneous velocities !! [L T-1 ~> m s-1] - type(KPP_CS), pointer :: KPP_CSp => NULL() !< KPP control structure needed to ge - type(energetic_PBL_CS), pointer :: energetic_PBL_CSp => NULL() !< ePBL control structure real, pointer, dimension(:,:) :: taux_bot => NULL() !< frictional x-bottom stress from the ocean !! to the seafloor [R L Z T-2 ~> Pa] @@ -734,9 +729,7 @@ subroutine step_MOM_dyn_split_RK2b(u_av, v_av, h, tv, visc, Time_local, dt, forc ! if (CS%fpmix) then ! hbl(:,:) = 0.0 - ! if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - ! if (ASSOCIATED(CS%energetic_PBL_CSp)) & - ! call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, m_to_MLD_units=GV%m_to_H) + ! if (associated(visc%h_ML)) hbl(:,:) = visc%h_ML(:,:) ! call vertFPmix(up, vp, uold, vold, hbl, h, forces, & ! dt_pred, G, GV, US, CS%vertvisc_CSp, CS%OBC) ! call vertvisc(up, vp, h, forces, visc, dt_pred, CS%OBC, CS%ADp, CS%CDp, G, & diff --git a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 index af17e0287f..958b2478f3 100644 --- a/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 +++ b/src/parameterizations/vertical/MOM_CVMix_ddiff.F90 @@ -245,8 +245,8 @@ subroutine compute_ddiff_coeffs(h, tv, G, GV, US, j, Kd_T, Kd_S, CS, R_rho) iFaceHeight(k+1) = iFaceHeight(k) - dh enddo - ! gets index of the level and interface above hbl - !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, GV%Z_to_H*hbl(i,j)) + ! gets index of the level and interface above hbl in [H ~> m or kg m-2] + !kOBL = CVmix_kpp_compute_kOBL_depth(iFaceHeight, cellHeight, hbl(i,j)) Kd1_T(:) = 0.0 ; Kd1_S(:) = 0.0 call CVMix_coeffs_ddiff(Tdiff_out=Kd1_T(:), & diff --git a/src/parameterizations/vertical/MOM_diabatic_aux.F90 b/src/parameterizations/vertical/MOM_diabatic_aux.F90 index 1ba5aef392..aa31024b24 100644 --- a/src/parameterizations/vertical/MOM_diabatic_aux.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_aux.F90 @@ -1064,7 +1064,7 @@ end subroutine diagnoseMLDbyEnergy subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, tv, & aggregate_FW_forcing, evap_CFL_limit, & minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, & - SkinBuoyFlux, MLD) + SkinBuoyFlux, MLD_h) type(diabatic_aux_CS), pointer :: CS !< Control structure for diabatic_aux type(ocean_grid_type), intent(in) :: G !< Grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure @@ -1094,7 +1094,8 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !! salinity [R-1 S-1 ~> m3 kg-1 ppt-1]. real, dimension(SZI_(G),SZJ_(G)), & optional, intent(out) :: SkinBuoyFlux !< Buoyancy flux at surface [Z2 T-3 ~> m2 s-3]. - real, pointer, dimension(:,:), optional :: MLD !< Mixed layer depth for brine plumes [Z ~> m] + real, dimension(:,:), & + optional, pointer :: MLD_h !< Mixed layer thickness for brine plumes [H ~> m or kg m-2] ! Local variables integer, parameter :: maxGroundings = 5 @@ -1137,8 +1138,6 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! [S H T-1 ~> ppt m s-1 or ppt kg m-2 s-1] netMassInOut_rate, & ! netmassinout but for dt=1 [H T-1 ~> m s-1 or kg m-2 s-1] mixing_depth, & ! The mixing depth for brine plumes [H ~> m or kg m-2] - MLD_H, & ! The mixed layer depth for brine plumes in thickness units [H ~> m or kg m-2] - MLD_Z, & ! Running sum of distance from the surface for finding MLD_H [Z ~> m] total_h ! Total thickness of the water column [H ~> m or kg m-2] real, dimension(SZI_(G), SZK_(GV)) :: & h2d, & ! A 2-d copy of the thicknesses [H ~> m or kg m-2] @@ -1204,11 +1203,15 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t GoRho = US%L_to_Z**2*GV%g_Earth / GV%Rho0 endif - if (CS%do_brine_plume .and. .not. associated(MLD)) then + if (CS%do_brine_plume .and. .not.present(MLD_h)) then call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& - "Brine plume parameterization requires a mixed-layer depth,\n"//& + "Brine plume parameterization requires a mixed-layer depth argument,\n"//& "currently coming from the energetic PBL scheme.") endif + if (CS%do_brine_plume .and. .not.associated(MLD_h)) then + call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& + "Brine plume parameterization requires an associated mixed-layer depth.") + endif if (CS%do_brine_plume .and. .not. associated(fluxes%salt_left_behind)) then call MOM_error(FATAL, "MOM_diabatic_aux.F90, applyBoundaryFluxesInOut(): "//& "Brine plume parameterization requires DO_BRINE_PLUME\n"//& @@ -1232,7 +1235,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP minimum_forcing_depth,evap_CFL_limit,dt,EOSdom, & !$OMP calculate_buoyancy,netPen_rate,SkinBuoyFlux,GoRho,& !$OMP calculate_energetics,dSV_dT,dSV_dS,cTKE,g_Hconv2, & - !$OMP EnthalpyConst,MLD) & + !$OMP EnthalpyConst,MLD_h) & !$OMP private(opacityBand,h2d,T2d,netMassInOut,netMassOut, & !$OMP netHeat,netSalt,Pen_SW_bnd,fractionOfForcing, & !$OMP IforcingDepthScale,g_conv,dSpV_dT,dSpV_dS, & @@ -1242,7 +1245,7 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t !$OMP drhodt,drhods,pen_sw_bnd_rate, & !$OMP pen_TKE_2d,Temp_in,Salin_in,RivermixConst, & !$OMP mixing_depth,A_brine,fraction_left_brine, & - !$OMP plume_fraction,dK,MLD_H,MLD_Z,total_h) & + !$OMP plume_fraction,dK,total_h) & !$OMP firstprivate(SurfPressure,plume_flux) do j=js,je ! Work in vertical slices for efficiency @@ -1368,24 +1371,10 @@ subroutine applyBoundaryFluxesInOut(CS, G, GV, US, dt, fluxes, optics, nsw, h, t ! C/ update temp due to penetrative SW if (CS%do_brine_plume) then ! Find the plume mixing depth. - if (GV%Boussinesq .or. .not.allocated(tv%SpV_avg)) then - do i=is,ie ; MLD_H(i) = GV%Z_to_H * MLD(i,j) ; total_h(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo - else - do i=is,ie ; MLD_H(i) = 0.0 ; MLD_Z(i) = 0.0 ; total_h(i) = 0.0 ; enddo - do k=1,nz ; do i=is,ie - total_h(i) = total_h(i) + h(i,j,k) - if (MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) < MLD(i,j)) then - MLD_H(i) = MLD_H(i) + h(i,j,k) - MLD_Z(i) = MLD_Z(i) + GV%H_to_RZ * h(i,j,k) * tv%SpV_avg(i,j,k) - elseif (MLD_Z(i) < MLD(i,j)) then ! This is the last layer in the mixed layer - MLD_H(i) = MLD_H(i) + GV%RZ_to_H * (MLD(i,j) - MLD_Z(i)) / tv%SpV_avg(i,j,k) - MLD_Z(i) = MLD(i,j) - endif - enddo ; enddo - endif + do i=is,ie ; total_h(i) = 0.0 ; enddo + do k=1,nz ; do i=is,ie ; total_h(i) = total_h(i) + h(i,j,k) ; enddo ; enddo do i=is,ie - mixing_depth(i) = min( max(MLD_H(i) - minimum_forcing_depth, minimum_forcing_depth), & + mixing_depth(i) = min( max(MLD_h(i,j) - minimum_forcing_depth, minimum_forcing_depth), & max(total_h(i), GV%angstrom_h) ) + GV%H_subroundoff A_brine(i) = (CS%brine_plume_n + 1) / (mixing_depth(i) ** (CS%brine_plume_n + 1)) enddo diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index 4f4c605a11..f2446e0332 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -825,7 +825,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_mks) @@ -885,7 +885,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML) ! Find the vertical distances across layers, which may have been modified by the net surface flux call thickness_to_dz(h, tv, dz, G, GV, US) @@ -1377,7 +1377,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, skinbuoyflux(:,:) = 0.0 call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, CS%evap_CFL_limit, & - CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD=visc%MLD) + CS%minimum_forcing_depth, cTKE, dSV_dT, dSV_dS, SkinBuoyFlux=SkinBuoyFlux, MLD_h=visc%h_ML) if (CS%debug) then call hchksum(ent_t, "after applyBoundaryFluxes ent_t", G%HI, haloshift=0, scale=GV%H_to_MKS) @@ -1423,7 +1423,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, else call applyBoundaryFluxesInOut(CS%diabatic_aux_CSp, G, GV, US, dt, fluxes, CS%optics, & optics_nbands(CS%optics), h, tv, CS%aggregate_FW_forcing, & - CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD=visc%MLD) + CS%evap_CFL_limit, CS%minimum_forcing_depth, MLD_h=visc%h_ML) endif ! endif for CS%use_energetic_PBL diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e10e1d5340..ab92a60950 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2694,6 +2694,7 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C ! Local variables logical :: use_kappa_shear, KS_at_vertex logical :: adiabatic, useKPP, useEPBL + logical :: do_brine_plume, use_hor_bnd_diff, use_neutral_diffusion, use_fpmix 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. @@ -2757,25 +2758,43 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C call safe_alloc_ptr(visc%Kv_slow, isd, ied, jsd, jed, nz+1) endif - ! visc%MLD is used to communicate the state of the (e)PBL or KPP to the rest of the model + ! visc%MLD and visc%h_ML are 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_PBL_MLD", MLE_use_PBL_MLD, & default=.false., do_not_log=.true.) - ! visc%MLD needs to be allocated when melt potential is computed (HFREEZE>0) + ! visc%h_ML needs to be allocated when melt potential is computed (HFREEZE>0) or one of + ! several other parameterizations are in use. call get_param(param_file, mdl, "HFREEZE", hfreeze, & units="m", default=-1.0, scale=US%m_to_Z, do_not_log=.true.) + call get_param(param_file, mdl, "DO_BRINE_PLUME", do_brine_plume, & + "If true, use a brine plume parameterization from Nguyen et al., 2009.", & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_HORIZONTAL_BOUNDARY_DIFFUSION", use_hor_bnd_diff, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_NEUTRAL_DIFFUSION", use_neutral_diffusion, & + default=.false., do_not_log=.true.) + if (use_neutral_diffusion) & + call get_param(param_file, mdl, "NDIFF_INTERIOR_ONLY", use_neutral_diffusion, & + default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "FPMIX", use_fpmix, & + default=.false., do_not_log=.true.) - if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then + if (MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) endif - if (hfreeze >= 0.0 .or. MLE_use_PBL_MLD) then + if ((hfreeze >= 0.0) .or. MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & + use_neutral_diffusion .or. use_hor_bnd_diff) then call safe_alloc_ptr(visc%h_ML, isd, ied, jsd, jed) endif if (MLE_use_PBL_MLD) then call register_restart_field(visc%MLD, "MLD", .false., restart_CS, & "Instantaneous active mixing layer depth", units="m", conversion=US%Z_to_m) + endif + if (MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & + use_neutral_diffusion .or. use_hor_bnd_diff) then call register_restart_field(visc%h_ML, "h_ML", .false., restart_CS, & - "Instantaneous active mixing layer thickness", units=get_thickness_units(GV), conversion=GV%H_to_mks) + "Instantaneous active mixing layer thickness", & + units=get_thickness_units(GV), conversion=GV%H_to_mks) endif ! visc%sfc_buoy_flx is used to communicate the state of the (e)PBL or KPP to the rest of the model diff --git a/src/tracer/MOM_hor_bnd_diffusion.F90 b/src/tracer/MOM_hor_bnd_diffusion.F90 index 163d8a480f..13e91e8973 100644 --- a/src/tracer/MOM_hor_bnd_diffusion.F90 +++ b/src/tracer/MOM_hor_bnd_diffusion.F90 @@ -20,6 +20,7 @@ module MOM_hor_bnd_diffusion use MOM_spatial_means, only : global_mass_integral use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use MOM_CVMix_KPP, only : KPP_get_BLD, KPP_CS use MOM_energetic_PBL, only : energetic_PBL_get_MLD, energetic_PBL_CS @@ -161,7 +162,7 @@ end function hor_bnd_diffusion_init !! 2) calculate diffusive tracer fluxes (F) in the HBD grid using a layer by layer approach !! 3) remap fluxes to the native grid !! 4) update tracer by adding the divergence of F -subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) +subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, visc, CS) type(ocean_grid_type), intent(inout) :: 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 @@ -171,6 +172,8 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) real, intent(in) :: dt !< Tracer time step * I_numitts !! (I_numitts in tracer_hordiff) [T ~> s] type(tracer_registry_type), pointer :: Reg !< Tracer registry + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! boundary layer properties and related fields type(hbd_CS), pointer :: CS !< Control structure for this module ! Local variables @@ -203,10 +206,14 @@ subroutine hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, dt, Reg, CS) call cpu_clock_begin(id_clock_hbd) Idt = 1./dt - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, hbl, G, US, & - m_to_MLD_units=GV%m_to_H) - call pass_var(hbl,G%Domain) + + if (associated(visc%h_ML)) then + hbl(:,:) = visc%h_ML(:,:) + else + call MOM_error(FATAL, "hor_bnd_diffusion requires that visc%h_ML is associated.") + endif + ! This halo update is probably not necessary because visc%h_ML has valid halo data. + call pass_var(hbl, G%Domain, halo=1) ! build HBD grid call hbd_grid(SURFACE, G, GV, hbl, h, CS) @@ -336,10 +343,11 @@ subroutine hbd_grid(boundary, G, GV, hbl, h, CS) integer, intent(in ) :: boundary !< Which boundary layer SURFACE or BOTTOM [nondim] type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure - real, dimension(SZI_(G),SZJ_(G)) :: hbl !< Boundary layer depth [H ~> m or kg m-2] + real, dimension(SZI_(G),SZJ_(G)), & + intent(in) :: hbl !< Boundary layer depth [H ~> m or kg m-2] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & - intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] - type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure + intent(in) :: h !< Layer thickness in the native grid [H ~> m or kg m-2] + type(hbd_CS), pointer :: CS !< Horizontal diffusion control structure ! Local variables real, allocatable :: dz_top(:) !< temporary HBD grid given by merge_interfaces [H ~> m or kg m-2] diff --git a/src/tracer/MOM_neutral_diffusion.F90 b/src/tracer/MOM_neutral_diffusion.F90 index 094825d031..402a008244 100644 --- a/src/tracer/MOM_neutral_diffusion.F90 +++ b/src/tracer/MOM_neutral_diffusion.F90 @@ -20,6 +20,7 @@ module MOM_neutral_diffusion use MOM_remapping, only : average_value_ppoly, remappingSchemesDoc, remappingDefaultScheme use MOM_tracer_registry, only : tracer_registry_type, tracer_type use MOM_unit_scaling, only : unit_scale_type +use MOM_variables, only : vertvisc_type use MOM_verticalGrid, only : verticalGrid_type use polynomial_functions, only : evaluation_polynomial, first_derivative_polynomial use PPM_functions, only : PPM_reconstruction, PPM_boundary_extrapolation @@ -142,7 +143,7 @@ logical function neutral_diffusion_init(Time, G, GV, US, param_file, diag, EOS, type(diag_ctrl), target, intent(inout) :: diag !< Diagnostics control structure type(param_file_type), intent(in) :: param_file !< Parameter file structure type(EOS_type), target, intent(in) :: EOS !< Equation of state - type(diabatic_CS), pointer :: diabatic_CSp!< KPP control structure needed to get BLD + type(diabatic_CS), pointer :: diabatic_CSp!< diabatic control structure needed to get BLD type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure ! Local variables @@ -333,13 +334,15 @@ end function neutral_diffusion_init !> Calculate remapping factors for u/v columns used to map adjoining columns to !! a shared coordinate space. -subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) +subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, visc, CS, p_surf) type(ocean_grid_type), intent(in) :: G !< Ocean grid structure type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type 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) :: T !< Potential temperature [C ~> degC] real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), intent(in) :: S !< Salinity [S ~> ppt] + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! boundary layer properties and related fields type(neutral_diffusion_CS), pointer :: CS !< Neutral diffusion control structure real, dimension(SZI_(G),SZJ_(G)), optional, intent(in) :: p_surf !< Surface pressure to include in pressures used !! for equation of state calculations [R L2 T-2 ~> Pa] @@ -369,10 +372,13 @@ subroutine neutral_diffusion_calc_coeffs(G, GV, US, h, T, S, CS, p_surf) ! Check if hbl needs to be extracted if (CS%interior_only) then - if (ASSOCIATED(CS%KPP_CSp)) call KPP_get_BLD(CS%KPP_CSp, CS%hbl, G, US, m_to_BLD_units=GV%m_to_H) - if (ASSOCIATED(CS%energetic_PBL_CSp)) call energetic_PBL_get_MLD(CS%energetic_PBL_CSp, CS%hbl, G, US, & - m_to_MLD_units=GV%m_to_H) - call pass_var(CS%hbl,G%Domain) + if (associated(visc%h_ML)) then + CS%hbl(:,:) = visc%h_ML(:,:) + else + call MOM_error(FATAL, "hor_bnd_diffusion requires that visc%h_ML is associated.") + endif + call pass_var(CS%hbl, G%Domain, halo=1) + ! get k-indices and zeta do j=G%jsc-1, G%jec+1 ; do i=G%isc-1,G%iec+1 if (G%mask2dT(i,j) > 0.0) then diff --git a/src/tracer/MOM_tracer_hor_diff.F90 b/src/tracer/MOM_tracer_hor_diff.F90 index 732a42e44b..2b1530e94d 100644 --- a/src/tracer/MOM_tracer_hor_diff.F90 +++ b/src/tracer/MOM_tracer_hor_diff.F90 @@ -27,7 +27,7 @@ module MOM_tracer_hor_diff use MOM_hor_bnd_diffusion, only : hor_bnd_diffusion, hor_bnd_diffusion_end use MOM_tracer_registry, only : tracer_registry_type, tracer_type, MOM_tracer_chksum use MOM_unit_scaling, only : unit_scale_type -use MOM_variables, only : thermo_var_ptrs +use MOM_variables, only : thermo_var_ptrs, vertvisc_type use MOM_verticalGrid, only : verticalGrid_type implicit none ; private @@ -113,7 +113,7 @@ module MOM_tracer_hor_diff !! using the diffusivity in CS%KhTr, or using space-dependent diffusivity. !! Multiple iterations are used (if necessary) so that there is no limit !! on the acceptable time increment. -subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) +subroutine tracer_hordiff(h, dt, MEKE, VarMix, visc, G, GV, US, CS, Reg, tv, do_online_flag, read_khdt_x, read_khdt_y) type(ocean_grid_type), intent(inout) :: G !< Grid type type(verticalGrid_type), intent(in) :: GV !< ocean vertical grid structure real, dimension(SZI_(G),SZJ_(G),SZK_(GV)), & @@ -121,6 +121,8 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online real, intent(in) :: dt !< time step [T ~> s] type(MEKE_type), intent(in) :: MEKE !< MEKE fields type(VarMix_CS), intent(in) :: VarMix !< Variable mixing type + type(vertvisc_type), intent(in) :: visc !< Structure with vertical viscosities, + !! boundary layer properties and related fields type(unit_scale_type), intent(in) :: US !< A dimensional unit scaling type type(tracer_hor_diff_CS), pointer :: CS !< module control structure type(tracer_registry_type), pointer :: Reg !< registered tracers @@ -442,7 +444,7 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online if (itt>1) then ! Update halos for subsequent iterations call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) endif - call hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, & + call hor_bnd_diffusion(G, GV, US, h, Coef_x, Coef_y, I_numitts*dt, Reg, visc, & CS%hor_bnd_diffusion_CSp) enddo ! itt endif @@ -457,9 +459,9 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online ! would be inside the itt-loop. -AJA if (associated(tv%p_surf)) then - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) else - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp) endif do k=1,nz+1 @@ -499,9 +501,10 @@ subroutine tracer_hordiff(h, dt, MEKE, VarMix, G, GV, US, CS, Reg, tv, do_online call do_group_pass(CS%pass_t, G%Domain, clock=id_clock_pass) if (CS%recalc_neutral_surf) then if (associated(tv%p_surf)) then - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp, p_surf=tv%p_surf) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp, & + p_surf=tv%p_surf) else - call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, CS%neutral_diffusion_CSp) + call neutral_diffusion_calc_coeffs(G, GV, US, h, tv%T, tv%S, visc, CS%neutral_diffusion_CSp) endif endif endif From d66adffb53846016ec4793537e6bdc1998002ba9 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 25 Apr 2024 16:49:44 -0400 Subject: [PATCH 622/629] +*Pass visc%h_ML to call_tracer_column_fns Added the optional argument h_BL to call_tracer_column_fns, and then pass visc%h_ML to this routine as a part of the calls from the diabatic routines. This argument is not provided in adiabatic mode or in offline tracer mode, which is why it has been made optional. All answers are bitwise identical in Boussinesq mode but ideal age tracers can change in non-Boussinesq mode due to the updates to the layer specific volumes between the calculation of the boundary layer properties and the calls to call_tracer_column_fns. --- .../vertical/MOM_diabatic_driver.F90 | 13 +++++-------- .../vertical/MOM_set_viscosity.F90 | 6 ++++-- src/tracer/MOM_tracer_flow_control.F90 | 18 +++++++++++++++--- 3 files changed, 24 insertions(+), 13 deletions(-) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index f2446e0332..b450127156 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -1073,7 +1073,7 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & - minimum_forcing_depth=CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML) call cpu_clock_end(id_clock_tracers) @@ -1587,7 +1587,7 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, KPP_CSp=CS%KPP_CSp, & nonLocalTrans=KPP_NLTscalar, & evap_CFL_limit=CS%evap_CFL_limit, & - minimum_forcing_depth=CS%minimum_forcing_depth) + minimum_forcing_depth=CS%minimum_forcing_depth, h_BL=visc%h_ML) call cpu_clock_end(id_clock_tracers) @@ -2381,8 +2381,7 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, BLD, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & - KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=KPP_NLTscalar) + KPP_CSp=CS%KPP_CSp, nonLocalTrans=KPP_NLTscalar, h_BL=visc%h_ML) elseif (CS%double_diffuse) then ! extra diffusivity for passive tracers @@ -2403,14 +2402,12 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e call call_tracer_column_fns(hold, h, eatr, ebtr, fluxes, BLD, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & - KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=KPP_NLTscalar) + KPP_CSp=CS%KPP_CSp, nonLocalTrans=KPP_NLTscalar, h_BL=visc%h_ML) else call call_tracer_column_fns(hold, h, ea, eb, fluxes, BLD, dt, G, GV, US, tv, & CS%optics, CS%tracer_flow_CSp, CS%debug, & - KPP_CSp=CS%KPP_CSp, & - nonLocalTrans=KPP_NLTscalar) + KPP_CSp=CS%KPP_CSp, nonLocalTrans=KPP_NLTscalar, h_BL=visc%h_ML) endif ! (CS%mix_boundary_tracers) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index ab92a60950..e59e5d99aa 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -2693,7 +2693,7 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C logical, intent(in) :: use_ice_shelf !< if true, register tau_shelf restarts ! Local variables logical :: use_kappa_shear, KS_at_vertex - logical :: adiabatic, useKPP, useEPBL + logical :: adiabatic, useKPP, useEPBL, use_ideal_age logical :: do_brine_plume, use_hor_bnd_diff, use_neutral_diffusion, use_fpmix logical :: use_CVMix_shear, MLE_use_PBL_MLD, MLE_use_Bodner, use_CVMix_conv integer :: isd, ied, jsd, jed, nz @@ -2777,12 +2777,14 @@ subroutine set_visc_register_restarts(HI, G, GV, US, param_file, visc, restart_C default=.false., do_not_log=.true.) call get_param(param_file, mdl, "FPMIX", use_fpmix, & default=.false., do_not_log=.true.) + call get_param(param_file, mdl, "USE_IDEAL_AGE_TRACER", use_ideal_age, & + default=.false., do_not_log=.true.) if (MLE_use_PBL_MLD) then call safe_alloc_ptr(visc%MLD, isd, ied, jsd, jed) endif if ((hfreeze >= 0.0) .or. MLE_use_PBL_MLD .or. do_brine_plume .or. use_fpmix .or. & - use_neutral_diffusion .or. use_hor_bnd_diff) then + use_neutral_diffusion .or. use_hor_bnd_diff .or. use_ideal_age) then call safe_alloc_ptr(visc%h_ML, isd, ied, jsd, jed) endif diff --git a/src/tracer/MOM_tracer_flow_control.F90 b/src/tracer/MOM_tracer_flow_control.F90 index 10aba675da..ca85fc234f 100644 --- a/src/tracer/MOM_tracer_flow_control.F90 +++ b/src/tracer/MOM_tracer_flow_control.F90 @@ -429,7 +429,7 @@ end subroutine call_tracer_set_forcing !> This subroutine calls all registered tracer column physics subroutines. subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, US, tv, optics, CS, & - debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth) + debug, KPP_CSp, nonLocalTrans, evap_CFL_limit, minimum_forcing_depth, h_BL) 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_old !< Layer thickness before entrainment @@ -464,9 +464,11 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, !! of the top layer in a timestep [nondim] real, optional, intent(in) :: minimum_forcing_depth !< The smallest depth over !! which fluxes can be applied [H ~> m or kg m-2] + real, dimension(:,:), optional, pointer :: h_BL !< Thickness of active mixing layer [H ~> m or kg m-2] ! Local variables real :: Hbl(SZI_(G),SZJ_(G)) !< Boundary layer thickness [H ~> m or kg m-2] + logical :: use_h_BL if (.not. associated(CS)) call MOM_error(FATAL, "call_tracer_column_fns: "// & "Module must be initialized via call_tracer_register before it is used.") @@ -493,7 +495,12 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, evap_CFL_limit=evap_CFL_limit, & minimum_forcing_depth=minimum_forcing_depth) if (CS%use_ideal_age) then - call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) + use_h_BL = .false. ; if (present(h_BL)) use_h_BL = associated(h_BL) + if (present(h_BL)) then + Hbl(:,:) = h_BL(:,:) + else ! This option is here mostly to support the offline tracers. + call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) + endif call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%ideal_age_tracer_CSp, & evap_CFL_limit=evap_CFL_limit, & @@ -573,7 +580,12 @@ subroutine call_tracer_column_fns(h_old, h_new, ea, eb, fluxes, mld, dt, G, GV, call RGC_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%RGC_tracer_CSp) if (CS%use_ideal_age) then - call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) + use_h_BL = .false. ; if (present(h_BL)) use_h_BL = associated(h_BL) + if (present(h_BL)) then + Hbl(:,:) = h_BL(:,:) + else ! This option is here mostly to support the offline tracers. + call convert_MLD_to_ML_thickness(mld, h_new, Hbl, tv, G, GV) + endif call ideal_age_tracer_column_physics(h_old, h_new, ea, eb, fluxes, dt, & G, GV, US, CS%ideal_age_tracer_CSp, Hbl=Hbl) endif From 0578393e48d7ee3bb73b01072146b57f59b469eb Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Sat, 8 Jun 2024 11:27:59 -0400 Subject: [PATCH 623/629] Remove diag_send_complete from disable_averaging diag_send_complete() is removed from disable_averaging(), due to potential performance costs over sweeping through files and variables for synchronization across nodes or other thread-like backround operations. It also prevents potential errors in drivers where diag_manager_set_time_end was unset. We will come back to this issue and work out a better strategy for diagnostic synchronization. --- src/framework/MOM_diag_mediator.F90 | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/framework/MOM_diag_mediator.F90 b/src/framework/MOM_diag_mediator.F90 index b3194af3d8..5475e79627 100644 --- a/src/framework/MOM_diag_mediator.F90 +++ b/src/framework/MOM_diag_mediator.F90 @@ -14,7 +14,6 @@ module MOM_diag_mediator use MOM_diag_manager_infra, only : send_data_infra, MOM_diag_field_add_attribute, EAST, NORTH use MOM_diag_manager_infra, only : register_diag_field_infra, register_static_field_infra use MOM_diag_manager_infra, only : get_MOM_diag_field_id, DIAG_FIELD_NOT_FOUND -use MOM_diag_manager_infra, only : diag_send_complete_infra use MOM_diag_remap, only : diag_remap_ctrl, diag_remap_update, diag_remap_calc_hmask use MOM_diag_remap, only : diag_remap_init, diag_remap_end, diag_remap_do_remap use MOM_diag_remap, only : vertically_reintegrate_diag_field, vertically_interpolate_diag_field @@ -2079,10 +2078,8 @@ end subroutine enable_averages subroutine disable_averaging(diag_cs) type(diag_ctrl), intent(inout) :: diag_CS !< Structure used to regulate diagnostic output - call diag_send_complete_infra() diag_cs%time_int = 0.0 diag_cs%ave_enabled = .false. - end subroutine disable_averaging !> Call this subroutine to determine whether the averaging is From b4ae2b752230fb95dc8dd12564f4223771227fe2 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Mon, 17 Jun 2024 11:30:01 -0400 Subject: [PATCH 624/629] Disable nonrepro FMAs in convex BBL solver Three FMAs were introduced when the BBL convex L(:) computation were moved to a separate function. Parentheses have been added to disable these FMAs. Calculation of the cell width fractions `L` was consolidated and moved into a new function, `find_L_open_concave_analytic` (later renamed to `find_open_L_open_concave_trigonometric`). When compiled with Intel and using the following flags, -O2 -march=core-avx2 -fp-model source -qno-opt-dynamic-align additional FMAs are added to the function, specifically the following expressions: crv_3 = (Dp + Dm - 2.0*D_vel) L(K) = L0*(1.0 + ax2_3apb*L0) L(K) = apb_4a * (1.0 - 2.0 * cos( C1_3*acos(a2x48_apb3*vol_below(K) - 1.0) - C2pi_3) ) (Third expression FMA was added inside of `acos()` by the compiler) The crucial flag seems to be `-march=core-avx2` which controls the introduction of FMAs and explains why the problem went undetected. The legacy answers were restored by adding new parentheses to the above equations. Since this function is not generally considered reproducible and is provided for legacy support, the loss of performance is not considered to be an issue. --- src/parameterizations/vertical/MOM_set_viscosity.F90 | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/src/parameterizations/vertical/MOM_set_viscosity.F90 b/src/parameterizations/vertical/MOM_set_viscosity.F90 index e59e5d99aa..d1d333b5ce 100644 --- a/src/parameterizations/vertical/MOM_set_viscosity.F90 +++ b/src/parameterizations/vertical/MOM_set_viscosity.F90 @@ -1178,7 +1178,8 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) ! Each cell extends from x=-1/2 to 1/2, and has a topography ! given by D(x) = crv*x^2 + slope*x + D_vel - crv/12. - crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + !crv_3 = (Dp + Dm - 2.0*D_vel) ; crv = 3.0*crv_3 + crv_3 = (Dp + Dm - (2.0*D_vel)) ; crv = 3.0*crv_3 slope = Dp - Dm ! Calculate the volume above which the entire cell is open and the volume at which the @@ -1205,10 +1206,13 @@ subroutine find_L_open_concave_trigonometric(vol_below, D_vel, Dp, Dm, L, GV) ! vol_below(K) = 0.5*L^2*(slope + crv/3*(3-4L)). if (a2x48_apb3*vol_below(K) < 1e-8) then ! Could be 1e-7? ! There is a very good approximation here for massless layers. - L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) + !L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + ax2_3apb*L0) + L0 = sqrt(2.0*vol_below(K)*Iapb) ; L(K) = L0*(1.0 + (ax2_3apb*L0)) else + !L(K) = apb_4a * (1.0 - & + ! 2.0 * cos(C1_3*acos(a2x48_apb3*vol_below(K) - 1.0) - C2pi_3)) L(K) = apb_4a * (1.0 - & - 2.0 * cos(C1_3*acos(a2x48_apb3*vol_below(K) - 1.0) - C2pi_3)) + 2.0 * cos(C1_3*acos((a2x48_apb3*vol_below(K)) - 1.0) - C2pi_3)) endif ! To check the answers. ! Vol_err = 0.5*(L(K)*L(K))*(slope + crv_3*(3.0-4.0*L(K))) - vol_below(K) From ac2b642f4f60dbfeebcaef5f1d08d202e3a01b56 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 2 Jul 2024 15:44:08 -0400 Subject: [PATCH 625/629] Re-initialize fields within KPP Five fields associated with KPP were previously initialized during allocation (using `source=0.`). It was found that the allocations were unnecessary, and the fields were redefined as local variables within functions, without the initialization to zero. Although the uninitialized points were masked and unused in the rest of the model, they were still able to change the checksums and were being reported as regressions. This patch restores the original checksums by re-implementing the zero initialization. Thanks to Bob Hallberg (@Hallberg-NOAA) for diagnosing this issue. --- .../vertical/MOM_diabatic_driver.F90 | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/src/parameterizations/vertical/MOM_diabatic_driver.F90 b/src/parameterizations/vertical/MOM_diabatic_driver.F90 index b450127156..d7cb102e05 100644 --- a/src/parameterizations/vertical/MOM_diabatic_driver.F90 +++ b/src/parameterizations/vertical/MOM_diabatic_driver.F90 @@ -676,6 +676,14 @@ subroutine diabatic_ALE_legacy(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Tim call cpu_clock_begin(id_clock_kpp) ! total vertical viscosity in the interior is represented via visc%Kv_shear + ! NOTE: The following do not require initialization, but their checksums do + ! require initialization, and past versions were initialized to zero. + KPP_NLTheat(:,:,:) = 0. + KPP_NLTscalar(:,:,:) = 0. + KPP_buoy_flux(:,:,:) = 0. + KPP_temp_flux(:,:) = 0. + KPP_salt_flux(:,:) = 0. + ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux @@ -1288,6 +1296,14 @@ subroutine diabatic_ALE(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_end, visc%Kv_shear(i,j,k) = visc%Kv_shear(i,j,k) + visc%Kv_slow(i,j,k) enddo ; enddo ; enddo + ! NOTE: The following do not require initialization, but their checksums do + ! require initialization, and past versions were initialized to zero. + KPP_NLTheat(:,:,:) = 0. + KPP_NLTscalar(:,:,:) = 0. + KPP_buoy_flux(:,:,:) = 0. + KPP_temp_flux(:,:) = 0. + KPP_salt_flux(:,:) = 0. + ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux @@ -1885,6 +1901,15 @@ subroutine layered_diabatic(u, v, h, tv, BLD, fluxes, visc, ADp, CDp, dt, Time_e if (CS%useKPP) then call cpu_clock_begin(id_clock_kpp) + + ! NOTE: The following do not require initialization, but their checksums do + ! require initialization, and past versions were initialized to zero. + KPP_NLTheat(:,:,:) = 0. + KPP_NLTscalar(:,:,:) = 0. + KPP_buoy_flux(:,:,:) = 0. + KPP_temp_flux(:,:) = 0. + KPP_salt_flux(:,:) = 0. + ! KPP needs the surface buoyancy flux but does not update state variables. ! We could make this call higher up to avoid a repeat unpacking of the surface fluxes. ! Sets: KPP_buoy_flux, KPP_temp_flux, KPP_salt_flux From 3fac1c5ab53335e6e07086f373fd3142b704ec25 Mon Sep 17 00:00:00 2001 From: Marshall Ward Date: Tue, 2 Jul 2024 22:29:24 -0400 Subject: [PATCH 626/629] Allow incorrect PPM:H3 tracer advection stencil Due to answer changes in multiple production experiments, this patch introduces a new parameter, USE_HUYNH_STENCIL_BUG, which sets the tracer advection stencil width to its previous incorrect value. This parameter replicates the previous method, which keeps `stencil` at 2 when PPM:H3 is used. ---- The logical parameters are * P = CS%usePPM * H = CS%useHuynh * E = USE_HUYNH_STENCIL_BUG * R = CS%useHuynhStencilBug The three expressions of interest: 1. P & ~H 2. P 3. P & ~R (1) is the original incorrect expression, (2) is the fixed expression, and (3) is the proposed update. What we want: If E is false, then (3) should reduce to (2). If E is true, then (3) should reduce to (1). R is computed as follows: * R = False (from derived type initialization) * if (H) R = E (from get_param call) This is equivalent to R = H & E, and (3) is P & ~(H & E). * If E is False, then P & ~(H & False) = P. * If E is True, then P & ~(H & True) = P & ~H So this flag should replicate both the previous and current behavior. --- src/tracer/MOM_tracer_advect.F90 | 19 ++++++++++++++++--- 1 file changed, 16 insertions(+), 3 deletions(-) diff --git a/src/tracer/MOM_tracer_advect.F90 b/src/tracer/MOM_tracer_advect.F90 index b77949342d..e927f2f89d 100644 --- a/src/tracer/MOM_tracer_advect.F90 +++ b/src/tracer/MOM_tracer_advect.F90 @@ -34,6 +34,8 @@ module MOM_tracer_advect logical :: debug !< If true, write verbose checksums for debugging purposes. logical :: usePPM !< If true, use PPM instead of PLM logical :: useHuynh !< If true, use the Huynh scheme for PPM interface values + logical :: useHuynhStencilBug = .false. !< If true, use the incorrect stencil width. + !! This is provided for compatibility with legacy simuations. type(group_pass_type) :: pass_uhr_vhr_t_hprev !< A structure used for group passes end type tracer_advect_CS @@ -94,6 +96,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first ! can be simply discarded [H L2 ~> m3 or kg]. real :: landvolfill ! An arbitrary? nonzero cell volume [H L2 ~> m3 or kg]. + logical :: use_PPM_stencil ! If true, use the correct PPM stencil width. real :: Idt ! 1/dt [T-1 ~> s-1]. logical :: domore_u(SZJ_(G),SZK_(GV)) ! domore_u and domore_v indicate whether there is more logical :: domore_v(SZJB_(G),SZK_(GV)) ! advection to be done in the corresponding row or column. @@ -112,7 +115,7 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first isd = G%isd ; ied = G%ied ; jsd = G%jsd ; jed = G%jed IsdB = G%IsdB ; IedB = G%IedB ; JsdB = G%JsdB ; JedB = G%JedB landvolfill = 1.0e-20 ! This is arbitrary, but must be positive. - stencil = 2 ! The scheme's stencil; 2 for PLM and PPM:H3 + stencil = 2 ! The scheme's stencil; 2 for PLM if (.not. associated(CS)) call MOM_error(FATAL, "MOM_tracer_advect: "// & "tracer_advect_init must be called before advect_tracer.") @@ -123,8 +126,8 @@ subroutine advect_tracer(h_end, uhtr, vhtr, OBC, dt, G, GV, US, CS, Reg, x_first x_first = (MOD(G%first_direction,2) == 0) ! increase stencil size for Colella & Woodward PPM -! if (CS%usePPM .and. .not. CS%useHuynh) stencil = 3 - if (CS%usePPM) stencil = 3 + use_PPM_stencil = CS%usePPM .and. .not. CS%useHuynhStencilBug + if (use_PPM_stencil) stencil = 3 ntr = Reg%ntr Idt = 1.0 / dt @@ -1130,6 +1133,16 @@ subroutine tracer_advect_init(Time, G, US, param_file, diag, CS) "Unknown TRACER_ADVECTION_SCHEME = "//trim(mesg)) end select + if (CS%useHuynh) then + call get_param(param_file, mdl, "USE_HUYNH_STENCIL_BUG", & + CS%useHuynhStencilBug, & + desc="If true, use a stencil width of 2 in PPM:H3 tracer advection. " & + // "This is incorrect and will produce regressions in certain " & + // "configurations, but may be required to reproduce results in " & + // "legacy simulations.", & + default=.false.) + endif + id_clock_advect = cpu_clock_id('(Ocean advect tracer)', grain=CLOCK_MODULE) id_clock_pass = cpu_clock_id('(Ocean tracer halo updates)', grain=CLOCK_ROUTINE) id_clock_sync = cpu_clock_id('(Ocean tracer global synch)', grain=CLOCK_ROUTINE) From 00f7d231ab7a106a080f8899904989524262678a Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Sun, 14 Jul 2024 11:42:38 -0400 Subject: [PATCH 627/629] (*)+Restore USE_WRIGHT_2ND_DERIV_BUG functionality This commit restores the effectiveness of the runtime parameter USE_WRIGHT_2ND_DERIV_BUG in determining whether a bug is corrected in the calculation of two of the second derivative terms returned by calculate_density_second_derivs_elem() with the "WRIGHT" equation of state, recreating the behavior (and answers) that are currently on the main branch of MOM6. To do this, it adds and calls the new routine set_params_buggy_Wright() when appropriate, and adds the new element "three" to the buggy_Wright_EOS type. When the bug is fixed, buggy_Wright_EOS%three = 3, but ...%three = 2 to recreate the bug. This commit does change answers for cases using the "WRIGHT" equation of state and one of the "USE_STANLEY_..." parameterizations from those on the dev/gfdl branch of MOM6, but in so doing it restores the answers on the main branch of MOM6. There is also a new publicly visible subroutine. --- src/equation_of_state/MOM_EOS.F90 | 3 +++ src/equation_of_state/MOM_EOS_Wright.F90 | 31 +++++++++++++++++++++--- 2 files changed, 31 insertions(+), 3 deletions(-) diff --git a/src/equation_of_state/MOM_EOS.F90 b/src/equation_of_state/MOM_EOS.F90 index 7a9de49573..1567d20692 100644 --- a/src/equation_of_state/MOM_EOS.F90 +++ b/src/equation_of_state/MOM_EOS.F90 @@ -1526,6 +1526,7 @@ subroutine EOS_init(param_file, EOS, US) "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.) + call EOS_manual_init(EOS, form_of_EOS=EOS_WRIGHT, use_Wright_2nd_deriv_bug=EOS%use_Wright_2nd_deriv_bug) endif EOS_quad_default = .not.((EOS%form_of_EOS == EOS_LINEAR) .or. & @@ -1645,6 +1646,8 @@ subroutine EOS_manual_init(EOS, form_of_EOS, form_of_TFreeze, EOS_quadrature, Co select type (t => EOS%type) type is (linear_EOS) call t%set_params_linear(Rho_T0_S0, dRho_dT, dRho_dS) + type is (buggy_Wright_EOS) + call t%set_params_buggy_Wright(use_Wright_2nd_deriv_bug) end select endif if (present(form_of_TFreeze)) EOS%form_of_TFreeze = form_of_TFreeze diff --git a/src/equation_of_state/MOM_EOS_Wright.F90 b/src/equation_of_state/MOM_EOS_Wright.F90 index 8b6d6495d1..d4b091b7b2 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 buggy_Wright_EOS public int_density_dz_wright, int_spec_vol_dp_wright public avg_spec_vol_buggy_Wright +public set_params_buggy_Wright !>@{ 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]. @@ -39,6 +40,8 @@ module MOM_EOS_Wright !> The EOS_base implementation of the Wright 1997 equation of state with some bugs type, extends (EOS_base) :: buggy_Wright_EOS + real :: three = 3.0 !< A constant that can be adjusted to recreate some bugs [nondim] + contains !> Implementation of the in-situ density as an elemental function [kg m-3] procedure :: density_elem => density_elem_buggy_Wright @@ -59,6 +62,9 @@ module MOM_EOS_Wright !> Implementation of the range query function procedure :: EOS_fit_range => EOS_fit_range_buggy_Wright + !> Instance specific function to set internal parameters + procedure :: set_params_buggy_Wright => set_params_buggy_Wright + !> Local implementation of generic calculate_density_array for efficiency procedure :: calculate_density_array => calculate_density_array_buggy_Wright !> Local implementation of generic calculate_spec_vol_array for efficiency @@ -228,13 +234,16 @@ elemental subroutine calculate_density_second_derivs_elem_buggy_Wright(this, T, 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 :: six ! A constant that can be adjusted from 6. to 4. to recreate a bug [nondim] ! Based on the above expression with common terms factored, there probably exists a more numerically stable ! and/or efficient expression + six = 2.0*this%three ! When recreating a bug from the original version of this routine, six = 4. + z0 = T*(b1 + b5*S + T*(b2 + b3*T)) z1 = (b0 + pressure + b4*S + z0) - z3 = (b1 + b5*S + T*(2.*b2 + 2.*b3*T)) ! BUG: This should be z3 = b1 + b5*S + T*(2.*b2 + 3.*b3*T) + z3 = (b1 + b5*S + T*(2.*b2 + this%three*b3*T)) ! When recreating a bug here this%three = 2. z4 = (c0 + c4*S + T*(c1 + c5*S + T*(c2 + c3*T))) z5 = (b1 + b5*S + T*(b2 + b3*T) + T*(b2 + 2.*b3*T)) z6 = c1 + c5*S + T*(c2 + c3*T) + T*(c2 + 2.*c3*T) @@ -249,8 +258,7 @@ elemental subroutine calculate_density_second_derivs_elem_buggy_Wright(this, T, drho_ds_ds = (z10*(c4 + c5*T) - a2*z10*z1 - z10*z7)/z2_2 - (2.*(c4 + c5*T + z9*z10 + a2*z1)*z11)/z2_3 drho_ds_dt = (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) should be (2.*b2 + 6.*b3*T) - drho_dt_dt = (z3*z6 - z1*(2.*c2 + 6.*c3*T + a1*z5) + (2.*b2 + 4.*b3*T)*z4 - z5*z8)/z2_2 - & + drho_dt_dt = (z3*z6 - z1*(2.*c2 + 6.*c3*T + a1*z5) + (2.*b2 + six*b3*T)*z4 - z5*z8)/z2_2 - & (2.*(z6 + z9*z5 + a1*z1)*(z3*z4 - z1*z8))/z2_3 drho_ds_dp = (-c4 - c5*T - 2.*a2*z1)/z2_2 - (2.*z9*z11)/z2_3 drho_dt_dp = (-c1 - c5*S - T*(2.*c2 + 3.*c3*T) - 2.*a1*z1)/z2_2 - (2.*z9*(z3*z4 - z1*z8))/z2_3 @@ -925,6 +933,23 @@ subroutine calculate_spec_vol_array_buggy_Wright(this, T, S, pressure, specvol, end subroutine calculate_spec_vol_array_buggy_Wright +!> Set coefficients that can correct bugs un the buggy Wright equation of state. +subroutine set_params_buggy_Wright(this, use_Wright_2nd_deriv_bug) + class(buggy_Wright_EOS), intent(inout) :: this !< This EOS + logical, optional, intent(in) :: use_Wright_2nd_deriv_bug !< If true, use a buggy + !! 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. + + this%three = 3.0 + if (present(use_Wright_2nd_deriv_bug)) then + if (use_Wright_2nd_deriv_bug) then ; this%three = 2.0 + else ; this%three = 3.0 ; endif + endif + +end subroutine set_params_buggy_Wright + + !> \namespace mom_eos_wright !! !! \section section_EOS_Wright Wright equation of state From 40f47212389b180f648ea0679408085941d70955 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Fri, 19 Jul 2024 04:47:34 -0400 Subject: [PATCH 628/629] *Possibly initialize h_ML from MLD in restart file Moved a check for whether to initialize an uninitialized visc%h_ML field from visc%MLD outside of the test for the value of CS%mixedlayer_restart. This change will prevent answer changes between code versions for certain cases that initialize from a restart file, use the melt_potential field and have MLE_USE_PBL_MLD = True but also have MIXEDLAYER_RESTRAT = False. This commit corrects a very specific oversight that was introduced when the roles of visc%h_ML and visc%MLD were separated, and it can change answers (reverting them to answers from older versions of the main branch of MOM6) in very specific cases where MOM6 is initialized from a restart file from an older versions of the code, including the 5x5-degree test case in the dev/emc regression suite. --- src/core/MOM.F90 | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index e6a42ef7a7..d190b83e3b 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -3270,17 +3270,18 @@ subroutine initialize_MOM(Time, Time_init, param_file, dirs, CS, & CS%mixedlayer_restrat = mixedlayer_restrat_init(Time, G, GV, US, param_file, diag, & CS%mixedlayer_restrat_CSp, restart_CSp) - if (CS%mixedlayer_restrat) then - if (GV%Boussinesq .and. associated(CS%visc%h_ML)) then - ! This is here to allow for a transition of restart files between model versions. - call get_param(param_file, "MOM", "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & - default=.false., do_not_log=.true.) - if (MLE_use_PBL_MLD .and. .not.query_initialized(CS%visc%h_ML, "h_ML", restart_CSp) .and. & - associated(CS%visc%MLD)) then - do j=js,je ; do i=is,ie ; CS%visc%h_ML(i,j) = GV%Z_to_H * CS%visc%MLD(i,j) ; enddo ; enddo - endif + + if (GV%Boussinesq .and. associated(CS%visc%h_ML)) then + ! This is here to allow for a transition of restart files between model versions. + call get_param(param_file, "MOM", "MLE_USE_PBL_MLD", MLE_use_PBL_MLD, & + default=.false., do_not_log=.true.) + if (MLE_use_PBL_MLD .and. .not.query_initialized(CS%visc%h_ML, "h_ML", restart_CSp) .and. & + associated(CS%visc%MLD)) then + do j=js,je ; do i=is,ie ; CS%visc%h_ML(i,j) = GV%Z_to_H * CS%visc%MLD(i,j) ; enddo ; enddo endif + endif + if (CS%mixedlayer_restrat) then if (.not.(bulkmixedlayer .or. CS%use_ALE_algorithm)) & call MOM_error(FATAL, "MOM: MIXEDLAYER_RESTRAT true requires a boundary layer scheme.") ! When DIABATIC_FIRST=False and using CS%visc%ML in mixedlayer_restrat we need to update after a restart From ee686c8d7c94e577882f935bae0c743559df0003 Mon Sep 17 00:00:00 2001 From: Robert Hallberg Date: Thu, 18 Jul 2024 17:22:33 -0400 Subject: [PATCH 629/629] Improve MOM_surface_chksum Added checksum calls for the melt_potential, ocean_mass, ocean_heat and ocean_salt elements of the surface state in MOM_surface_chksum if these fields are allocated for more comprehensive debugging. Also added the symmetric optional argument to the call to MOM_surface_chksum form extract_surface_state so that all of the surface velocity values that could contribute to the ocean surface velocities that are seen by the coupler are checksummed. All solutions are bitwise identical, but there are enhancements to the MOM6 debugging capabilities. --- src/core/MOM.F90 | 2 +- src/core/MOM_checksum_packages.F90 | 10 +++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/core/MOM.F90 b/src/core/MOM.F90 index d190b83e3b..de58a2f3bb 100644 --- a/src/core/MOM.F90 +++ b/src/core/MOM.F90 @@ -4028,7 +4028,7 @@ subroutine extract_surface_state(CS, sfc_state_in) endif endif - if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0) + if (CS%debug) call MOM_surface_chksum("Post extract_sfc", sfc_state, G, US, haloshift=0, symmetric=.true.) ! Rotate sfc_state back onto the input grid, sfc_state_in if (CS%rotate_index) then diff --git a/src/core/MOM_checksum_packages.F90 b/src/core/MOM_checksum_packages.F90 index dc60e0888f..b892742cf3 100644 --- a/src/core/MOM_checksum_packages.F90 +++ b/src/core/MOM_checksum_packages.F90 @@ -167,7 +167,7 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) logical :: sym sym = .false. ; if (present(symmetric)) sym = symmetric - hs = 1 ; if (present(haloshift)) hs = haloshift + hs = 0 ; if (present(haloshift)) hs = haloshift if (allocated(sfc_state%SST)) call hchksum(sfc_state%SST, mesg//" SST", G%HI, haloshift=hs, & scale=US%C_to_degC) @@ -182,6 +182,14 @@ subroutine MOM_surface_chksum(mesg, sfc_state, G, US, haloshift, symmetric) scale=US%L_T_to_m_s) if (allocated(sfc_state%frazil)) call hchksum(sfc_state%frazil, mesg//" frazil", G%HI, & haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (allocated(sfc_state%melt_potential)) call hchksum(sfc_state%melt_potential, mesg//" melt_potential", & + G%HI, haloshift=hs, scale=US%Q_to_J_kg*US%RZ_to_kg_m2) + if (allocated(sfc_state%ocean_mass)) call hchksum(sfc_state%ocean_mass, mesg//" ocean_mass", & + G%HI, haloshift=hs, scale=US%RZ_to_kg_m2) + if (allocated(sfc_state%ocean_heat)) call hchksum(sfc_state%ocean_heat, mesg//" ocean_heat", & + G%HI, haloshift=hs, scale=US%C_to_degC*US%RZ_to_kg_m2) + if (allocated(sfc_state%ocean_salt)) call hchksum(sfc_state%ocean_salt, mesg//" ocean_salt", & + G%HI, haloshift=hs, scale=US%S_to_ppt*US%RZ_to_kg_m2) end subroutine MOM_surface_chksum